diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 7b002f08fa..dc2f29fb2a 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -28,6 +28,7 @@ module Development.IDE.Core.Compile , loadInterface , loadModulesHome , setupFinderCache + , getDocsNonInteractive , getDocsBatch , lookupName ,mergeEnvs) where @@ -39,7 +40,6 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util import Development.IDE.GHC.Warnings -import Development.IDE.Spans.Common import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options @@ -75,7 +75,7 @@ import Control.Lens hiding (List) import Control.Monad.Except import Control.Monad.Extra import Control.Monad.Trans.Except -import Data.Bifunctor (first, second) +import Data.Bifunctor (second) import qualified Data.ByteString as BS import qualified Data.DList as DL import Data.IORef @@ -89,7 +89,6 @@ import System.Directory import System.FilePath import System.IO.Extra (fixIO, newTempFileWithin) --- GHC API imports -- GHC API imports import GHC (GetDocsFailure (..), mgModSummaries, @@ -104,6 +103,7 @@ import Data.Functor import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) import Data.Tuple.Extra (dupe) +import Data.Either.Extra (maybeToEither) import Data.Unique as Unique import Development.IDE.Core.Tracing (withTrace) import Development.IDE.GHC.Compat.Util (emptyUDFM, plusUDFM_C) @@ -213,9 +213,7 @@ tcRnModule hsc_env keep_lbls pmod = do HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, hpm_annotations = pm_annotations pmod } - let rn_info = case mrn_info of - Just x -> x - Nothing -> error "no renamed info tcRnModule" + let rn_info = fromMaybe (error "no renamed info tcRnModule") mrn_info pure (TcModuleResult pmod rn_info tc_gbl_env splices False) mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult @@ -658,7 +656,7 @@ setupFinderCache mss session = do -- Make modules available for others that import them, -- by putting them in the finder cache. let ims = map (installedModule (homeUnitId_ $ hsc_dflags session) . moduleName . ms_mod) mss - ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims + ifrs = zipWith (InstalledFound . ms_location) mss ims -- set the target and module graph in the session graph = mkModuleGraph mss @@ -696,7 +694,7 @@ mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv mergeEnvs env extraModSummaries extraMods envs = do prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs let ims = map (Compat.installedModule (homeUnitId_ $ hsc_dflags env) . moduleName . ms_mod) extraModSummaries - ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) extraModSummaries ims + ifrs = zipWith (InstalledFound . ms_location) extraModSummaries ims newFinderCache <- newIORef $ foldl' (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache @@ -809,6 +807,8 @@ getModSummaryFromImports env fp modTime contents = do , fingerPrintImports ] ++ map Util.fingerprintString opts +diagMsgs :: DynFlags -> Util.Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic] +diagMsgs = diagFromErrMsgs "parser" -- | Parse only the module header parseHeader @@ -826,7 +826,7 @@ parseHeader dflags filename contents = do case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of #if MIN_VERSION_ghc(8,10,0) PFailed pst -> - throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags + throwE $ diagMsgs dflags $ getErrorMessages pst dflags #else PFailed _ locErr msgErr -> throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr @@ -843,9 +843,9 @@ parseHeader dflags filename contents = do -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags (fmap pprError errs) + throwE $ diagMsgs dflags (fmap pprError errs) - let warnings = diagFromErrMsgs "parser" dflags (fmap pprWarning warns) + let warnings = diagMsgs dflags (fmap pprWarning warns) return (warnings, rdr_module) -- | Given a buffer, flags, and file path, produce a @@ -863,7 +863,7 @@ parseFileContents env customPreprocessor filename ms = do contents = fromJust $ ms_hspp_buf ms case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of #if MIN_VERSION_ghc(8,10,0) - PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags + PFailed pst -> throwE $ diagMsgs dflags $ getErrorMessages pst dflags #else PFailed _ locErr msgErr -> throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr @@ -884,7 +884,7 @@ parseFileContents env customPreprocessor filename ms = do -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags errs + throwE $ diagMsgs dflags errs -- Ok, we got here. It's safe to continue. let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module @@ -922,7 +922,7 @@ parseFileContents env customPreprocessor filename ms = do srcs2 <- liftIO $ filterM doesFileExist srcs1 let pm = mkParsedModule ms parsed' srcs2 hpm_annotations - warnings = diagFromErrMsgs "parser" dflags warns + warnings = diagMsgs dflags warns pure (warnings ++ preproc_warnings, pm) loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile @@ -991,40 +991,62 @@ mkDetailsFromIface session iface linkable = do initIfaceLoad hsc' (typecheckIface iface) return (HomeModInfo iface details linkable) --- | Non-interactive, batch version of 'InteractiveEval.getDocs'. +initTypecheckEnv :: HscEnv -> Module -> TcRn r -> IO (Messages, Maybe r) +initTypecheckEnv hsc_env mod = initTc hsc_env HsSrcFile False mod fakeSpan + where + fakeSpan :: RealSrcSpan + fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "") 1 1 + +-- | Non-interactive handling of the module interface. +-- A non-interactive modification of code from the 'GHC.Runtime.Eval.getDocs'. -- The interactive paths create problems in ghc-lib builds ---- and leads to fun errors like "Cannot continue after interface file error". +--- and lead to fun errors like "Cannot continue after interface file error". +getDocsNonInteractive' + :: Name + -> IOEnv + (Env TcGblEnv TcLclEnv) + (Name, + Either + GetDocsFailure (Maybe HsDocString, Maybe (Map.Map Int HsDocString))) +getDocsNonInteractive' name = + case nameModule_maybe name of + Nothing -> return (name, Left $ NameHasNoModule name) + Just mod -> do -- in GHC here was an interactive check & handling. + ModIface + { mi_doc_hdr = mb_doc_hdr + , mi_decl_docs = DeclDocMap dmap + , mi_arg_docs = ArgDocMap amap + } + <- loadModuleInterface "getModuleInterface" mod + let + isNameCompiled = + -- comment from GHC: Find a more direct indicator. + case nameSrcLoc name of + RealSrcLoc {} -> False + UnhelpfulLoc {} -> True + pure . (name,) $ + if isNothing mb_doc_hdr && Map.null dmap && Map.null amap + then Left $ NoDocsInIface mod isNameCompiled + else Right (Map.lookup name dmap, Map.lookup name amap) + +-- | Non-interactive modification of 'GHC.Runtime.Eval.getDocs'. +getDocsNonInteractive :: HscEnv -> Module -> Name -> IO (Either GHC.ErrorMessages (Name, Either GetDocsFailure (Maybe HsDocString, Maybe (Map.Map Int HsDocString)))) +getDocsNonInteractive hsc_env mod name = do + ((_warns,errs), res) <- initTypecheckEnv hsc_env mod $ getDocsNonInteractive' name + pure $ maybeToEither errs res + + +-- | Non-interactive, batch version of 'GHC.Runtime.Eval.getDocs'. getDocsBatch :: HscEnv -> Module -- ^ a moudle where the names are in scope -> [Name] - -> IO [Either String (Maybe HsDocString, Map.Map Int HsDocString)] -getDocsBatch hsc_env _mod _names = do - ((_warns,errs), res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name -> - case nameModule_maybe name of - Nothing -> return (Left $ NameHasNoModule name) - Just mod -> do - ModIface { mi_doc_hdr = mb_doc_hdr - , mi_decl_docs = DeclDocMap dmap - , mi_arg_docs = ArgDocMap amap - } <- loadModuleInterface "getModuleInterface" mod - if isNothing mb_doc_hdr && Map.null dmap && Map.null amap - then pure (Left (NoDocsInIface mod $ compiled name)) - else pure (Right ( Map.lookup name dmap - , Map.findWithDefault Map.empty name amap)) - case res of - Just x -> return $ map (first $ T.unpack . showGhc) x - Nothing -> throwErrors errs - where - throwErrors = liftIO . throwIO . mkSrcErr - compiled n = - -- TODO: Find a more direct indicator. - case nameSrcLoc n of - RealSrcLoc {} -> False - UnhelpfulLoc {} -> True - -fakeSpan :: RealSrcSpan -fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "") 1 1 + -- 2021-11-18: NOTE: Map Int would become IntMap if next GHCs. + -> IO (Either GHC.ErrorMessages (Map.Map Name (Either GetDocsFailure (Maybe HsDocString, Maybe (Map.Map Int HsDocString))))) + -- ^ Return a 'Map' of 'Name's to 'Either' (no docs messages) (general doc body & arg docs) +getDocsBatch hsc_env mod names = do + ((_warns,errs), res) <- initTypecheckEnv hsc_env mod $ Map.fromList <$> traverse getDocsNonInteractive' names + pure $ maybeToEither errs res -- | Non-interactive, batch version of 'InteractiveEval.lookupNames'. -- The interactive paths create problems in ghc-lib builds @@ -1034,11 +1056,11 @@ lookupName :: HscEnv -> Name -> IO (Maybe TyThing) lookupName hsc_env mod name = do - (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do + (_messages, res) <- initTypecheckEnv hsc_env mod $ do tcthing <- tcLookup name case tcthing of AGlobal thing -> return thing - ATcId{tct_id=id} -> return (AnId id) + ATcId{tct_id=id} -> return $ AnId id _ -> panic "tcRnLookupName'" return res diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 14ff4a29fa..449a58c0e2 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -574,9 +574,9 @@ getBindingsRule :: Rules () getBindingsRule = define $ \GetBindings f -> do HAR{hieKind=kind, refMap=rm} <- use_ GetHieAst f - case kind of - HieFresh -> pure ([], Just $ bindings rm) - HieFromDisk _ -> pure ([], Nothing) + pure . (mempty,) $ case kind of + HieFresh -> Just $ bindings rm + HieFromDisk _ -> Nothing getDocMapRule :: Rules () getDocMapRule = @@ -688,8 +688,7 @@ loadGhcSession ghcSessionDepsConfig = do afp <- liftIO $ makeAbsolute fp let nfp = toNormalizedFilePath' afp itExists <- getFileExists nfp - when itExists $ void $ do - use_ GetModificationTime nfp + when itExists $ void $ use_ GetModificationTime nfp mapM_ addDependency deps opts <- getIdeOptions @@ -722,7 +721,7 @@ ghcSessionDepsDefinition ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do let hsc = hscEnv env - mbdeps <- mapM(fmap artifactFilePath . snd) <$> use_ GetLocatedImports file + mbdeps <- traverse (fmap artifactFilePath . snd) <$> use_ GetLocatedImports file case mbdeps of Nothing -> return Nothing Just deps -> do diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs index e3b6d2a453..69f8607629 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs @@ -27,6 +27,8 @@ module Development.IDE.GHC.Compat.Outputable ( mkWarnMsg, mkSrcErr, srcErrorMessages, + Messages, + ErrorMessages ) where @@ -49,7 +51,7 @@ import GHC.Driver.Session import GHC.Driver.Types as HscTypes import GHC.Types.Name.Reader (GlobalRdrEnv) import GHC.Types.SrcLoc -import GHC.Utils.Error as Err hiding (mkWarnMsg) +import GHC.Utils.Error hiding (mkWarnMsg) import qualified GHC.Utils.Error as Err import GHC.Utils.Outputable as Out #else diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 97a5a3e065..ecd2e9a8c2 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -24,14 +24,14 @@ import Language.LSP.Types import qualified Data.Text as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition)) -hover :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover)) +gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition)) +hover :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover)) gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentTypeDefinition)) -documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight)) -gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List) -gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List) -hover = request "Hover" getAtPoint Nothing foundHover -documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List +documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight)) +gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List) +hover = request "Hover" getAtPoint Nothing foundHover +documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location)) references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $ diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 36bdd58303..23fcdf4d35 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -40,6 +40,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Data.Coerce (coerce) +import Data.Set (Set) import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as M import Data.Maybe @@ -53,6 +54,7 @@ import Data.List.Extra (dropEnd1, nubOrd) import Data.Version (showVersion) import HieDb hiding (pointCommand) import System.Directory (doesFileExist) +import Data.Bool (bool) -- | Gives a Uri for the module, given the .hie file location and the the module info -- The Bool denotes if it is a boot module @@ -62,13 +64,13 @@ type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping)) computeTypeReferences :: Foldable f => f (HieAST Type) -> M.Map Name [Span] -computeTypeReferences = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty +computeTypeReferences = foldr (\ast m -> M.unionWith (<>) (go ast) m) M.empty where go ast = M.unionsWith (++) (this : map go (nodeChildren ast)) where this = M.fromListWith (++) $ map (, [nodeSpan ast]) - $ concatMap namesInType + $ foldMap namesInType $ mapMaybe (\x -> guard (not $ all isOccurrence $ identInfo x) *> identType x) $ M.elems $ nodeIdentifiers $ nodeInfo ast @@ -163,8 +165,12 @@ documentHighlight hf rf pos = pure highlights n <- ns ref <- fromMaybe [] (M.lookup (Right n) rf) pure $ makeHighlight ref + + makeHighlight :: (RealSrcSpan, IdentifierDetails a) -> DocumentHighlight makeHighlight (sp,dets) = DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets) + + highlightType :: Set ContextInfo -> DocumentHighlightKind highlightType s = if any (isJust . getScopeFromContext) s then HkWrite @@ -204,12 +210,12 @@ atPoint -> Maybe (Maybe Range, [T.Text]) atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo where - -- Hover info for values/data + -- | Get hover info for values/data hoverInfo ast = (Just range, prettyNames ++ pTypes) where - pTypes - | Prelude.length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes - | otherwise = map wrapHaskell prettyTypes + pTypes = + bool id dropEnd1 (Prelude.length names == 1) + $ map wrapHaskell prettyConcreteTypes range = realSrcSpanToRange $ nodeSpan ast @@ -237,11 +243,13 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ p version = T.pack $ showVersion (unitPackageVersion conf) pure $ " *(" <> pkgName <> "-" <> version <> ")*" - prettyTypes = map (("_ :: "<>) . prettyType) types prettyType t = case kind of HieFresh -> showGhc t HieFromDisk full_file -> showGhc $ hieTypeToIface $ recoverFullType t (hie_types full_file) + -- | Local inferred most concrete type signature. + prettyConcreteTypes = map (("_ :: "<>) . prettyType) types + definedAt name = -- do not show "at " and similar messages -- see the code of 'pprNameDefnLoc' for more information @@ -387,8 +395,10 @@ defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile)) defRowToSymbolInfo _ = Nothing pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] -pointCommand hf pos k = - catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> +pointCommand hf pos getter = + catMaybes $ M.elems $ M.mapWithKey findInfo (getAsts hf) + where + findInfo fs ast = -- Since GHC 9.2: -- getAsts :: Map HiePath (HieAst a) -- type HiePath = LexialFastString @@ -399,10 +409,8 @@ pointCommand hf pos k = -- -- 'coerce' here to avoid an additional function for maintaining -- backwards compatibility. - case selectSmallestContaining (sp $ coerce fs) ast of - Nothing -> Nothing - Just ast' -> Just $ k ast' - where + let smallestRange = selectSmallestContaining (sp $ coerce fs) ast in + fmap getter smallestRange sloc fs = mkRealSrcLoc fs (line+1) (cha+1) sp fs = mkRealSrcSpan (sloc fs) (sloc fs) line = _line pos diff --git a/ghcide/src/Development/IDE/Spans/Common.hs b/ghcide/src/Development/IDE/Spans/Common.hs index 0a60120138..59b7029484 100644 --- a/ghcide/src/Development/IDE/Spans/Common.hs +++ b/ghcide/src/Development/IDE/Spans/Common.hs @@ -40,6 +40,7 @@ showGhc = showSD . ppr showSD :: SDoc -> T.Text showSD = T.pack . unsafePrintSDoc +-- | Print the name, dropping the unique tagging from it. showNameWithoutUniques :: Outputable a => a -> T.Text showNameWithoutUniques = T.pack . printNameWithoutUniques @@ -96,9 +97,7 @@ spanDocToMarkdownForTest = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing -- Simple (and a bit hacky) conversion from Haddock markup to Markdown -haddockToMarkdown - :: H.DocH String String -> String - +haddockToMarkdown :: H.DocH String String -> String haddockToMarkdown H.DocEmpty = "" haddockToMarkdown (H.DocAppend d1 d2) diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 8afe4f72fe..18dd381ddf 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -12,9 +12,9 @@ module Development.IDE.Spans.Documentation ( , mkDocMap ) where -import Control.Monad import Control.Monad.IO.Class import Control.Monad.Extra (findM) +import Data.Bool (bool) import Data.Either import Data.Foldable import Data.List.Extra @@ -44,16 +44,16 @@ mkDocMap env rm this_mod = k <- foldrM getType (tcg_type_env this_mod) names pure $ DKMap d k where - getDocs n map - | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist + getDocs n mapToSpanDoc + | maybe True (mod ==) $ nameModule_maybe n = pure mapToSpanDoc -- we already have the docs in this_docs, or they do not exist | otherwise = do doc <- getDocumentationTryGhc env mod n - pure $ extendNameEnv map n doc - getType n map + pure $ extendNameEnv mapToSpanDoc n doc + getType n mapToTyThing | isTcOcc $ occName n = do kind <- lookupKind env mod n - pure $ maybe map (extendNameEnv map n) kind - | otherwise = pure map + pure $ maybe mapToTyThing (extendNameEnv mapToTyThing n) kind + | otherwise = pure mapToTyThing names = rights $ S.toList idents idents = M.keysSet rm mod = tcg_mod this_mod @@ -62,39 +62,49 @@ lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) lookupKind env mod = fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod +intoSpanDoc :: HscEnv -> Name -> Either a (Maybe HsDocString, b) -> IO SpanDoc +intoSpanDoc env name a = extractDocString a <$> getSpanDocUris name + where + extractDocString :: Either b1 (Maybe HsDocString, b2) -> SpanDocUris -> SpanDoc + -- 2021-11-17: FIXME: ArgDocs get dropped here - instead propagate them. + extractDocString (Right (Just docs, _)) = SpanDocString docs + extractDocString _ = SpanDocText mempty + + -- | Get the uris to the documentation and source html pages if they exist + getSpanDocUris :: Name -> IO SpanDocUris + getSpanDocUris name = do + (docFu, srcFu) <- + case nameModule_maybe name of + Just mod -> liftIO $ do + let + toUriFileText :: (HscEnv -> Module -> IO (Maybe FilePath)) -> IO (Maybe T.Text) + toUriFileText f = (fmap . fmap) (getUri . filePathToUri) $ f env mod + doc <- toUriFileText lookupDocHtmlForModule + src <- toUriFileText lookupSrcHtmlForModule + return (doc, src) + Nothing -> pure mempty + let + embelishUri :: Functor f => T.Text -> f T.Text -> f T.Text + embelishUri f = fmap (<> "#" <> f <> showNameWithoutUniques name) + + docUri = embelishUri (bool "t:" "v:" $ isValName name) docFu + srcUri = embelishUri mempty srcFu + + return $ SpanDocUris docUri srcUri + getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc -getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] +getDocumentationTryGhc env mod name = do + res <- getDocsNonInteractive env mod name + case res of + Left _ -> pure emptySpanDoc + Right res -> uncurry (intoSpanDoc env) res -getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] +getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO (M.Map Name SpanDoc) getDocumentationsTryGhc env mod names = do - res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names + res <- getDocsBatch env mod names case res of - Left _ -> return [] - Right res -> zipWithM unwrap res names - where - unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n - unwrap _ n = mkSpanDocText n - - mkSpanDocText name = - SpanDocText [] <$> getUris name - - -- Get the uris to the documentation and source html pages if they exist - getUris name = do - (docFu, srcFu) <- - case nameModule_maybe name of - Just mod -> liftIO $ do - doc <- toFileUriText $ lookupDocHtmlForModule env mod - src <- toFileUriText $ lookupSrcHtmlForModule env mod - return (doc, src) - Nothing -> pure (Nothing, Nothing) - let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu - srcUri = (<> "#" <> showNameWithoutUniques name) <$> srcFu - selector - | isValName name = "v:" - | otherwise = "t:" - return $ SpanDocUris docUri srcUri - - toFileUriText = (fmap . fmap) (getUri . filePathToUri) + Left _ -> return mempty + Right res -> sequenceA $ M.mapWithKey (intoSpanDoc env) res getDocumentation :: HasSrcSpan name @@ -161,7 +171,7 @@ getDocumentation sources targetName = fromMaybe [] $ do docHeaders :: [RealLocated AnnotationComment] -> [T.Text] docHeaders = mapMaybe (\(L _ x) -> wrk x) - where + where wrk = \case -- When `Opt_Haddock` is enabled. AnnDocCommentNext s -> Just $ T.pack s diff --git a/hie-compat/src-ghc810/Compat/HieAst.hs b/hie-compat/src-ghc810/Compat/HieAst.hs index 3d2eba2feb..c4567953c3 100644 --- a/hie-compat/src-ghc810/Compat/HieAst.hs +++ b/hie-compat/src-ghc810/Compat/HieAst.hs @@ -50,7 +50,7 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Data ( Data, Typeable ) import Data.List ( foldl1' ) -import Data.Maybe ( listToMaybe ) +import Data.Maybe ( listToMaybe, fromMaybe ) import Control.Monad.Trans.Reader import Control.Monad.Trans.Class ( lift ) @@ -506,9 +506,7 @@ instance ToHie (Context (Located Var)) where C context (L (RealSrcSpan span) name') -> do m <- asks name_remapping - let name = case lookupNameEnv m (varName name') of - Just var -> var - Nothing-> name' + let name = fromMaybe name' (lookupNameEnv m (varName name')) pure [Node (NodeInfo S.empty [] $ @@ -523,9 +521,7 @@ instance ToHie (Context (Located Name)) where toHie c = case c of C context (L (RealSrcSpan span) name') -> do m <- asks name_remapping - let name = case lookupNameEnv m name' of - Just var -> varName var - Nothing -> name' + let name = maybe name' varName (lookupNameEnv m name') pure [Node (NodeInfo S.empty [] $