feat: add hls-document-link-plugin to support LSP document links

docs/features.md

@@ -22,6 +22,7 @@ Many of these are standard LSP features, but a lot of special features are provi
 | [Selection range](#selection-range)                 | `textDocument/selectionRange`                                                                     |
 | [Rename](#rename)                                   | `textDocument/rename`                                                                             |
 | [Semantic tokens](#semantic-tokens)                 | `textDocument/semanticTokens/full`                                                                |
+| [Document links](#document-links)                   | `textDocument/documentLink`                                                                       |
 
 The individual sections below also identify which [HLS plugin](./what-is-hls.md#hls-plugins) is responsible for providing the given functionality, which is useful if you want to raise an issue report or contribute!
 Additionally, not all plugins are supported on all versions of GHC, see the [plugin support page](./support/plugin-support.md) for details.
@@ -434,6 +435,13 @@ Provided by: `hls-semantic-tokens-plugin`
 
 Provides semantic tokens for each token in the source code to support semantic highlighting.
 
+## Document links
+
+Provided by: `hls-document-link-plugin`
+
+Extracts clickable links (e.g., URLs in Haddock comments) and makes them available as LSP document links.
+This allows editors to open the linked resource directly from the source code.
+
 ## Rewrite to overloaded record syntax
 
 Provided by: `hls-overloaded-record-dot-plugin`
@@ -454,7 +462,6 @@ Contributions welcome!
 | Jump to declaration    | Unclear if useful | `textDocument/declaration`                     |
 | Jump to implementation | Unclear if useful | `textDocument/implementation`                  |
 | Linked editing         | Unimplemented     | `textDocument/linkedEditingRange`              |
-| Document links         | Unimplemented     | `textDocument/documentLink`                    |
 | Document color         | Unclear if useful | `textDocument/documentColor`                   |
 | Color presentation     | Unclear if useful | `textDocument/colorPresentation`               |
 | Monikers               | Unclear if useful | `textDocument/moniker`                         |

haskell-language-server.cabal

@@ -1176,6 +1176,58 @@ test-suite hls-code-range-plugin-tests
     , transformers
     , vector
 
+-----------------------------
+-- document link
+-----------------------------
+
+flag documentLink
+  description: Enable documentLink plugin
+  default:     True
+  manual:      True
+
+common documentLink
+  if flag(documentLink)
+    build-depends: haskell-language-server:hls-document-link-plugin
+    cpp-options: -Dhls_documentLink
+
+library hls-document-link-plugin
+  import:           defaults, pedantic, warnings
+  if !flag(documentLink)
+    buildable: False
+  exposed-modules:
+    Ide.Plugin.DocumentLink
+  hs-source-dirs: plugins/hls-document-link-plugin/src
+  build-depends:
+    , containers
+    , deepseq
+    , extra
+    , ghc
+    , ghcide           == 2.13.0.0
+    , hashable
+    , hls-plugin-api   == 2.13.0.0
+    , lens
+    , lsp
+    , mtl
+    , semigroupoids
+    , transformers
+    , vector
+
+test-suite hls-document-link-plugin-tests
+  import:           defaults, pedantic, test-defaults, warnings
+  if !flag(documentLink)
+    buildable: False
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   plugins/hls-document-link-plugin/test
+  main-is:          Main.hs
+  build-depends:
+    , ghcide
+    , filepath
+    , haskell-language-server:hls-document-link-plugin
+    , hls-test-utils             == 2.13.0.0
+    , text
+    , lens
+    , lsp-types
+
 -----------------------------
 -- change type signature plugin
 -----------------------------
@@ -1846,6 +1898,7 @@ library
                   , hlint
                   , stan
                   , signatureHelp
+                  , documentLink
                   , pragmas
                   , splice
                   , alternateNumberFormat

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

@@ -78,6 +78,7 @@ parsePluginConfig def = A.withObject "PluginConfig" $ \o -> PluginConfig
       <*> o .:? "selectionRangeOn" .!= plcSelectionRangeOn def
       <*> o .:? "foldingRangeOn"   .!= plcFoldingRangeOn def
       <*> o .:? "semanticTokensOn" .!= plcSemanticTokensOn def
+      <*> o .:? "documentLinkOn"   .!= plcDocumentLinkOn def
       <*> o .:? "config"           .!= plcConfig        def
 
 -- ---------------------------------------------------------------------

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

@@ -109,6 +109,7 @@ pluginsToDefaultConfig IdePlugins {..} =
           SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn]
           SMethod_TextDocumentSemanticTokensFull   -> ["semanticTokensOn" A..= plcSemanticTokensOn]
           SMethod_TextDocumentSemanticTokensFullDelta -> ["semanticTokensOn" A..= plcSemanticTokensOn]
+          SMethod_TextDocumentDocumentLink         -> ["documentLinkOn" A..= plcDocumentLinkOn]
           _                                 -> []
 
 -- | Generates json schema used in haskell vscode extension

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

@@ -269,6 +269,7 @@ data PluginConfig =
       , plcSelectionRangeOn :: !Bool
       , plcFoldingRangeOn   :: !Bool
       , plcSemanticTokensOn :: !Bool
+      , plcDocumentLinkOn   :: !Bool
       , plcConfig           :: !Object
       } deriving (Show,Eq)
 
@@ -288,11 +289,12 @@ instance Default PluginConfig where
       , plcSelectionRangeOn = True
       , plcFoldingRangeOn   = True
       , plcSemanticTokensOn = True
+      , plcDocumentLinkOn   = True
       , plcConfig           = mempty
       }
 
 instance ToJSON PluginConfig where
-    toJSON (PluginConfig g ch ca ih cl d h s sh c rn sr fr st cfg) = r
+    toJSON (PluginConfig g ch ca ih cl d h s sh c rn sr fr st dl cfg) = r
       where
         r = object [ "globalOn"         .= g
                    , "callHierarchyOn"  .= ch
@@ -308,6 +310,7 @@ instance ToJSON PluginConfig where
                    , "selectionRangeOn" .= sr
                    , "foldingRangeOn"   .= fr
                    , "semanticTokensOn" .= st
+                   , "documentLinkOn"   .= dl
                    , "config"           .= cfg
                    ]
 
@@ -613,6 +616,8 @@ instance PluginMethod Request Method_WorkspaceExecuteCommand where
 instance PluginMethod Request (Method_CustomMethod m) where
   handlesRequest _ _ _ _ _ = HandlesRequest
 
+instance PluginMethod Request Method_TextDocumentDocumentLink where
+
 -- Plugin Notifications
 
 instance PluginMethod Notification Method_TextDocumentDidOpen where
@@ -844,6 +849,9 @@ instance PluginRequestMethod Method_TextDocumentSemanticTokensFullDelta where
 instance PluginRequestMethod Method_TextDocumentInlayHint where
   combineResponses _ _ _ _ x = sconcat x
 
+instance PluginRequestMethod Method_TextDocumentDocumentLink where
+
+
 takeLefts :: [a |? b] -> [a]
 takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x])
 

plugins/hls-document-link-plugin/src/Ide/Plugin/DocumentLink.hs

@@ -0,0 +1,129 @@
+{-# LANGUAGE DataKinds                #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE OverloadedStrings        #-}
+{-# LANGUAGE PatternSynonyms          #-}
+{-# LANGUAGE StrictData               #-}
+{-# LANGUAGE TypeFamilies             #-}
+
+module Ide.Plugin.DocumentLink (descriptor, Log(..)) where
+
+import           Control.DeepSeq                  (NFData)
+import           Control.Monad.Trans.Maybe        (MaybeT (runMaybeT),
+                                                   hoistMaybe)
+import           Data.Hashable                    (Hashable)
+import qualified Data.Map.Strict                  as Map
+import           Data.Maybe                       (maybeToList)
+import           Development.IDE                  (DocAndTyThingMap (DKMap, getDocMap),
+                                                   GetDocMap (GetDocMap),
+                                                   GetHieAst (GetHieAst),
+                                                   HieAstResult (HAR, hieAst),
+                                                   IdeState (shakeExtras),
+                                                   Pretty (pretty), Range,
+                                                   Recorder, RuleResult, Rules,
+                                                   Uri (Uri), WithPriority,
+                                                   cmapWithPrio,
+                                                   defineNoDiagnostics,
+                                                   fromNormalizedFilePath,
+                                                   realSrcSpanToRange)
+import           Development.IDE.Core.PluginUtils (runIdeActionE, useMT,
+                                                   useWithStaleFastE)
+import qualified Development.IDE.Core.Shake       as Shake
+import           Development.IDE.GHC.Compat       (lookupNameEnv)
+import           Development.IDE.GHC.Compat.Util  (mkFastString)
+import           Development.IDE.Spans.Common     (DocMap,
+                                                   SpanDoc (SpanDocString, SpanDocText),
+                                                   spanDocUriDoc)
+import           GHC.Generics                     (Generic)
+import           GHC.Iface.Ext.Types              (HieAST (nodeChildren, nodeSpan, sourcedNodeInfo),
+                                                   HieASTs (getAsts),
+                                                   Identifier,
+                                                   NodeInfo (nodeIdentifiers),
+                                                   NodeOrigin (SourceInfo),
+                                                   SourcedNodeInfo (getSourcedNodeInfo),
+                                                   Span, pattern HiePath)
+import           Ide.Plugin.Error                 (getNormalizedFilePathE)
+import           Ide.Types                        (PluginDescriptor (pluginHandlers),
+                                                   PluginId,
+                                                   PluginMethodHandler,
+                                                   defaultPluginDescriptor,
+                                                   mkPluginHandler, pluginRules)
+import           Language.LSP.Protocol.Message    (Method (Method_TextDocumentDocumentLink),
+                                                   SMethod (SMethod_TextDocumentDocumentLink))
+import           Language.LSP.Protocol.Types      (DocumentLink (..),
+                                                   DocumentLinkParams (DocumentLinkParams),
+                                                   TextDocumentIdentifier (TextDocumentIdentifier),
+                                                   type (|?) (InL))
+
+newtype Log = LogShake Shake.Log
+
+instance Pretty Log where
+  pretty = \case
+    LogShake shakeLog -> pretty shakeLog
+
+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
+descriptor recorder pluginId =
+  (defaultPluginDescriptor pluginId "Provide document link of symbols")
+    { Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentDocumentLink documentLinkProvider,
+      Ide.Types.pluginRules    = getDocumentLinkRule recorder
+    }
+
+documentLinkProvider :: PluginMethodHandler IdeState Method_TextDocumentDocumentLink
+documentLinkProvider ideState _pluginId (DocumentLinkParams _ _ (TextDocumentIdentifier uri)) = do
+  nfp <- getNormalizedFilePathE uri
+  ((DocumentLinks uris), _pm) <- runIdeActionE "DocumentLink" (shakeExtras ideState) $ useWithStaleFastE GetDocumentLinks nfp
+  pure $ InL (map mkDocumentLink uris)
+
+mkDocumentLink :: (Range, Uri) -> DocumentLink
+mkDocumentLink (range, target) =
+  DocumentLink
+    { _range = range,
+      _target = Just target,
+      _tooltip = Nothing,
+      _data_ = Nothing
+    }
+
+data GetDocumentLinks = GetDocumentLinks
+  deriving (Eq, Show, Generic)
+
+instance Hashable GetDocumentLinks
+
+instance NFData GetDocumentLinks
+
+newtype DocumentLinks = DocumentLinks [(Range, Uri)]
+  deriving (Show, NFData)
+
+type instance RuleResult GetDocumentLinks = DocumentLinks
+
+getDocumentLinkRule :: Recorder (WithPriority Log) -> Rules ()
+getDocumentLinkRule recorder =
+  defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetDocumentLinks nfp -> runMaybeT $ do
+    HAR {hieAst} <- useMT GetHieAst nfp
+    DKMap {getDocMap} <- useMT GetDocMap nfp
+    ast <- hoistMaybe $ getAsts hieAst Map.!? HiePath (mkFastString $ fromNormalizedFilePath nfp)
+    let lookup = lookupDoc getDocMap
+    pure $ DocumentLinks (foldAst lookup ast)
+
+-- | Recursively traverses the HieAST in depth-first order to collect information
+-- from leaf nodes. For each leaf, it extracts all identifiers and their source
+-- spans, applies the lookup function, and aggregates the results using the
+-- Monoid instance.
+foldAst :: forall a t. Monoid a => ((Identifier, Span) -> a) -> HieAST t -> a
+foldAst lookup ast = case nodeChildren ast of
+  []   -> visitLeaf ast
+  asts -> foldMap (foldAst lookup) asts
+  where
+    visitLeaf leaf =
+      let span = nodeSpan leaf
+          mNodeInfo = Map.lookup SourceInfo $ getSourcedNodeInfo (sourcedNodeInfo leaf)
+      in flip foldMap mNodeInfo $ \nodeInfo ->
+           foldMap (\ident -> lookup (ident, span)) (Map.keys $ nodeIdentifiers nodeInfo)
+
+lookupDoc :: DocMap -> (Identifier, Span) -> [(Range, Uri)]
+lookupDoc dm (identifier, span) = do
+  Right name <- [identifier]
+  doc <- maybeToList $ lookupNameEnv dm name
+  uris <- maybeToList $ spanDocUriDoc $ case doc of
+        SpanDocString _ uris -> uris
+        SpanDocText _ uris   -> uris
+  pure (realSrcSpanToRange span, Uri uris)

plugins/hls-document-link-plugin/test/Main.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE QuasiQuotes        #-}
+
+import           Control.Exception          (throw)
+import           Control.Lens               hiding ((<.>))
+import           Control.Monad              (void)
+import           Data.Maybe                 (fromJust, fromMaybe)
+import qualified Data.Text                  as T
+import           Ide.Plugin.DocumentLink    (descriptor)
+import qualified Ide.Plugin.DocumentLink    as DL
+import qualified Language.LSP.Protocol.Lens as L
+import           System.FilePath
+import           Test.Hls
+import qualified Test.Hls.FileSystem        as FS
+
+testDataDir :: FilePath
+testDataDir = "plugins" </> "hls-document-link-plugin" </> "test" </> "testdata"
+
+main :: IO ()
+main = defaultTestRunner tests
+
+tests :: TestTree
+tests = testGroup "documentLink"
+  [ mkTest "no document links" "NoDocumentLinks" []
+  , mkTest "links of primitive types" "Definition"
+      [ (mkDocLink (mkRange 0 10 0 13) (Uri "GHC-Types.html#t:Int"))
+      , (mkDocLink (mkRange 2 10 2 14) (Uri "GHC-Types.html#t:Bool"))
+      , (mkDocLink (mkRange 3 9  3 13) (Uri "GHC-Types.html#v:True"))
+      ]
+  , mkTest "links from modules" "ImportModule"
+      [ (mkDocLink (mkRange 0 20 0 28) (Uri "GHC-Internal-Data-Maybe.html#v:fromJust"))
+      , (mkDocLink (mkRange 0 30 0 39) (Uri "GHC-Internal-Data-Maybe.html#v:fromMaybe"))
+      , (mkDocLink (mkRange 0 41 0 46) (Uri "GHC-Internal-Maybe.html#t:Maybe"))
+      , (mkDocLink (mkRange 0 47 0 51) (Uri "GHC-Internal-Maybe.html#v:Just"))
+      , (mkDocLink (mkRange 0 53 0 60) (Uri "GHC-Internal-Maybe.html#v:Nothing"))
+      , (mkDocLink (mkRange 1 20 1 26) (Uri "GHC-Internal-Data-Either.html#t:Either"))
+      , (mkDocLink (mkRange 2 5  2 13) (Uri "GHC-Internal-Data-Maybe.html#v:fromJust"))
+      , (mkDocLink (mkRange 2 15 2 24) (Uri "GHC-Internal-Data-Maybe.html#v:fromMaybe"))
+      ]
+  ]
+
+mkDocLink :: Range -> Uri -> SimilarDocumentLink
+mkDocLink range uri =
+  SimilarDocumentLink (DocumentLink range (Just uri) Nothing Nothing)
+
+mkTest :: TestName -> FilePath -> [SimilarDocumentLink] -> TestTree
+mkTest title file expected = testCase title $ runWithDocumentLink filehs $ do
+  adoc <- openDoc filehs "haskell"
+  void waitForBuildQueue
+  documentLink <- getDocumentLink adoc
+  liftIO $ ((fmap . fmap) SimilarDocumentLink documentLink) @?= Just expected
+  where filehs = file <.> "hs"
+
+runWithDocumentLink :: FilePath -> Session a -> IO a
+runWithDocumentLink file = runSessionWithServerInTmpDir def plugin (mkFs $ FS.directProject file)
+  where plugin :: PluginTestDescriptor DL.Log
+        plugin = mkPluginTestDescriptor descriptor "documentLink"
+        mkFs :: [FS.FileTree] -> FS.VirtualFileTree
+        mkFs = FS.mkVirtualFileTree testDataDir
+
+getDocumentLink :: TextDocumentIdentifier -> Session (Maybe [DocumentLink])
+getDocumentLink doc =
+  let params = DocumentLinkParams Nothing Nothing doc
+  in nullToMaybe . getResponseResult <$> request SMethod_TextDocumentDocumentLink params
+
+
+getResponseResult :: (Show (ErrorData m)) => TResponseMessage m -> MessageResult m
+getResponseResult rsp =
+  case rsp ^. L.result of
+    Right x  -> x
+    Left err -> throw $ UnexpectedResponseError (fromJust $ rsp ^. L.id) err
+
+newtype SimilarDocumentLink = SimilarDocumentLink DocumentLink
+  deriving newtype (Show)
+
+-- custom Eq to ignore some details, such as specific URI
+-- not symmetry
+instance Eq SimilarDocumentLink where
+  SimilarDocumentLink actualDocumentLink@( DocumentLink
+                                             actualRange
+                                             actualUri
+                                             actualTooltip
+                                             actualData )
+    == SimilarDocumentLink expectedDocumentLink@( DocumentLink
+                                                    expectRange
+                                                    expectUri
+                                                    expectToolTip
+                                                    expectData )
+    | actualDocumentLink == expectedDocumentLink = True
+    | actualRange == expectRange
+      && actualTooltip == expectToolTip
+      && actualData == expectData
+      = actualUri ~= expectUri
+    | otherwise = False
+
+class IsSimilar a where
+  (~=) :: a -> a -> Bool
+
+instance (IsSimilar a) => IsSimilar (Maybe a) where
+  m1 ~= m2 = fromMaybe False $ liftA2 (~=) m1 m2
+
+instance IsSimilar Uri where
+  (Uri actual) ~= (Uri except)
+    = except `T.isSuffixOf` actual