diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index 5acf24662c..2c10a9a56a 100644 --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -266,10 +266,10 @@ getSpanInfoRule = define $ \GetSpanInfo file -> do tc <- use_ TypeCheck file deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file - tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps) + parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps) (fileImports, _) <- use_ GetLocatedImports file packageState <- hscEnv <$> use_ GhcSession file - x <- liftIO $ getSrcSpanInfos packageState fileImports tc tms + x <- liftIO $ getSrcSpanInfos packageState fileImports tc parsedDeps return ([], Just x) -- Typechecks a module. diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs index 93995f9f23..f43d2804c8 100644 --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -32,13 +32,13 @@ produceCompletions :: Rules () produceCompletions = define $ \ProduceCompletions file -> do deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file - tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps) + parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps) tm <- fmap fst <$> useWithStale TypeCheck file packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file case (tm, packageState) of (Just tm', Just packageState') -> do cdata <- liftIO $ cacheDataProducer packageState' (hsc_dflags packageState') - (tmrModule tm') (map tmrModule tms) + (tmrModule tm') parsedDeps return ([], Just (cdata, tm')) _ -> return ([], Nothing) diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs index 2a7becab00..40a49ed593 100644 --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -210,8 +210,8 @@ mkPragmaCompl label insertText = Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) Nothing Nothing Nothing Nothing Nothing -cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions -cacheDataProducer packageState dflags tm tcs = do +cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions +cacheDataProducer packageState dflags tm deps = do let parsedMod = tm_parsed_module tm curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod Just (_,limports,_,_) = tm_renamed_source tm @@ -269,12 +269,12 @@ cacheDataProducer packageState dflags tm tcs = do let typ = Just $ varType var name = Var.varName var label = T.pack $ showGhc name - docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm:tcs) name + docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name return $ CI name (showModName curMod) typ label Nothing docs toCompItem :: ModuleName -> Name -> IO CompItem toCompItem mn n = do - docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm:tcs) n + docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n -- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi -- and leads to fun errors like "Cannot continue after interface file error". #ifdef GHC_LIB diff --git a/src/Development/IDE/Spans/Calculate.hs b/src/Development/IDE/Spans/Calculate.hs index 6d5d0a95bd..fea90ae807 100644 --- a/src/Development/IDE/Spans/Calculate.hs +++ b/src/Development/IDE/Spans/Calculate.hs @@ -51,25 +51,25 @@ getSrcSpanInfos :: HscEnv -> [(Located ModuleName, Maybe NormalizedFilePath)] -> TcModuleResult - -> [TcModuleResult] + -> [ParsedModule] -> IO SpansInfo -getSrcSpanInfos env imports tc tms = +getSrcSpanInfos env imports tc deps = runGhcEnv env $ - getSpanInfo imports (tmrModule tc) (map tmrModule tms) + getSpanInfo imports (tmrModule tc) deps -- | Get ALL source spans in the module. getSpanInfo :: GhcMonad m => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports -> TypecheckedModule - -> [TypecheckedModule] + -> [ParsedModule] -> m SpansInfo -getSpanInfo mods tcm tcms = +getSpanInfo mods tcm deps = do let tcs = tm_typechecked_source tcm bs = listifyAllSpans tcs :: [LHsBind GhcTc] es = listifyAllSpans tcs :: [LHsExpr GhcTc] ps = listifyAllSpans' tcs :: [Pat GhcTc] ts = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn] - allModules = tcm:tcms + allModules = tm_parsed_module tcm : deps funBinds = funBindMap $ tm_parsed_module tcm bts <- mapM (getTypeLHsBind allModules funBinds) bs -- binds ets <- mapM (getTypeLHsExpr allModules) es -- expressions @@ -117,19 +117,19 @@ ieLNames _ = [] -- | Get the name and type of a binding. getTypeLHsBind :: (GhcMonad m) - => [TypecheckedModule] + => [ParsedModule] -> OccEnv (HsBind GhcPs) -> LHsBind GhcTc -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)] -getTypeLHsBind tms funBinds (L _spn FunBind{fun_id = pid}) +getTypeLHsBind deps funBinds (L _spn FunBind{fun_id = pid}) | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do let name = getName (unLoc pid) - docs <- getDocumentationTryGhc tms name + docs <- getDocumentationTryGhc deps name return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ] -- In theory this shouldn’t ever fail but if it does, we can at least show the first clause. -getTypeLHsBind tms _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do +getTypeLHsBind deps _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do let name = getName (unLoc pid) - docs <- getDocumentationTryGhc tms name + docs <- getDocumentationTryGhc deps name return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)] getTypeLHsBind _ _ _ = return [] @@ -142,17 +142,17 @@ getConstraintsLHsBind _ = [] -- | Get the name and type of an expression. getTypeLHsExpr :: (GhcMonad m) - => [TypecheckedModule] + => [ParsedModule] -> LHsExpr GhcTc -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc)) -getTypeLHsExpr tms e = do +getTypeLHsExpr deps e = do hs_env <- getSession (_, mbe) <- liftIO (deSugarExpr hs_env e) case mbe of Just expr -> do let ss = getSpanSource (unLoc e) docs <- case ss of - Named n -> getDocumentationTryGhc tms n + Named n -> getDocumentationTryGhc deps n _ -> return emptySpanDoc return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs) Nothing -> return Nothing @@ -198,13 +198,13 @@ getTypeLHsExpr tms e = do -- | Get the name and type of a pattern. getTypeLPat :: (GhcMonad m) - => [TypecheckedModule] + => [ParsedModule] -> Pat GhcTc -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc)) -getTypeLPat tms pat = do +getTypeLPat deps pat = do let (src, spn) = getSpanSource pat docs <- case src of - Named n -> getDocumentationTryGhc tms n + Named n -> getDocumentationTryGhc deps n _ -> return emptySpanDoc return $ Just (src, spn, Just (hsPatType pat), docs) where @@ -216,12 +216,12 @@ getTypeLPat tms pat = do getLHsType :: GhcMonad m - => [TypecheckedModule] + => [ParsedModule] -> LHsType GhcRn -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)] -getLHsType tms (L spn (HsTyVar U _ v)) = do +getLHsType deps (L spn (HsTyVar U _ v)) = do let n = unLoc v - docs <- getDocumentationTryGhc tms n + docs <- getDocumentationTryGhc deps n #ifdef GHC_LIB let ty = Right Nothing #else diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs index ab9d82695b..8422821e5f 100644 --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -14,33 +14,33 @@ import Data.List.Extra import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T +import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Spans.Common import FastString -import GHC import SrcLoc getDocumentationTryGhc :: GhcMonad m - => [TypecheckedModule] + => [ParsedModule] -> Name -> m SpanDoc -- getDocs goes through the GHCi codepaths which cause problems on ghc-lib. -- See https://github.com/digital-asset/daml/issues/4152 for more details. #if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB) -getDocumentationTryGhc tcs name = do +getDocumentationTryGhc sources name = do res <- catchSrcErrors "docs" $ getDocs name case res of Right (Right (Just docs, _)) -> return $ SpanDocString docs - _ -> return $ SpanDocText $ getDocumentation tcs name + _ -> return $ SpanDocText $ getDocumentation sources name #else -getDocumentationTryGhc tcs name = do - return $ SpanDocText $ getDocumentation tcs name +getDocumentationTryGhc sources name = do + return $ SpanDocText $ getDocumentation sources name #endif getDocumentation - :: [TypecheckedModule] -- ^ All of the possible modules it could be defined in. + :: [ParsedModule] -- ^ All of the possible modules it could be defined in. -> Name -- ^ The name you want documentation for. -> [T.Text] -- This finds any documentation between the name you want @@ -50,16 +50,18 @@ getDocumentation -- may be edge cases where it is very wrong). -- TODO : Build a version of GHC exactprint to extract this information -- more accurately. -getDocumentation tcs targetName = fromMaybe [] $ do +getDocumentation sources targetName = fromMaybe [] $ do -- Find the module the target is defined in. targetNameSpan <- realSpan $ nameSrcSpan targetName tc <- find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) - $ reverse tcs -- TODO : Is reversing the list here really neccessary? - -- Names bound by the module (we want to exclude non-"top-level" - -- bindings but unfortunately we get all here). - let bs = mapMaybe name_of_bind - (listifyAllSpans (tm_typechecked_source tc) :: [LHsBind GhcTc]) + $ reverse sources -- TODO : Is reversing the list here really neccessary? + + -- Top level names bound by the module + let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc + , L _ (ValD hsbind) <- hsmodDecls + , Just n <- [name_of_bind hsbind] + ] -- Sort the names' source spans. let sortedSpans = sortedNameSpans bs -- Now go ahead and extract the docs. @@ -81,16 +83,16 @@ getDocumentation tcs targetName = fromMaybe [] $ do where -- Get the name bound by a binding. We only concern ourselves with -- @FunBind@ (which covers functions and variables). - name_of_bind :: LHsBind GhcTc -> Maybe Name - name_of_bind (L _ FunBind {fun_id}) = Just (getName (unLoc fun_id)) + name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName) + name_of_bind FunBind {fun_id} = Just fun_id name_of_bind _ = Nothing -- Get source spans from names, discard unhelpful spans, remove -- duplicates and sort. - sortedNameSpans :: [Name] -> [RealSrcSpan] - sortedNameSpans ls = nubSort (mapMaybe (realSpan . nameSrcSpan) ls) + sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] + sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) isBetween target before after = before <= target && target <= after - ann = snd . pm_annotations . tm_parsed_module - annotationFileName :: TypecheckedModule -> Maybe FastString + ann = snd . pm_annotations + annotationFileName :: ParsedModule -> Maybe FastString annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan] realSpans =