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