From 34f360fef785133f7c7dcc1de4f28d6f853b7980 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 13 Jan 2011 17:22:43 +0900 Subject: [PATCH] cosmetic change. --- Info.hs | 101 ++++++++++++++++++++++++-------------------------- ghc-mod.cabal | 3 +- 2 files changed, 50 insertions(+), 54 deletions(-) diff --git a/Info.hs b/Info.hs index cb2d71a..f4afcaa 100644 --- a/Info.hs +++ b/Info.hs @@ -22,41 +22,11 @@ type ModuleString = String typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String typeExpr _ modstr expr file = (++ "\n") <$> typeOf file modstr expr -inModuleContext :: FilePath -> ModuleString -> Ghc String -> IO String -inModuleContext fileName modstr action = - withGHC $ valid `gcatch` constE invalid `gcatch` constE (return errorMessage) - where - valid = do - initSession ["-w"] - setTargetFile fileName - loadWithLogger (\_ -> return ()) LoadAllTargets - ok <- setContextFromTarget - if ok - then action - else throw $ ErrorCall errorMessage - -- this will be caught anyway - invalid = do - initSession ["-w"] - modgraph <- depanal [mkModuleName modstr] True - let imports = concatMap (map (showSDoc . ppr . unLoc)) $ - map ms_imps modgraph ++ map ms_srcimps modgraph - importsBuf <- liftIO . stringToStringBuffer . unlines $ - ("module " ++ sanitize modstr ++ " where") : imports - clkTime <- liftIO getClockTime - setTargets [Target (TargetModule $ mkModuleName modstr) True - (Just (importsBuf, clkTime))] - loadWithLogger defaultWarnErrLogger LoadAllTargets - ok <- setContextFromTarget - if ok - then action - else return errorMessage - errorMessage = "Couldn't determine type" - sanitize = fromMaybe "SomeModule" . listToMaybe . words - typeOf :: FilePath -> ModuleString -> Expression -> IO String -typeOf fileName modstr expr = inModuleContext fileName modstr - (pretty <$> exprType expr) - where pretty = showSDocForUser neverQualify . pprTypeForUser False +typeOf fileName modstr expr = + inModuleContext fileName modstr (pretty <$> exprType expr) + where + pretty = showSDocForUser neverQualify . pprTypeForUser False ---------------------------------------------------------------- @@ -65,14 +35,15 @@ infoExpr _ modstr expr file = (++ "\n") <$> info file modstr expr info :: FilePath -> ModuleString -> FilePath -> IO String info fileName modstr expr = inModuleContext fileName modstr (infoThing expr) - where infoThing str = do - names <- parseName str - mb_stuffs <- mapM getInfo names - let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) - unqual <- getPrintUnqual - return $ showSDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered) + where + -- ghc/InteractiveUI.hs + infoThing str = do + names <- parseName str + mb_stuffs <- mapM getInfo names + let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) + unqual <- getPrintUnqual + return $ showSDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered) --- ghc/InteractiveUI.hs filterOutChildren :: (a -> TyThing) -> [a] -> [a] filterOutChildren get_thing xs = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] @@ -81,9 +52,9 @@ filterOutChildren get_thing xs pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc pprInfo pefas (thing, fixity, insts) - = pprTyThingInContextLoc pefas thing - $$ show_fixity fixity - $$ vcat (map pprInstance insts) + = pprTyThingInContextLoc pefas thing + $$ show_fixity fixity + $$ vcat (map pprInstance insts) where show_fixity fix | fix == defaultFixity = empty @@ -91,19 +62,43 @@ pprInfo pefas (thing, fixity, insts) ---------------------------------------------------------------- +inModuleContext :: FilePath -> ModuleString -> Ghc String -> IO String +inModuleContext fileName modstr action = withGHC valid + where + valid = do + initSession ["-w"] + setTargetFile fileName + loadWithLogger (\_ -> return ()) LoadAllTargets + ok <- setContextFromTarget + if ok + then action + else invalid + invalid = do + initSession ["-w"] + dummyModule + loadWithLogger defaultWarnErrLogger LoadAllTargets + ok <- setContextFromTarget + if ok + then action + else return errorMessage + dummyModule = do + modgraph <- depanal [mkModuleName modstr] True + let imports = concatMap (map (showSDoc . ppr . unLoc)) $ + map ms_imps modgraph ++ map ms_srcimps modgraph + moddef = "module " ++ sanitize modstr ++ " where" + header = moddef : imports + importsBuf <- liftIO . stringToStringBuffer . unlines $ header + clkTime <- liftIO getClockTime + setTargets [Target (TargetModule $ mkModuleName modstr) True (Just (importsBuf, clkTime))] + sanitize = fromMaybe "SomeModule" . listToMaybe . words + errorMessage = "Couldn't determine type" + setContextFromTarget :: Ghc Bool setContextFromTarget = do ms <- depanal [] False - -- ms <- getModuleGraph -- this is the same top <- map ms_mod <$> filterM isTop ms - {- - top is a set of this module and your-defined modules. - If this module has syntax errors, it cannot be specified. - And if there is no your-defined modules, top is []. - In this case, we cannot obtain the type of an expression, sigh. - -} setContext top [] - return . not $ top == [] + return (top /= []) where isTop ms = lookupMod `gcatch` returnFalse where @@ -113,4 +108,4 @@ setContextFromTarget = do ---------------------------------------------------------------- constE :: a -> (SomeException -> a) -constE func _ = func +constE func = \_ -> func diff --git a/ghc-mod.cabal b/ghc-mod.cabal index d820259..ca0e840 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -29,7 +29,8 @@ Executable ghc-mod else GHC-Options: -Wall Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, - process, directory, filepath, hlint >= 1.7.1, old-time == 1.0.* + process, directory, filepath, old-time, + hlint >= 1.7.1 Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/ghc-mod.git