ghc-mod/Info.hs

95 lines
3.0 KiB
Haskell
Raw Normal View History

2010-11-12 07:27:50 +00:00
module Info where
2010-11-15 05:46:59 +00:00
import Control.Applicative hiding (empty)
import Data.Maybe
2010-11-12 07:27:50 +00:00
import GHC
import Outputable
import PprTyThing
import Types
2010-11-15 05:46:59 +00:00
import NameSet
import HscTypes
import Data.List
import Control.Exception
type Expression = String
type ModuleString = String
2010-11-15 05:46:59 +00:00
----------------------------------------------------------------
2010-11-12 07:27:50 +00:00
typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String
typeExpr _ modstr expr file = (++ "\n") <$> typeOf file modstr expr
2010-11-12 07:27:50 +00:00
typeOf :: FilePath -> ModuleString-> Expression -> IO String
typeOf fileName modstr expr = withGHC $ valid `gcatch` invalid
2010-11-12 07:27:50 +00:00
where
valid = makeTypeOf LoadAllTargets
invalid = constE invalid0
invalid0 = makeTypeOf $ LoadDependenciesOf (mkModuleName modstr)
makeTypeOf x = do
initSession ["-w"]
setTargetFile fileName
loadWithLogger (\_ -> return ()) x
setContextFromTarget
pretty <$> exprType expr
2010-11-12 07:27:50 +00:00
pretty = showSDocForUser neverQualify . pprTypeForUser False
2010-11-15 05:46:59 +00:00
----------------------------------------------------------------
infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String
infoExpr _ modstr expr file = (++ "\n") <$> info file modstr expr
2010-11-15 05:46:59 +00:00
info :: FilePath -> ModuleString -> FilePath -> IO String
info fileName modstr expr = withGHC $ valid `gcatch` invalid
2010-11-15 05:46:59 +00:00
where
valid = makeInfo LoadAllTargets
invalid = constE invalid0
invalid0 = makeInfo $ LoadDependenciesOf (mkModuleName modstr)
makeInfo x = do
initSession ["-w"]
setTargetFile fileName
loadWithLogger (\_ -> return ()) x
setContextFromTarget
infoThing expr
2010-11-15 05:46:59 +00:00
-- 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)]
where
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
pprInfo pefas (thing, fixity, insts)
= pprTyThingInContextLoc pefas thing
$$ show_fixity fixity
$$ vcat (map pprInstance insts)
where
show_fixity fix
| fix == defaultFixity = empty
| otherwise = ppr fix <+> ppr (getName thing)
----------------------------------------------------------------
setContextFromTarget :: Ghc ()
setContextFromTarget = do
ms <- depanal [] False
mdls <- mapM toModule ms
setContext (catMaybes mdls) []
where
toModule ms = lookupMod `gcatch` nothing
where
lookupMod = lookupModule (ms_mod_name ms) Nothing >>= return . Just
nothing = constE $ return Nothing
----------------------------------------------------------------
constE :: a -> (SomeException -> a)
constE func = \_ -> func