Use Hackage for Documentation and Source links

controlled by `linkToHackage` configuration field

Author: Saizan

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

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

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)

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,18 +99,37 @@ 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
             | isValName name = "v:"
             | 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

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

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'.

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
     }