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