module Scion.Inspect.DefinitionSite where
import Scion.Types
import Scion.Types.Notes
import GHC
import Name ( getOccString, getSrcSpan )
import Outputable ( showSDoc, ppr, Outputable, (<+>) )
import PprTyThing ( pprTyThingInContext )
import TyCon ( isCoercionTyCon, isFamInstTyCon )
import Var ( globalIdVarDetails )
import IdInfo ( GlobalIdDetails(..) )
import HscTypes ( isBootSummary )
import qualified Data.Map as M
import Data.List ( foldl' )
import Data.Monoid
import Control.Monad ( foldM )
moduleGraphDefSiteDB ::
FilePath
-> ModuleGraph
-> ScionM DefSiteDB
moduleGraphDefSiteDB base_dir mg = do
let mg' = filter (not . isBootSummary) mg
foldM go emptyDefSiteDB mg'
where
go db modsum = do
db1 <- moduleSiteDB (base_dir, ms_mod modsum)
return (db1 `mappend` db)
moduleSiteDB :: (FilePath, Module)
-> ScionM DefSiteDB
moduleSiteDB (base_dir, mdl) = do
mb_mod_info <- getModuleInfo mdl
case mb_mod_info of
Nothing -> return emptyDefSiteDB
Just mod_info -> do
return $ mkSiteDB base_dir (modInfoTyThings mod_info)
mkSiteDB :: FilePath -> [TyThing] -> DefSiteDB
mkSiteDB base_dir ty_things = foldl' go emptyDefSiteDB ty_things
where
go db (ATyCon tycon) | is_boring_tycon tycon = db
go db (ADataCon datacon) | is_boring_datacon datacon = db
go db (AnId nm)
| isDictonaryId nm || not (is_interesting_id nm) = db
go db ty_thing =
addToDB (getOccString ty_thing)
(ghcSpanToLocation base_dir (getSrcSpan ty_thing))
ty_thing db
is_interesting_id ident =
case globalIdVarDetails ident of
VanillaGlobal -> True
ClassOpId _ -> True
RecordSelId {} -> True
NotGlobalId -> True
_ -> False
is_boring_tycon tycon =
isClassTyCon tycon || isCoercionTyCon tycon || isFamInstTyCon tycon
is_boring_datacon datacon =
is_boring_tycon (dataConTyCon datacon)
addToDB :: String -> Location -> TyThing -> DefSiteDB -> DefSiteDB
addToDB nm loc ty_thing (DefSiteDB m) =
DefSiteDB (M.insertWith (++) nm [(loc,ty_thing)] m)
dumpDefSiteDB :: DefSiteDB -> String
dumpDefSiteDB (DefSiteDB m) = unlines (map pp (M.assocs m))
where
pp (s, l_ty_things) = show s ++ ":\n" ++ unlines
[ " " ++ show (viewLoc l) ++ ", " ++ pp_ty_thing t
| (l, t) <- l_ty_things ]
pp_ty_thing tt@(AnId ident) =
showSDoc (pprTyThingInContext False tt <+> ppr (globalIdVarDetails ident))
pp_ty_thing (ADataCon dcon) =
showSDoc (ppr dcon <+> ppr (dataConType dcon))
pp_ty_thing tt = showSDoc (ppr tt)