d42f019e5fddcf2d2c5cbfede8e0f690946a4414
[ghc.git] / ghc / GHCi / UI / Info.hs
1 {-# LANGUAGE LambdaCase #-}
2 {-# LANGUAGE RankNTypes #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE ViewPatterns #-}
6
7 -- | Get information on modules, expressions, and identifiers
8 module GHCi.UI.Info
9 ( ModInfo(..)
10 , SpanInfo(..)
11 , spanInfoFromRealSrcSpan
12 , collectInfo
13 , findLoc
14 , findNameUses
15 , findType
16 , getModInfo
17 ) where
18
19 import Control.Exception
20 import Control.Monad
21 import Control.Monad.Trans.Class
22 import Control.Monad.Trans.Except
23 import Control.Monad.Trans.Maybe
24 import Data.Data
25 import Data.Function
26 import Data.List
27 import Data.Map.Strict (Map)
28 import qualified Data.Map.Strict as M
29 import Data.Maybe
30 import Data.Time
31 import Prelude hiding (mod,(<>))
32 import System.Directory
33
34 import qualified CoreUtils
35 import Desugar
36 import DynFlags (HasDynFlags(..))
37 import FastString
38 import GHC
39 import GhcMonad
40 import Name
41 import NameSet
42 import Outputable
43 import SrcLoc
44 import TcHsSyn
45 import Var
46
47 -- | Info about a module. This information is generated every time a
48 -- module is loaded.
49 data ModInfo = ModInfo
50 { modinfoSummary :: !ModSummary
51 -- ^ Summary generated by GHC. Can be used to access more
52 -- information about the module.
53 , modinfoSpans :: [SpanInfo]
54 -- ^ Generated set of information about all spans in the
55 -- module that correspond to some kind of identifier for
56 -- which there will be type info and/or location info.
57 , modinfoInfo :: !ModuleInfo
58 -- ^ Again, useful from GHC for accessing information
59 -- (exports, instances, scope) from a module.
60 , modinfoLastUpdate :: !UTCTime
61 -- ^ The timestamp of the file used to generate this record.
62 }
63
64 -- | Type of some span of source code. Most of these fields are
65 -- unboxed but Haddock doesn't show that.
66 data SpanInfo = SpanInfo
67 { spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan
68 -- ^ The span we associate information with
69 , spaninfoType :: !(Maybe Type)
70 -- ^ The 'Type' associated with the span
71 , spaninfoVar :: !(Maybe Id)
72 -- ^ The actual 'Var' associated with the span, if
73 -- any. This can be useful for accessing a variety of
74 -- information about the identifier such as module,
75 -- locality, definition location, etc.
76 }
77
78 -- | Test whether second span is contained in (or equal to) first span.
79 -- This is basically 'containsSpan' for 'SpanInfo'
80 containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
81 containsSpanInfo = containsSpan `on` spaninfoSrcSpan
82
83 -- | Filter all 'SpanInfo' which are contained in 'SpanInfo'
84 spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]
85 spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'
86
87 -- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a
88 -- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'
89 -- respectively)
90 spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
91 spanInfoFromRealSrcSpan spn mty mvar =
92 SpanInfo spn mty mvar
93
94 -- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs
95 -- only a 'RealSrcSpan'
96 spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo
97 spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing
98
99 -- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'
100 srcSpanFilePath :: RealSrcSpan -> FilePath
101 srcSpanFilePath = unpackFS . srcSpanFile
102
103 -- | Try to find the location of the given identifier at the given
104 -- position in the module.
105 findLoc :: GhcMonad m
106 => Map ModuleName ModInfo
107 -> RealSrcSpan
108 -> String
109 -> ExceptT SDoc m (ModInfo,Name,SrcSpan)
110 findLoc infos span0 string = do
111 name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
112 guessModule infos (srcSpanFilePath span0)
113
114 info <- maybeToExceptT "No module info for current file! Try loading it?" $
115 MaybeT $ pure $ M.lookup name infos
116
117 name' <- findName infos span0 info string
118
119 case getSrcSpan name' of
120 UnhelpfulSpan{} -> do
121 throwE ("Found a name, but no location information." <+>
122 "The module is:" <+>
123 maybe "<unknown>" (ppr . moduleName)
124 (nameModule_maybe name'))
125
126 span' -> return (info,name',span')
127
128 -- | Find any uses of the given identifier in the codebase.
129 findNameUses :: (GhcMonad m)
130 => Map ModuleName ModInfo
131 -> RealSrcSpan
132 -> String
133 -> ExceptT SDoc m [SrcSpan]
134 findNameUses infos span0 string =
135 locToSpans <$> findLoc infos span0 string
136 where
137 locToSpans (modinfo,name',span') =
138 stripSurrounding (span' : map toSrcSpan spans)
139 where
140 toSrcSpan = RealSrcSpan . spaninfoSrcSpan
141 spans = filter ((== Just name') . fmap getName . spaninfoVar)
142 (modinfoSpans modinfo)
143
144 -- | Filter out redundant spans which surround/contain other spans.
145 stripSurrounding :: [SrcSpan] -> [SrcSpan]
146 stripSurrounding xs = filter (not . isRedundant) xs
147 where
148 isRedundant x = any (x `strictlyContains`) xs
149
150 (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)
151 = s1 /= s2 && s1 `containsSpan` s2
152 _ `strictlyContains` _ = False
153
154 -- | Try to resolve the name located at the given position, or
155 -- otherwise resolve based on the current module's scope.
156 findName :: GhcMonad m
157 => Map ModuleName ModInfo
158 -> RealSrcSpan
159 -> ModInfo
160 -> String
161 -> ExceptT SDoc m Name
162 findName infos span0 mi string =
163 case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of
164 Nothing -> tryExternalModuleResolution
165 Just name ->
166 case getSrcSpan name of
167 UnhelpfulSpan {} -> tryExternalModuleResolution
168 RealSrcSpan {} -> return (getName name)
169 where
170 tryExternalModuleResolution =
171 case find (matchName $ mkFastString string)
172 (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of
173 Nothing -> throwE "Couldn't resolve to any modules."
174 Just imported -> resolveNameFromModule infos imported
175
176 matchName :: FastString -> Name -> Bool
177 matchName str name =
178 str ==
179 occNameFS (getOccName name)
180
181 -- | Try to resolve the name from another (loaded) module's exports.
182 resolveNameFromModule :: GhcMonad m
183 => Map ModuleName ModInfo
184 -> Name
185 -> ExceptT SDoc m Name
186 resolveNameFromModule infos name = do
187 modL <- maybe (throwE $ "No module for" <+> ppr name) return $
188 nameModule_maybe name
189
190 info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>
191 ppr modL)) return $
192 M.lookup (moduleName modL) infos
193
194 maybe (throwE "No matching export in any local modules.") return $
195 find (matchName name) (modInfoExports (modinfoInfo info))
196 where
197 matchName :: Name -> Name -> Bool
198 matchName x y = occNameFS (getOccName x) ==
199 occNameFS (getOccName y)
200
201 -- | Try to resolve the type display from the given span.
202 resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var
203 resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $
204 reverse spans' `spaninfosWithin` si
205
206 -- | Try to find the type of the given span.
207 findType :: GhcMonad m
208 => Map ModuleName ModInfo
209 -> RealSrcSpan
210 -> String
211 -> ExceptT SDoc m (ModInfo, Type)
212 findType infos span0 string = do
213 name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
214 guessModule infos (srcSpanFilePath span0)
215
216 info <- maybeToExceptT "No module info for current file! Try loading it?" $
217 MaybeT $ pure $ M.lookup name infos
218
219 case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of
220 Nothing -> (,) info <$> lift (exprType TM_Inst string)
221 Just ty -> return (info, ty)
222 where
223 -- | Try to resolve the type display from the given span.
224 resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type
225 resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $
226 reverse spans' `spaninfosWithin` si
227
228 -- | Guess a module name from a file path.
229 guessModule :: GhcMonad m
230 => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
231 guessModule infos fp = do
232 target <- lift $ guessTarget fp Nothing
233 case targetId target of
234 TargetModule mn -> return mn
235 TargetFile fp' _ -> guessModule' fp'
236 where
237 guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName
238 guessModule' fp' = case findModByFp fp' of
239 Just mn -> return mn
240 Nothing -> do
241 fp'' <- liftIO (makeRelativeToCurrentDirectory fp')
242
243 target' <- lift $ guessTarget fp'' Nothing
244 case targetId target' of
245 TargetModule mn -> return mn
246 _ -> MaybeT . pure $ findModByFp fp''
247
248 findModByFp :: FilePath -> Maybe ModuleName
249 findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)
250 where
251 mifp :: (ModuleName, ModInfo) -> Maybe FilePath
252 mifp = ml_hs_file . ms_location . modinfoSummary . snd
253
254
255 -- | Collect type info data for the loaded modules.
256 collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
257 -> m (Map ModuleName ModInfo)
258 collectInfo ms loaded = do
259 df <- getDynFlags
260 liftIO (filterM cacheInvalid loaded) >>= \case
261 [] -> return ms
262 invalidated -> do
263 liftIO (putStrLn ("Collecting type info for " ++
264 show (length invalidated) ++
265 " module(s) ... "))
266
267 foldM (go df) ms invalidated
268 where
269 go df m name = do { info <- getModInfo name; return (M.insert name info m) }
270 `gcatch`
271 (\(e :: SomeException) -> do
272 liftIO $ putStrLn
273 $ showSDocForUser df alwaysQualify
274 $ "Error while getting type info from" <+>
275 ppr name <> ":" <+> text (show e)
276 return m)
277
278 cacheInvalid name = case M.lookup name ms of
279 Nothing -> return True
280 Just mi -> do
281 let fp = srcFilePath (modinfoSummary mi)
282 last' = modinfoLastUpdate mi
283 current <- getModificationTime fp
284 exists <- doesFileExist fp
285 if exists
286 then return $ current /= last'
287 else return True
288
289 -- | Get the source file path from a ModSummary.
290 -- If the .hs file is missing, and the .o file exists,
291 -- we return the .o file path.
292 srcFilePath :: ModSummary -> FilePath
293 srcFilePath modSum = fromMaybe obj_fp src_fp
294 where
295 src_fp = ml_hs_file ms_loc
296 obj_fp = ml_obj_file ms_loc
297 ms_loc = ms_location modSum
298
299 -- | Get info about the module: summary, types, etc.
300 getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
301 getModInfo name = do
302 m <- getModSummary name
303 p <- parseModule m
304 typechecked <- typecheckModule p
305 allTypes <- processAllTypeCheckedModule typechecked
306 let i = tm_checked_module_info typechecked
307 ts <- liftIO $ getModificationTime $ srcFilePath m
308 return (ModInfo m allTypes i ts)
309
310 -- | Get ALL source spans in the module.
311 processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule
312 -> m [SpanInfo]
313 processAllTypeCheckedModule tcm = do
314 bts <- mapM getTypeLHsBind $ listifyAllSpans tcs
315 ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs
316 pts <- mapM getTypeLPat $ listifyAllSpans tcs
317 return $ mapMaybe toSpanInfo
318 $ sortBy cmpSpan
319 $ catMaybes (bts ++ ets ++ pts)
320 where
321 tcs = tm_typechecked_source tcm
322
323 -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's
324 getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
325 getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})
326 = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))
327 getTypeLHsBind _ = pure Nothing
328
329 -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's
330 getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
331 getTypeLHsExpr e = do
332 hs_env <- getSession
333 (_,mbe) <- liftIO $ deSugarExpr hs_env e
334 return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe
335 where
336 mid :: Maybe Id
337 mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i
338 | otherwise = Nothing
339
340 unwrapVar (HsWrap _ _ var) = var
341 unwrapVar e' = e'
342
343 -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's
344 getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
345 getTypeLPat (dL->L spn pat) =
346 pure (Just (getMaybeId pat,spn,hsPatType pat))
347 where
348 getMaybeId (VarPat _ (dL->L _ vid)) = Just vid
349 getMaybeId _ = Nothing
350
351 -- | Get ALL source spans in the source.
352 listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a]
353 listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))
354 where
355 p (dL->L spn _) = isGoodSrcSpan spn
356
357 -- | Variant of @syb@'s @everything@ (which summarises all nodes
358 -- in top-down, left-to-right order) with a stop-condition on 'NameSet's
359 everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
360 everythingAllSpans k z f x
361 | (False `mkQ` (const True :: NameSet -> Bool)) x = z
362 | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)
363
364 cmpSpan (_,a,_) (_,b,_)
365 | a `isSubspanOf` b = LT
366 | b `isSubspanOf` a = GT
367 | otherwise = EQ
368
369 -- | Pretty print the types into a 'SpanInfo'.
370 toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo
371 toSpanInfo (n,RealSrcSpan spn,typ)
372 = Just $ spanInfoFromRealSrcSpan spn (Just typ) n
373 toSpanInfo _ = Nothing
374
375 -- helper stolen from @syb@ package
376 type GenericQ r = forall a. Data a => a -> r
377
378 mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
379 (r `mkQ` br) a = maybe r br (cast a)