diff --git a/docs/features.md b/docs/features.md index 449db37c7f..7db7fb93a3 100644 --- a/docs/features.md +++ b/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` | diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 60d4a5c810..10b7379246 100644 --- a/haskell-language-server.cabal +++ b/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 diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index ecaf5f5d41..045be02359 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/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 -- --------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index f352cc179d..5fb3660d65 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/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 diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 96edee141c..e546e4000c 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/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]) diff --git a/plugins/hls-document-link-plugin/src/Ide/Plugin/DocumentLink.hs b/plugins/hls-document-link-plugin/src/Ide/Plugin/DocumentLink.hs new file mode 100644 index 0000000000..12e5a811b7 --- /dev/null +++ b/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) diff --git a/plugins/hls-document-link-plugin/test/Main.hs b/plugins/hls-document-link-plugin/test/Main.hs new file mode 100644 index 0000000000..5a49be2da9 --- /dev/null +++ b/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 diff --git a/plugins/hls-document-link-plugin/test/testdata/Definition.hs b/plugins/hls-document-link-plugin/test/testdata/Definition.hs new file mode 100644 index 0000000000..fb9bcbdc57 --- /dev/null +++ b/plugins/hls-document-link-plugin/test/testdata/Definition.hs @@ -0,0 +1,4 @@ +answer :: Int +answer = 42 +living :: Bool +living = True diff --git a/plugins/hls-document-link-plugin/test/testdata/ImportModule.hs b/plugins/hls-document-link-plugin/test/testdata/ImportModule.hs new file mode 100644 index 0000000000..6d7cbf1243 --- /dev/null +++ b/plugins/hls-document-link-plugin/test/testdata/ImportModule.hs @@ -0,0 +1,3 @@ +import Data.Maybe (fromJust, fromMaybe, Maybe(Just, Nothing)) +import Data.Either (Either (..)) +f = (fromJust, fromMaybe) diff --git a/plugins/hls-document-link-plugin/test/testdata/NoDocumentLinks.hs b/plugins/hls-document-link-plugin/test/testdata/NoDocumentLinks.hs new file mode 100644 index 0000000000..662527ea76 --- /dev/null +++ b/plugins/hls-document-link-plugin/test/testdata/NoDocumentLinks.hs @@ -0,0 +1 @@ +answer = 42 diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 5a56aee686..18d9c2e095 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -131,6 +131,10 @@ import qualified Development.IDE.Plugin.CodeAction as Refactor import qualified Ide.Plugin.SemanticTokens as SemanticTokens #endif +#if hls_documentLink +import qualified Ide.Plugin.DocumentLink as DocumentLink +#endif + data Log = forall a. (Pretty a) => Log PluginId a @@ -247,5 +251,8 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins #endif #if hls_notes let pId = "notes" in Notes.descriptor (pluginRecorder pId) pId : +#endif +#if hls_documentLink + let pId = "documentLink" in DocumentLink.descriptor (pluginRecorder pId) pId: #endif GhcIde.descriptors (pluginRecorder "ghcide") diff --git a/test/testdata/schema/ghc910/default-config.golden.json b/test/testdata/schema/ghc910/default-config.golden.json index 0c0704b257..cd22a0b7e0 100644 --- a/test/testdata/schema/ghc910/default-config.golden.json +++ b/test/testdata/schema/ghc910/default-config.golden.json @@ -38,6 +38,9 @@ "codeActionsOn": true, "codeLensOn": true }, + "documentLink": { + "globalOn": true + }, "eval": { "codeActionsOn": true, "codeLensOn": true, diff --git a/test/testdata/schema/ghc912/default-config.golden.json b/test/testdata/schema/ghc912/default-config.golden.json index 40c7b5b03a..381cb335c5 100644 --- a/test/testdata/schema/ghc912/default-config.golden.json +++ b/test/testdata/schema/ghc912/default-config.golden.json @@ -38,6 +38,9 @@ "codeActionsOn": true, "codeLensOn": true }, + "documentLink": { + "globalOn": true + }, "eval": { "codeActionsOn": true, "codeLensOn": true, diff --git a/test/testdata/schema/ghc914/default-config.golden.json b/test/testdata/schema/ghc914/default-config.golden.json index f94188128b..0bf5a3d062 100644 --- a/test/testdata/schema/ghc914/default-config.golden.json +++ b/test/testdata/schema/ghc914/default-config.golden.json @@ -38,6 +38,9 @@ "codeActionsOn": true, "codeLensOn": true }, + "documentLink": { + "globalOn": true + }, "eval": { "codeActionsOn": true, "codeLensOn": true, diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json index 9073784a75..691126bea3 100644 --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -38,6 +38,9 @@ "codeActionsOn": true, "codeLensOn": true }, + "documentLink": { + "globalOn": true + }, "eval": { "codeActionsOn": true, "codeLensOn": true, diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json index 9073784a75..691126bea3 100644 --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -38,6 +38,9 @@ "codeActionsOn": true, "codeLensOn": true }, + "documentLink": { + "globalOn": true + }, "eval": { "codeActionsOn": true, "codeLensOn": true,