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