@@ -9,13 +9,11 @@
99
1010-- | Get information on modules, identifiers, etc.
1111
12−module Development.IDE.Spans.Calculate(getSrcSpanInfos,listifyAllSpans) where
12+module Development.IDE.Spans.Calculate(getSrcSpanInfos) where
1313
1414import ConLike
1515import Control.Monad
1616import qualified CoreUtils
17−import Data.Data
18−import qualified Data.Generics
1917import Data.List
2018import Data.Maybe
2119import DataCon
@@ -26,14 +24,19 @@ import FastString (mkFastString)
2624import OccName
2725import Development.IDE.Types.Location
2826import Development.IDE.Spans.Type
27+#ifdef GHC_LIB
2928import Development.IDE.GHC.Error (zeroSpan)
29+#else
30+import Development.IDE.GHC.Error (zeroSpan, catchSrcErrors)
31+#endif
3032import Prelude hiding (mod)
3133import TcHsSyn
3234import Var
3335import Development.IDE.Core.Compile
3436import qualified Development.IDE.GHC.Compat as Compat
3537import Development.IDE.GHC.Util
36−
38+import Development.IDE.Spans.Common
39+import Development.IDE.Spans.Documentation
3740
3841-- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore
3942-- this U ignores that arg in 8.6, but is hidden in 8.4
@@ -48,37 +51,41 @@ getSrcSpanInfos
4851 :: HscEnv
4952 -> [(Located ModuleName, Maybe NormalizedFilePath)]
5053 -> TcModuleResult
54+ -> [TcModuleResult]
5155 -> IO [SpanInfo]
52−getSrcSpanInfos env imports tc =
53− runGhcEnv env
54− . getSpanInfo imports
55− $ tmrModule tc
56+getSrcSpanInfos env imports tc tms =
57+ runGhcEnv env $
58+ getSpanInfo imports (tmrModule tc) (map tmrModule tms)
5659
5760-- | Get ALL source spans in the module.
5861getSpanInfo :: GhcMonad m
5962 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
6063 -> TypecheckedModule
64+ -> [TypecheckedModule]
6165 -> m [SpanInfo]
62−getSpanInfo mods tcm =
66+getSpanInfo mods tcm tcms =
6367 do let tcs = tm_typechecked_source tcm
6468 bs = listifyAllSpans tcs :: [LHsBind GhcTc]
6569 es = listifyAllSpans tcs :: [LHsExpr GhcTc]
6670 ps = listifyAllSpans' tcs :: [Pat GhcTc]
6771 ts = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]
68− let funBinds = funBindMap $ tm_parsed_module tcm
69− bts <- mapM (getTypeLHsBind funBinds) bs -- binds
70− ets <- mapM (getTypeLHsExpr tcm) es -- expressions
71− pts <- mapM (getTypeLPat tcm) ps -- patterns
72− tts <- mapM (getLHsType tcm) ts -- types
72+ allModules = tcm:tcms
73+ funBinds = funBindMap $ tm_parsed_module tcm
74+ bts <- mapM (getTypeLHsBind allModules funBinds) bs -- binds
75+ ets <- mapM (getTypeLHsExpr allModules) es -- expressions
76+ pts <- mapM (getTypeLPat allModules) ps -- patterns
77+ tts <- mapM (getLHsType allModules) ts -- types
7378 let imports = importInfo mods
7479 let exports = getExports tcm
75− let exprs = exports ++ imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)
80+ let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)
7681 return (mapMaybe toSpanInfo (sortBy cmp exprs))
77− where cmp (_,a,_) (_,b,_)
82+ where cmp (_,a,_,_) (_,b,_,_)
7883 | a `isSubspanOf` b = LT
7984 | b `isSubspanOf` a = GT
8085 | otherwise = compare (srcSpanStart a) (srcSpanStart b)
8186
87+ addEmptyInfo = map (\(a,b) -> (a,b,Nothing,emptySpanDoc))
88+
8289-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always
8390-- points to the first match) whereas the parsed module has the correct locations.
8491-- Therefore we build up a map from OccName to the corresponding definition in the parsed module
@@ -88,10 +95,10 @@ getSpanInfo mods tcm =
8895funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs)
8996funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ]
9097
91−getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type)]
98+getExports :: TypecheckedModule -> [(SpanSource, SrcSpan)]
9299getExports m
93100 | Just (_, _, Just exports, _) <- renamedSource m =
94− [ (Named $ unLoc n, getLoc n, Nothing)
101+ [ (Named $ unLoc n, getLoc n)
95102 | (e, _) <- exports
96103 , n <- ieLNames $ unLoc e
97104 ]
@@ -107,47 +114,60 @@ ieLNames _ = []
107114
108115-- | Get the name and type of a binding.
109116getTypeLHsBind :: (GhcMonad m)
110− => OccEnv (HsBind GhcPs)
117+ => [TypecheckedModule]
118+ -> OccEnv (HsBind GhcPs)
111119 -> LHsBind GhcTc
112− -> m [(SpanSource, SrcSpan, Maybe Type)]
113−getTypeLHsBind funBinds (L _spn FunBind{fun_id = pid})
114− | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) =
115− return [(Named (getName (unLoc pid)), getLoc mc_fun, Just (varType (unLoc pid))) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
120+ -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
121+getTypeLHsBind tms funBinds (L _spn FunBind{fun_id = pid})
122+ | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do
123+ let name = getName (unLoc pid)
124+ docs <- getDocumentationTryGhc tms name
125+ return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
116126-- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.
117−getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) =
118− return [(Named $ getName (unLoc pid), getLoc pid, Just (varType (unLoc pid)))]
119−getTypeLHsBind _ _ = return []
127+getTypeLHsBind tms _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do
128+ let name = getName (unLoc pid)
129+ docs <- getDocumentationTryGhc tms name
130+ return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]
131+getTypeLHsBind _ _ _ = return []
120132
121133-- | Get the name and type of an expression.
122134getTypeLHsExpr :: (GhcMonad m)
123− => TypecheckedModule
135+ => [TypecheckedModule]
124136 -> LHsExpr GhcTc
125− -> m (Maybe (SpanSource, SrcSpan, Maybe Type))
126−getTypeLHsExpr _ e = do
137+ -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
138+getTypeLHsExpr tms e = do
127139 hs_env <- getSession
128140 (_, mbe) <- liftIO (deSugarExpr hs_env e)
129− return $
130− case mbe of
131− Just expr ->
132− Just (getSpanSource (unLoc e), getLoc e, Just (CoreUtils.exprType expr))
133− Nothing -> Nothing
141+ case mbe of
142+ Just expr -> do
143+ let ss = getSpanSource (unLoc e)
144+ docs <- case ss of
145+ Named n -> getDocumentationTryGhc tms n
146+ _ -> return emptySpanDoc
147+ return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)
148+ Nothing -> return Nothing
134149 where
135150 getSpanSource :: HsExpr GhcTc -> SpanSource
151+ getSpanSource (HsLit U lit) = Lit (showGhc lit)
152+ getSpanSource (HsOverLit U lit) = Lit (showGhc lit)
136153 getSpanSource (HsVar U (L _ i)) = Named (getName i)
137154 getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
138155 getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)
139156 getSpanSource (HsWrap U _ xpr) = getSpanSource xpr
140157 getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)
141− getSpanSource _ = NoSource
158+ getSpanSource _ = NoSource
142159
143160-- | Get the name and type of a pattern.
144161getTypeLPat :: (GhcMonad m)
145− => TypecheckedModule
162+ => [TypecheckedModule]
146163 -> Pat GhcTc
147− -> m (Maybe (SpanSource, SrcSpan, Maybe Type))
148−getTypeLPat _ pat =
149− let (src, spn) = getSpanSource pat in
150− return $ Just (src, spn, Just (hsPatType pat))
164+ -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
165+getTypeLPat tms pat = do
166+ let (src, spn) = getSpanSource pat
167+ docs <- case src of
168+ Named n -> getDocumentationTryGhc tms n
169+ _ -> return emptySpanDoc
170+ return $ Just (src, spn, Just (hsPatType pat), docs)
151171 where
152172 getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)
153173 getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)
@@ -157,40 +177,40 @@ getTypeLPat _ pat =
157177
158178getLHsType
159179 :: GhcMonad m
160− => TypecheckedModule
180+ => [TypecheckedModule]
161181 -> LHsType GhcRn
162− -> m [(SpanSource, SrcSpan, Maybe Type)]
163−getLHsType _ (L spn (HsTyVar U _ v)) = pure [(Named $ unLoc v, spn, Nothing)]
182+ -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
183+getLHsType tms (L spn (HsTyVar U _ v)) = do
184+ let n = unLoc v
185+ docs <- getDocumentationTryGhc tms n
186+#ifdef GHC_LIB
187+ let ty = Right Nothing
188+#else
189+ ty <- catchSrcErrors "completion" $ do
190+ name' <- lookupName n
191+ return $ name' >>= safeTyThingType
192+#endif
193+ let ty' = case ty of
194+ Right (Just x) -> Just x
195+ _ -> Nothing
196+ pure [(Named n, spn, ty', docs)]
164197getLHsType _ _ = pure []
165198
166199importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]
167− -> [(SpanSource, SrcSpan, Maybe Type)]
200+ -> [(SpanSource, SrcSpan)]
168201importInfo = mapMaybe (uncurry wrk) where
169− wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)
202+ wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan)
170203 wrk modName = \case
171204 Nothing -> Nothing
172− Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName, Nothing)
205+ Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName)
173206
174207 -- TODO make this point to the module name
175208 fpToSpanSource :: FilePath -> SpanSource
176209 fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp
177210
178−-- | Get ALL source spans in the source.
179−listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]
180−listifyAllSpans tcs =
181− Data.Generics.listify p tcs
182− where p (L spn _) = isGoodSrcSpan spn
183−-- This is a version of `listifyAllSpans` specialized on picking out
184−-- patterns. It comes about since GHC now defines `type LPat p = Pat
185−-- p` (no top-level locations).
186−listifyAllSpans' :: Typeable a
187− => TypecheckedSource -> [Pat a]
188−listifyAllSpans' tcs = Data.Generics.listify (const True) tcs
189−
190−
191211-- | Pretty print the types into a 'SpanInfo'.
192−toSpanInfo :: (SpanSource, SrcSpan, Maybe Type) -> Maybe SpanInfo
193−toSpanInfo (name,mspan,typ) =
212+toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, SpanDoc) -> Maybe SpanInfo
213+toSpanInfo (name,mspan,typ,docs) =
194214 case mspan of
195215 RealSrcSpan spn ->
196216 -- GHC’s line and column numbers are 1-based while LSP’s line and column
@@ -200,5 +220,6 @@ toSpanInfo (name,mspan,typ) =
200220 (srcSpanEndLine spn - 1)
201221 (srcSpanEndCol spn - 1)
202222 typ
203− name)
223+ name
224+ docs)
204225 _ -> Nothing