Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Collect definition site information by looking at the `TyThings`.

`TyThings` are defined in the `ModuleInfo` which is provided for every
module that GHC knows about.  Keeping the TyThings around may not be a good
long-term solution; see note in `Scion.Types.DefSiteDB`.

Getting the source locations for external packages must be done by using
Hackage as a library.
  • Loading branch information...
commit a407a2f5c06a09b64ea46963a9e5de368e83afc8 1 parent 3031449
@nominolo nominolo authored
View
193 src/Scion/Inspect/DefinitionSite.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE CPP #-}
-- |
-- Module : Scion.Inspect.DefinitionSite
@@ -8,143 +9,87 @@
-- Stability : experimental
-- Portability : portable
--
--- Finding the definition site of an identifier.
+-- Collecting and finding the definition site of an identifier.
--
-- This module analyses Haskell code to find the definition sites of
-- identifiers within.
--
--- TODO: collect type info as well?
module Scion.Inspect.DefinitionSite where
+import Scion.Types
import Scion.Types.Notes
-import GHC hiding ( FamilyFlavour(..), TyThing(..) )
-import qualified GHC ( FamilyFlavour(..) )
-import Bag ( bagToList )
-import Name ( getOccString )
+import GHC
+import Name ( getOccString, getSrcSpan )
+import Outputable ( showSDoc, ppr, Outputable, (<+>) )
+import PprTyThing ( pprTyThingInContext )
+import TyCon ( isCoercionTyCon )
+import Var ( globalIdVarDetails )
+import HscTypes ( isBootSummary )
-import Data.Maybe ( isJust )
+import qualified Data.Map as M
+import Data.List ( foldl' )
+import Data.Monoid
+import Control.Monad ( foldM )
------------------------------------------------------------------------
+-- * Intended Interface
-instance Show ModuleName where
- show m = moduleNameString m
-
-data DefSite
- = DefSite ModuleName String DefKind Location
- -- ^ The definition of the given identifier.
- | InstanceSite ModuleName String String Location
- -- ^ XXX: An instance of something
- deriving (Eq, Ord, Show)
-
-data DefKind
- = AClass
- | AType TypeDeclType
- | AVar
- deriving (Eq, Ord, Show)
-
-data TypeDeclType
- = DataDecl
- | TypeSynonym
- | Newtype
- | DataFamily
- | TypeFamily
- | DataInstance
- | TypeInstance
- deriving (Eq, Ord, Show)
-
-definedNames :: (ModuleName, FilePath) -> HsGroup Name -> TypecheckedSource
- -> [DefSite]
-definedNames srcmod hsgroup _tc_src =
- let vals = case hs_valds hsgroup of
- ValBindsOut nest _sigs ->
- [ site
- | (_rec, binds) <- nest
- , bind <- bagToList binds
- , site <- definedNamesHsBind srcmod bind ]
- _other -> error "definedNames: ValBindsOut expected"
-
- tys = [ site
- | ty_cl_decl <- map unLoc (hs_tyclds hsgroup)
- , let ns = tyClDeclNames ty_cl_decl
- , (n, def_kind) <- zip ns (first_tycl_def_kind ty_cl_decl :
- repeat AVar)
- , let site = mkSiteOfLName srcmod n def_kind ]
-
- first_tycl_def_kind tydecl = case tydecl of
- TyData { tcdND = nd } ->
- AType (if isJust (tcdTyPats tydecl)
- then DataInstance
- else case nd of
- NewType -> Newtype
- DataType -> DataDecl)
- TySynonym {tcdTyPats = Nothing} -> AType TypeSynonym
- TySynonym {} -> AType TypeInstance
- TyFamily { tcdFlavour = fl } ->
- AType (case fl of
- GHC.TypeFamily -> TypeFamily
- GHC.DataFamily -> DataFamily)
- ClassDecl {} -> AClass
- _ -> AType DataDecl
-
- foreigns = concat $ map foreignBound (hs_fords hsgroup)
- where foreignBound lfordecl =
- case unLoc lfordecl of
- ForeignImport n _ _ -> [mkSiteOfLName srcmod n AVar]
- ForeignExport { } -> []
- in vals ++ tys ++ foreigns
-
-definedNamesHsBind :: (ModuleName, FilePath) -> LHsBind Name -> [DefSite]
-definedNamesHsBind srcmod lbind =
- case unLoc lbind of
- FunBind { fun_id = name } -> [mkSite name AVar]
- PatBind { pat_lhs = lhs } -> definedNamesPat srcmod lhs
- VarBind { var_id = name } ->
- [DefSite (fst srcmod) (getOccString name) AVar (theLoc (snd srcmod) lbind)]
- AbsBinds { } -> [] -- nothing interesting in a type abstraction
- where
- mkSite = mkSiteOfLName srcmod
-
-definedNamesPat :: (ModuleName, FilePath) -> LPat Name -> [DefSite]
-definedNamesPat srcmod lhs = go lhs []
+-- | Construct a 'DefSiteDB' for a complete module graph.
+--
+-- Note: All the modules mentioned in the module graph must have been
+-- loaded. This is done either by a successful call to 'GHC.load' or by a
+-- call to 'GHC.loadModule' for each module (in dependency order).
+moduleGraphDefSiteDB ::
+ FilePath -- ^ Base path (see 'ghcSpanToLocation')
+ -> 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)
+
+-- | Construct a 'DefSiteDB' for a single module only.
+moduleSiteDB :: (FilePath, Module)
+ -- ^ Base path (see 'ghcSpanToLocation') and 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)
+
+-- ** Internal Stuff
+
+-- | Construct a 'SiteDB' from a base directory and a list of 'TyThing's.
+mkSiteDB :: FilePath -> [TyThing] -> DefSiteDB
+mkSiteDB base_dir ty_things = foldl' go emptyDefSiteDB ty_things
where
- mkSite = mkSiteOfLName srcmod
- go lpat acc =
- let loc = theLoc (snd srcmod) lpat
- lid name = DefSite (fst srcmod) (getOccString name) AVar loc
- in case unLoc lpat of
- WildPat _ -> acc
- VarPat name -> lid name : acc
- VarPatOut name _ -> lid name : acc -- XXX need help here
- LazyPat p -> go p acc
- AsPat name p -> go p (mkSite name AVar : acc)
- ParPat p -> go p acc
- BangPat p -> go p acc
- ListPat ps _ -> foldr go acc ps
- TuplePat ps _ _ -> foldr go acc ps
- PArrPat ps _ -> foldr go acc ps
- ConPatIn _ conargs -> conArgs conargs acc
- ConPatOut _ _ _ _ conargs _ -> conArgs conargs acc
- LitPat _ -> acc
-#if __GLASGOW_HASKELL__ > 608
- NPat _ _ _ -> acc -- form of literal pattern?
-#else
- NPat _ _ _ _ -> acc -- form of literal pattern?
-#endif
- NPlusKPat name _ _ _ -> mkSite name AVar : acc
- TypePat _ -> acc -- XXX need help here
- SigPatIn p _ -> go p acc
- SigPatOut p _ -> go p acc
- _ -> error "definedNamesPat"
+ -- TODO: there's probably more stuff to ignore
+ go db (ATyCon tycon) | isCoercionTyCon tycon = db -- ignore
+ go db ty_thing =
+ addToDB (getOccString ty_thing)
+ (ghcSpanToLocation base_dir (getSrcSpan ty_thing))
+ ty_thing db
- conArgs (PrefixCon ps) acc = foldr go acc ps
- conArgs (RecCon (HsRecFields { rec_flds = flds })) acc
- = foldr (\f acc' -> go (hsRecFieldArg f) acc') acc flds
- conArgs (InfixCon p1 p2) acc = go p1 $ go p2 acc
+addToDB :: String -> Location -> TyThing -> DefSiteDB -> DefSiteDB
+addToDB nm loc ty_thing (DefSiteDB m) =
+ DefSiteDB (M.insertWith (++) nm [(loc,ty_thing)] m)
-theLoc :: FilePath -> Located a -> Location
-theLoc base_path l = ghcSpanToLocation base_path (getLoc l)
-mkSiteOfLName :: (ModuleName, FilePath) -> Located Name -> DefKind -> DefSite
-mkSiteOfLName (srcmod, base_path) name def_kind =
- DefSite srcmod (getOccString $ unLoc name) def_kind (theLoc base_path name)
+-- | Dump a definition site DB to stdout. (For debugging purposes.)
+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 tt = showSDoc (pprTyThingInContext False tt)
View
52 src/Scion/Types.hs
@@ -24,6 +24,7 @@ import HscTypes
import MonadUtils ( liftIO, MonadIO )
import Exception
+import qualified Data.Map as M
import qualified Data.MultiSet as MS
import Distribution.Simple.LocalBuildInfo
import Control.Monad ( when )
@@ -58,13 +59,16 @@ data SessionState
focusedModule :: Maybe ModSummary,
-- ^ The currently focused module for background typechecking.
- bgTcCache :: Maybe BgTcCache
+ bgTcCache :: Maybe BgTcCache,
-- ^ Cached state of the background typechecker.
+
+ defSiteDB :: DefSiteDB
+ -- ^ Source code locations.
}
mkSessionState :: DynFlags -> IO (IORef SessionState)
mkSessionState dflags =
- newIORef (SessionState normal dflags Nothing Nothing mempty Nothing Nothing)
+ newIORef (SessionState normal dflags Nothing Nothing mempty Nothing Nothing mempty)
newtype ScionM a
@@ -237,3 +241,47 @@ data Component
-- | Shorthand for 'undefined'.
__ :: a
__ = undefined
+
+-- * Go To Definition
+
+-- | A definition site database.
+--
+-- This is a map from names to the location of their definition and
+-- information about the defined entity. Note that a name may refer to
+-- multiple entities.
+--
+-- XXX: Currently we use GHC's 'TyThing' data type. However, this probably
+-- holds on to a lot of stuff we don't need. It also cannot be serialised
+-- directly. The reason it's done this way is that wrapping 'TyThing' leads
+-- to a lot of duplicated code. Using a custom type might be useful to have
+-- fewer dependencies on the GHC API; however it also creates problems
+-- mapping things back into GHC API data structures. If we do this, we
+-- should at least remember the 'Unique' in order to quickly look up the
+-- original thing.
+newtype DefSiteDB =
+ DefSiteDB (M.Map String [(Location,TyThing)])
+
+instance Monoid DefSiteDB where
+ mempty = emptyDefSiteDB
+ mappend = unionDefSiteDB
+
+-- | The empty 'DefSiteDB'.
+emptyDefSiteDB :: DefSiteDB
+emptyDefSiteDB = DefSiteDB M.empty
+
+-- | Combine two 'DefSiteDB's. XXX: check for duplicates?
+unionDefSiteDB :: DefSiteDB -> DefSiteDB -> DefSiteDB
+unionDefSiteDB (DefSiteDB m1) (DefSiteDB m2) =
+ DefSiteDB (M.unionWith (++) m1 m2)
+
+-- | Return the list of defined names (the domain) of the 'DefSiteDB'.
+-- The result is, in fact, ordered.
+definedNames :: DefSiteDB -> [String]
+definedNames (DefSiteDB m) = M.keys m
+
+-- | Returns all the entities that the given name may refer to.
+lookupDefSite :: DefSiteDB -> String -> [(Location, TyThing)]
+lookupDefSite (DefSiteDB m) key =
+ case M.lookup key m of
+ Nothing -> []
+ Just xs -> xs
View
3  src/Scion/Types/Notes.hs
@@ -219,6 +219,9 @@ thenCmp x _ = x
-- * Converting from GHC types.
-- | Convert a 'GHC.SrcSpan' to a 'Location'.
+--
+-- The first argument is used to normalise relative source locations to an
+-- absolute file path.
ghcSpanToLocation :: FilePath -- ^ Base directory
-> GHC.SrcSpan
-> Location
Please sign in to comment.
Something went wrong with that request. Please try again.