have separate linkDocTo and linkSourceTo

Author: Saizan

ghcide/src/Development/IDE/Core/Rules.hs

@@ -583,8 +583,8 @@ getDocMapRule recorder =
       (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file
       (hscEnv -> hsc, _)        <- useWithStale_ GhcSessionDeps file
       (HAR{refMap=rf}, _)       <- useWithStale_ GetHieAst file
-      linkToHackage <- optLinkToHackage <$> getIdeOptions
-      dkMap <- liftIO $ mkDocMap hsc rf tc linkToHackage
+      linkTgts <- linkTargets <$> getIdeOptions
+      dkMap <- liftIO $ mkDocMap hsc rf tc linkTgts
       return ([],Just dkMap)
 
 -- | Persistent rule to ensure that hover doesn't block on startup

ghcide/src/Development/IDE/Core/Shake.hs

@@ -449,7 +449,8 @@ getIdeOptions = do
             config <- liftIO $ LSP.runLspT env HLS.getClientConfig
             return x{optCheckProject = pure $ checkProject config,
                      optCheckParents = pure $ checkParents config,
-                     optLinkToHackage = linkToHackage config
+                     optLinkSourceTo = linkSourceTo config,
+                     optLinkDocTo = linkDocTo config
                 }
 
 getIdeOptionsIO :: ShakeExtras -> IO IdeOptions

ghcide/src/Development/IDE/Plugin/Completions.hs

@@ -56,7 +56,7 @@ import           Development.IDE.Core.Rules               (usePropertyAction)
 
 import qualified Ide.Plugin.Config                        as Config
 
-import           Development.IDE.Types.Options            (IdeOptions (optLinkToHackage))
+import           Development.IDE.Types.Options            (IdeOptions (linkTargets))
 import qualified GHC.LanguageExtensions                   as LangExt
 
 data Log = LogShake Shake.Log deriving Show
@@ -138,8 +138,8 @@ resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} ur
     doc <- case lookupNameEnv dm name of
       Just doc -> pure $ spanDocToMarkdown doc
       Nothing -> liftIO $ do
-        lc <- optLinkToHackage <$> getIdeOptionsIO (shakeExtras ide)
-        spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) lc name
+        ltgts <- linkTargets <$> getIdeOptionsIO (shakeExtras ide)
+        spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) ltgts name
     typ <- case lookupNameEnv km name of
       _ | not needType -> pure Nothing
       Just ty -> pure (safeTyThingType ty)

ghcide/src/Development/IDE/Spans/Documentation.hs

@@ -43,9 +43,9 @@ mkDocMap
   :: HscEnv
   -> RefMap a
   -> TcGblEnv
-  -> Bool
+  -> LinkTargets
   -> IO DocAndTyThingMap
-mkDocMap env rm this_mod linkToHackage =
+mkDocMap env rm this_mod linkTgts =
   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
@@ -56,7 +56,7 @@ mkDocMap env rm this_mod linkToHackage =
     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 linkToHackage n
+      (doc, _argDoc) <- getDocumentationTryGhc env linkTgts n
       pure $ extendNameEnv nameMap n doc
     getType n nameMap
       | Nothing <- lookupNameEnv nameMap n
@@ -66,7 +66,7 @@ mkDocMap env rm this_mod linkToHackage =
     getArgDocs n nameMap
       | maybe True (mod ==) $ nameModule_maybe n = pure nameMap
       | otherwise = do
-      (_doc, argDoc) <- getDocumentationTryGhc env linkToHackage n
+      (_doc, argDoc) <- getDocumentationTryGhc env linkTgts n
       pure $ extendNameEnv nameMap n argDoc
     names = rights $ S.toList idents
     idents = M.keysSet rm
@@ -81,8 +81,8 @@ getDocumentationTryGhc env l2h n =
   (fromMaybe (emptySpanDoc, mempty) . listToMaybe <$> getDocumentationsTryGhc env l2h [n])
     `catch` (\(_ :: IOEnvFailure) -> pure (emptySpanDoc, mempty))
 
-getDocumentationsTryGhc :: HscEnv -> Bool -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)]
-getDocumentationsTryGhc env linkToHackage names = do
+getDocumentationsTryGhc :: HscEnv -> LinkTargets -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)]
+getDocumentationsTryGhc env linkTgts names = do
   resOr <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names
   case resOr of
       Left _    -> return []
@@ -102,10 +102,18 @@ getDocumentationsTryGhc env linkToHackage names = do
             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)
+            let
+              doc_link = case linkTgts.linkDoc of
+                LinkToHackage ->
+                  toHackageDocUriText env mod (takeFileName <$> doc)
+                LinkToLocal ->
+                  toFileUriText doc
+              src_link = case linkTgts.linkSource of
+                LinkToHackage ->
+                  toHackageSrcUriText env mod (takeFileName <$> src)
+                LinkToLocal ->
+                  toFileUriText src
+            pure (doc_link, src_link)
           Nothing -> pure (Nothing, Nothing)
 
       let docUri = (<> "#" <> selector <> printOutputable name) <$> docFu

ghcide/src/Development/IDE/Types/Options.hs

@@ -16,6 +16,7 @@ module Development.IDE.Types.Options
   , IdeGhcSession(..)
   , OptHaddockParse(..)
   , ProgressReportingStyle(..)
+  , LinkTargets(..)
   ) where
 
 import           Control.Lens
@@ -26,7 +27,8 @@ import           Development.IDE.GHC.Compat        as GHC
 import           Development.IDE.Graph
 import           Development.IDE.Types.Diagnostics
 import           Ide.Plugin.Config
-import           Ide.Types                         (DynFlagsModifications)
+import           Ide.Types                         (DynFlagsModifications,
+                                                    OptLinkTo)
 import qualified Language.LSP.Protocol.Lens        as L
 import qualified Language.LSP.Protocol.Types       as LSP
 
@@ -85,8 +87,21 @@ 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.
+  , optLinkSourceTo       :: OptLinkTo
+    -- ^ `Source` link to Hackage or local sources.
+  , optLinkDocTo          :: OptLinkTo
+    -- ^ `Documentation` link to Hackage or local docs.
+  }
+
+data LinkTargets = LinkTargets
+  { linkSource :: !OptLinkTo
+  , linkDoc    :: !OptLinkTo
+  }
+
+linkTargets :: IdeOptions -> LinkTargets
+linkTargets IdeOptions{..} = LinkTargets
+  { linkSource = optLinkSourceTo
+  , linkDoc = optLinkDocTo
   }
 
 data OptHaddockParse = HaddockParse | NoHaddockParse
@@ -140,7 +155,8 @@ defaultIdeOptions session = IdeOptions
     ,optRunSubset = True
     ,optVerifyCoreFile = False
     ,optMaxDirtyAge = 100
-    ,optLinkToHackage = False
+    ,optLinkSourceTo = LinkToLocal
+    ,optLinkDocTo = LinkToLocal
     }
 
 defaultSkipProgress :: Typeable a => a -> Bool

hls-plugin-api/src/Ide/Plugin/Config.hs

@@ -43,7 +43,9 @@ parseConfig idePlugins defValue = A.withObject "settings" $ \o ->
     <*> o .:? "cabalFormattingProvider"                 .!= cabalFormattingProvider defValue
     <*> o .:? "maxCompletions"                          .!= maxCompletions defValue
     <*> o .:? "sessionLoading"                          .!= sessionLoading defValue
-    <*> o .:? "linkToHackage"                           .!= linkToHackage defValue
+    <*> o .:? "linkSourceTo"                            .!= linkSourceTo defValue
+    <*> o .:? "linkDocTo"                               .!=
+        linkDocTo defValue
     <*> A.explicitParseFieldMaybe (parsePlugins idePlugins) o "plugin" .!= plugins defValue
 
 -- | Parse the 'PluginConfig'.

hls-plugin-api/src/Ide/Types.hs

@@ -178,7 +178,8 @@ data Config =
     , cabalFormattingProvider :: !T.Text
     , maxCompletions          :: !Int
     , sessionLoading          :: !SessionLoadingPreferenceConfig
-    , linkToHackage           :: !Bool
+    , linkSourceTo            :: !OptLinkTo
+    , linkDocTo               :: !OptLinkTo
     , plugins                 :: !(Map.Map PluginId PluginConfig)
     } deriving (Show,Eq)
 
@@ -190,7 +191,8 @@ instance ToJSON Config where
            , "cabalFormattingProvider"     .= cabalFormattingProvider
            , "maxCompletions"              .= maxCompletions
            , "sessionLoading"              .= sessionLoading
-           , "linkToHackage"               .= linkToHackage
+           , "linkSourceTo"                .= linkSourceTo
+           , "linkDocTo"                   .= linkDocTo
            , "plugin"                      .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins
            ]
 
@@ -205,7 +207,8 @@ instance Default Config where
     -- this string value needs to kept in sync with the value provided in HlsPlugins
     , maxCompletions              = 40
     , sessionLoading              = PreferSingleComponentLoading
-    , linkToHackage               = False
+    , linkSourceTo                = LinkToLocal
+    , linkDocTo                   = LinkToLocal
     , plugins                     = mempty
     }
 
@@ -219,6 +222,11 @@ data CheckParents
   deriving anyclass (FromJSON, ToJSON)
 
 
+data OptLinkTo = LinkToHackage | LinkToLocal
+  deriving stock (Eq, Ord, Show, Enum, Generic)
+  deriving anyclass (FromJSON, ToJSON)
+
+
 data SessionLoadingPreferenceConfig
     = PreferSingleComponentLoading
     -- ^ Always load only a singleComponent when a new component