diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index daaa28c5da..ac8981f743 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -570,8 +570,8 @@ getDocMapRule recorder = (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file (hscEnv -> hsc, _) <- useWithStale_ GhcSessionDeps file (HAR{refMap=rf}, _) <- useWithStale_ GetHieAst file - - dkMap <- liftIO $ mkDocMap hsc rf tc + linkToHackage <- optLinkToHackage <$> getIdeOptions + dkMap <- liftIO $ mkDocMap hsc rf tc linkToHackage return ([],Just dkMap) -- | Persistent rule to ensure that hover doesn't block on startup diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6fc9a4d00e..93bf66d7ea 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -441,7 +441,8 @@ getIdeOptions = do Just env -> do config <- liftIO $ LSP.runLspT env HLS.getClientConfig return x{optCheckProject = pure $ checkProject config, - optCheckParents = pure $ checkParents config + optCheckParents = pure $ checkParents config, + optLinkToHackage = linkToHackage config } getIdeOptionsIO :: ShakeExtras -> IO IdeOptions diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 7278b8a3e1..6c6b8fb89e 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -56,6 +56,7 @@ import Development.IDE.Core.Rules (usePropertyAction) import qualified Ide.Plugin.Config as Config +import Development.IDE.Types.Options (IdeOptions (optLinkToHackage)) import qualified GHC.LanguageExtensions as LangExt data Log = LogShake Shake.Log deriving Show @@ -136,7 +137,9 @@ resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} ur Nothing -> (mempty, mempty) doc <- case lookupNameEnv dm name of Just doc -> pure $ spanDocToMarkdown doc - Nothing -> liftIO $ spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) name + Nothing -> liftIO $ do + lc <- optLinkToHackage <$> getIdeOptionsIO (shakeExtras ide) + spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) lc name typ <- case lookupNameEnv km name of _ | not needType -> pure Nothing Just ty -> pure (safeTyThingType ty) diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index a4b6242315..58d2cc01a0 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -22,6 +22,7 @@ import qualified Data.Map as M import Data.Maybe import qualified Data.Set as S import qualified Data.Text as T +import Data.Version (showVersion) import Development.IDE.Core.Compile import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat @@ -30,7 +31,9 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.Util (printOutputable) import Development.IDE.Spans.Common import GHC.Iface.Ext.Utils (RefMap) -import Language.LSP.Protocol.Types (filePathToUri, getUri) +import GHC.Plugins (GenericUnitInfo (unitPackageName)) +import Language.LSP.Protocol.Types (Uri (..), filePathToUri, + getUri) import Prelude hiding (mod) import System.Directory import System.FilePath @@ -40,8 +43,9 @@ mkDocMap :: HscEnv -> RefMap a -> TcGblEnv + -> Bool -> IO DocAndTyThingMap -mkDocMap env rm this_mod = +mkDocMap env rm this_mod linkToHackage = do (Just Docs{docs_decls = UniqMap this_docs, docs_args = UniqMap this_arg_docs}) <- extractDocs (hsc_dflags env) this_mod d <- foldrM getDocs (fmap (\(_, x) -> (map hsDocString x) `SpanDocString` SpanDocUris Nothing Nothing) this_docs) names @@ -52,7 +56,7 @@ mkDocMap env rm this_mod = getDocs n nameMap | maybe True (mod ==) $ nameModule_maybe n = pure nameMap -- we already have the docs in this_docs, or they do not exist | otherwise = do - (doc, _argDoc) <- getDocumentationTryGhc env n + (doc, _argDoc) <- getDocumentationTryGhc env linkToHackage n pure $ extendNameEnv nameMap n doc getType n nameMap | Nothing <- lookupNameEnv nameMap n @@ -62,7 +66,7 @@ mkDocMap env rm this_mod = getArgDocs n nameMap | maybe True (mod ==) $ nameModule_maybe n = pure nameMap | otherwise = do - (_doc, argDoc) <- getDocumentationTryGhc env n + (_doc, argDoc) <- getDocumentationTryGhc env linkToHackage n pure $ extendNameEnv nameMap n argDoc names = rights $ S.toList idents idents = M.keysSet rm @@ -72,13 +76,13 @@ lookupKind :: HscEnv -> Name -> IO (Maybe TyThing) lookupKind env = fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env -getDocumentationTryGhc :: HscEnv -> Name -> IO (SpanDoc, IntMap SpanDoc) -getDocumentationTryGhc env n = - (fromMaybe (emptySpanDoc, mempty) . listToMaybe <$> getDocumentationsTryGhc env [n]) +getDocumentationTryGhc :: HscEnv -> Bool -> Name -> IO (SpanDoc, IntMap SpanDoc) +getDocumentationTryGhc env l2h n = + (fromMaybe (emptySpanDoc, mempty) . listToMaybe <$> getDocumentationsTryGhc env l2h [n]) `catch` (\(_ :: IOEnvFailure) -> pure (emptySpanDoc, mempty)) -getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)] -getDocumentationsTryGhc env names = do +getDocumentationsTryGhc :: HscEnv -> Bool -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)] +getDocumentationsTryGhc env linkToHackage names = do resOr <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names case resOr of Left _ -> return [] @@ -95,10 +99,15 @@ getDocumentationsTryGhc env names = 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) + doc <- lookupDocHtmlForModule env mod + src <- lookupSrcHtmlForModule env mod + -- If found, the local files are used as hints for the hackage links, this helps with symbols defined in an internal module but re-exported by another. + if linkToHackage + then return ( toHackageDocUriText env mod (takeFileName <$> doc) + , toHackageSrcUriText env mod (takeFileName <$> src)) + else pure (toFileUriText doc, toFileUriText src) Nothing -> pure (Nothing, Nothing) + let docUri = (<> "#" <> selector <> printOutputable name) <$> docFu srcUri = (<> "#" <> printOutputable name) <$> srcFu selector @@ -106,7 +115,21 @@ getDocumentationsTryGhc env names = do | otherwise = "t:" return $ SpanDocUris docUri srcUri - toFileUriText = (fmap . fmap) (getUri . filePathToUri) + toFileUriText = fmap (getUri . filePathToUri) + toHackageUriText subdir sep env mod hint = do + ui <- lookupUnit env (moduleUnit mod) + let htmlFile = case hint of + Nothing -> T.intercalate sep (map T.pack $ moduleNameChunks mod) <> ".html" + Just foundFile -> T.replace "-" sep $ T.pack foundFile + pure $! + mconcat $ + [ "http://hackage.haskell.org/package/" + , printOutputable (unitPackageName ui), "-", T.pack $ showVersion (unitPackageVersion ui), "/" + , subdir , "/" + , htmlFile + ] + toHackageDocUriText mod = toHackageUriText "docs" "-" mod + toHackageSrcUriText mod = toHackageUriText "docs/src" "." mod getDocumentation :: HasSrcSpan name @@ -146,10 +169,13 @@ lookupHtmlForModule mkDocPath hscEnv m = do -- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html -- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc. mns = do - chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m + chunks <- (reverse . drop1 . inits) $ moduleNameChunks m -- The file might use "." or "-" as separator map (`intercalate` chunks) [".", "-"] +moduleNameChunks :: Module -> [String] +moduleNameChunks m = splitOn "." $ (moduleNameString . moduleName) m + lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath] lookupHtmls df ui = -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 8d4d91e166..3257430a66 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -85,6 +85,8 @@ data IdeOptions = IdeOptions -- ^ Experimental feature to re-run only the subset of the Shake graph that has changed , optVerifyCoreFile :: Bool -- ^ Verify core files after serialization + , optLinkToHackage :: Bool + -- ^ `Documentation` and `Source` link to Hackage, rather than local docs. } data OptHaddockParse = HaddockParse | NoHaddockParse @@ -138,6 +140,7 @@ defaultIdeOptions session = IdeOptions ,optRunSubset = True ,optVerifyCoreFile = False ,optMaxDirtyAge = 100 + ,optLinkToHackage = False } defaultSkipProgress :: Typeable a => a -> Bool diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index ecaf5f5d41..f290bbb6ba 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -43,6 +43,7 @@ parseConfig idePlugins defValue = A.withObject "settings" $ \o -> <*> o .:? "cabalFormattingProvider" .!= cabalFormattingProvider defValue <*> o .:? "maxCompletions" .!= maxCompletions defValue <*> o .:? "sessionLoading" .!= sessionLoading defValue + <*> o .:? "linkToHackage" .!= linkToHackage defValue <*> A.explicitParseFieldMaybe (parsePlugins idePlugins) o "plugin" .!= plugins defValue -- | Parse the 'PluginConfig'. diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 314049b826..e21fe7517b 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -178,6 +178,7 @@ data Config = , cabalFormattingProvider :: !T.Text , maxCompletions :: !Int , sessionLoading :: !SessionLoadingPreferenceConfig + , linkToHackage :: !Bool , plugins :: !(Map.Map PluginId PluginConfig) } deriving (Show,Eq) @@ -189,6 +190,7 @@ instance ToJSON Config where , "cabalFormattingProvider" .= cabalFormattingProvider , "maxCompletions" .= maxCompletions , "sessionLoading" .= sessionLoading + , "linkToHackage" .= linkToHackage , "plugin" .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins ] @@ -204,6 +206,7 @@ instance Default Config where -- this string value needs to kept in sync with the value provided in HlsPlugins , maxCompletions = 40 , sessionLoading = PreferSingleComponentLoading + , linkToHackage = False , plugins = mempty } diff --git a/test/testdata/schema/ghc910/default-config.golden.json b/test/testdata/schema/ghc910/default-config.golden.json index 81b63dc6e4..5209c955b1 100644 --- a/test/testdata/schema/ghc910/default-config.golden.json +++ b/test/testdata/schema/ghc910/default-config.golden.json @@ -3,6 +3,7 @@ "checkParents": "CheckOnSave", "checkProject": true, "formattingProvider": "ormolu", + "linkToHackage": false, "maxCompletions": 40, "plugin": { "alternateNumberFormat": { diff --git a/test/testdata/schema/ghc912/default-config.golden.json b/test/testdata/schema/ghc912/default-config.golden.json index 598e3a4f2e..6154e64b3a 100644 --- a/test/testdata/schema/ghc912/default-config.golden.json +++ b/test/testdata/schema/ghc912/default-config.golden.json @@ -3,6 +3,7 @@ "checkParents": "CheckOnSave", "checkProject": true, "formattingProvider": "ormolu", + "linkToHackage": false, "maxCompletions": 40, "plugin": { "alternateNumberFormat": { diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json index efe24df3ae..0e0833e179 100644 --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -3,6 +3,7 @@ "checkParents": "CheckOnSave", "checkProject": true, "formattingProvider": "ormolu", + "linkToHackage": false, "maxCompletions": 40, "plugin": { "alternateNumberFormat": { diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json index efe24df3ae..0e0833e179 100644 --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -3,6 +3,7 @@ "checkParents": "CheckOnSave", "checkProject": true, "formattingProvider": "ormolu", + "linkToHackage": false, "maxCompletions": 40, "plugin": { "alternateNumberFormat": {