From 7a54a1dc5d5c360eb57a7c0f6e84f60349cf49ba Mon Sep 17 00:00:00 2001 From: Lin Jian Date: Mon, 9 Jun 2025 03:54:31 +0800 Subject: [PATCH 1/5] WIP: add basic boilerplate for signature help plugin --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 5 +- haskell-language-server.cabal | 53 ++++++++++++ hls-plugin-api/src/Ide/Plugin/Config.hs | 1 + hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 2 + hls-plugin-api/src/Ide/Types.hs | 12 ++- .../src/Ide/Plugin/SignatureHelp.hs | 83 +++++++++++++++++++ src/HlsPlugins.hs | 8 +- 7 files changed, 161 insertions(+), 3 deletions(-) create mode 100644 plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index a577cae32e..88834579e2 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -574,7 +574,8 @@ pointCommand hf pos k = -- -- 'coerce' here to avoid an additional function for maintaining -- backwards compatibility. - case selectSmallestContaining (sp $ coerce fs) ast of + case smallestContainingSatisfying (sp $ coerce fs) isFunction ast of + -- case selectSmallestContaining (sp $ coerce fs) ast of Nothing -> Nothing Just ast' -> Just $ k ast' where @@ -583,6 +584,8 @@ pointCommand hf pos k = line :: UInt line = _line pos cha = _character pos + isFunction ast = not $ null $ flip M.mapMaybeWithKey (getSourcedNodeInfo $ sourcedNodeInfo ast) $ \_nodeOrigin (NodeInfo _nodeAnnotations _nodeType _nodeIdentifiers) -> + Just True -- In ghc9, nodeInfo is monomorphic, so we need a case split here nodeInfoH :: HieKind a -> HieAST a -> NodeInfo a diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index bfa4f40185..d3e991df41 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -834,6 +834,58 @@ test-suite hls-stan-plugin-tests default-extensions: OverloadedStrings +----------------------------- +-- signature help plugin +----------------------------- + +flag signatureHelp + description: Enable signature help plugin + default: True + manual: True + +common signatureHelp + if flag(signatureHelp) + build-depends: haskell-language-server:hls-signature-help-plugin + cpp-options: -Dhls_signatureHelp + +-- TODO(@linj) remove unneeded deps +library hls-signature-help-plugin + import: defaults, pedantic, warnings + if !flag(signatureHelp) + buildable: False + exposed-modules: Ide.Plugin.SignatureHelp + hs-source-dirs: plugins/hls-signature-help-plugin/src + default-extensions: + DerivingStrategies + LambdaCase + OverloadedStrings + build-depends: + , containers + , ghcide == 2.11.0.0 + , hashable + , hls-plugin-api == 2.11.0.0 + , haskell-language-server:hls-refactor-plugin + , lens + , lsp-types + , mtl + , text + , transformers + , unordered-containers + , regex-tdfa + + +-- test-suite hls-signature-help-plugin-tests +-- import: defaults, pedantic, test-defaults, warnings +-- if !flag(signatureHelp) +-- buildable: False +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: plugins/hls-signature-help-plugin/test +-- main-is: Main.hs +-- build-depends: +-- , haskell-language-server:hls-signature-help-plugin +-- , hls-test-utils == 2.11.0.0 +-- , hls-plugin-api == 2.11.0.0 + ----------------------------- -- module name plugin ----------------------------- @@ -1846,6 +1898,7 @@ library , retrie , hlint , stan + , signatureHelp , moduleName , pragmas , splice diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index 4fee92c309..ecaf5f5d41 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -72,6 +72,7 @@ parsePluginConfig def = A.withObject "PluginConfig" $ \o -> PluginConfig <*> o .:? "diagnosticsOn" .!= plcDiagnosticsOn def -- AZ <*> o .:? "hoverOn" .!= plcHoverOn def <*> o .:? "symbolsOn" .!= plcSymbolsOn def + <*> o .:? "signatureHelpOn" .!= plcSignatureHelpOn def <*> o .:? "completionOn" .!= plcCompletionOn def <*> o .:? "renameOn" .!= plcRenameOn def <*> o .:? "selectionRangeOn" .!= plcSelectionRangeOn def diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index a7350ab344..f352cc179d 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -104,6 +104,7 @@ pluginsToDefaultConfig IdePlugins {..} = SMethod_TextDocumentRename -> ["renameOn" A..= plcRenameOn] SMethod_TextDocumentHover -> ["hoverOn" A..= plcHoverOn] SMethod_TextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn] + SMethod_TextDocumentSignatureHelp -> ["signatureHelpOn" A..= plcSignatureHelpOn] SMethod_TextDocumentCompletion -> ["completionOn" A..= plcCompletionOn] SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn] SMethod_TextDocumentSemanticTokensFull -> ["semanticTokensOn" A..= plcSemanticTokensOn] @@ -137,6 +138,7 @@ pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlug SMethod_TextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename" plcRenameOn] SMethod_TextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover" plcHoverOn] SMethod_TextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols" plcSymbolsOn] + SMethod_TextDocumentSignatureHelp -> [toKey' "signatureHelpOn" A..= schemaEntry "signature help" plcSignatureHelpOn] SMethod_TextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions" plcCompletionOn] SMethod_TextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy" plcCallHierarchyOn] SMethod_TextDocumentSemanticTokensFull -> [toKey' "semanticTokensOn" A..= schemaEntry "semantic tokens" plcSemanticTokensOn] diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 3a06656a77..662b424bf7 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -263,6 +263,7 @@ data PluginConfig = , plcDiagnosticsOn :: !Bool , plcHoverOn :: !Bool , plcSymbolsOn :: !Bool + , plcSignatureHelpOn :: !Bool , plcCompletionOn :: !Bool , plcRenameOn :: !Bool , plcSelectionRangeOn :: !Bool @@ -281,6 +282,7 @@ instance Default PluginConfig where , plcDiagnosticsOn = True , plcHoverOn = True , plcSymbolsOn = True + , plcSignatureHelpOn = True , plcCompletionOn = True , plcRenameOn = True , plcSelectionRangeOn = True @@ -290,7 +292,7 @@ instance Default PluginConfig where } instance ToJSON PluginConfig where - toJSON (PluginConfig g ch ca ih cl d h s c rn sr fr st cfg) = r + toJSON (PluginConfig g ch ca ih cl d h s sh c rn sr fr st cfg) = r where r = object [ "globalOn" .= g , "callHierarchyOn" .= ch @@ -300,6 +302,7 @@ instance ToJSON PluginConfig where , "diagnosticsOn" .= d , "hoverOn" .= h , "symbolsOn" .= s + , "signatureHelpOn" .= sh , "completionOn" .= c , "renameOn" .= rn , "selectionRangeOn" .= sr @@ -541,6 +544,9 @@ instance PluginMethod Request Method_TextDocumentHover where instance PluginMethod Request Method_TextDocumentDocumentSymbol where handlesRequest = pluginEnabledWithFeature plcSymbolsOn +instance PluginMethod Request Method_TextDocumentSignatureHelp where + handlesRequest = pluginEnabledWithFeature plcSignatureHelpOn + instance PluginMethod Request Method_CompletionItemResolve where -- See Note [Resolve in PluginHandlers] handlesRequest = pluginEnabledResolve plcCompletionOn @@ -764,6 +770,10 @@ instance PluginRequestMethod Method_TextDocumentDocumentSymbol where si = SymbolInformation name' (ds ^. L.kind) Nothing parent (ds ^. L.deprecated) loc in [si] <> children' +-- TODO(@linj) is this correct? +instance PluginRequestMethod Method_TextDocumentSignatureHelp where + combineResponses _ _ _ _ (x :| _) = x + instance PluginRequestMethod Method_CompletionItemResolve where -- A resolve request should only have one response. -- See Note [Resolve in PluginHandlers] diff --git a/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs b/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs new file mode 100644 index 0000000000..8e14e962e4 --- /dev/null +++ b/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Ide.Plugin.SignatureHelp (descriptor) where + +import Control.Monad.Trans (lift) +import qualified Data.List.NonEmpty as NL +import qualified Data.Text as T +import Development.IDE +import Development.IDE.Core.PluginUtils (runIdeActionE, + useWithStaleFastE) +import Development.IDE.Spans.AtPoint (getNamesAtPoint) +import Ide.Plugin.Error +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Text.Regex.TDFA ((=~)) + +data Log = LogDummy + +instance Pretty Log where + pretty = \case + LogDummy -> "TODO(@linj) remove this dummy log" + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor _recorder pluginId = + (defaultPluginDescriptor pluginId "Provides signature help of something callable") + { pluginHandlers = mkPluginHandler SMethod_TextDocumentSignatureHelp signatureHelpProvider + } + +-- get src info +-- function +-- which arg is under the cursor +-- get function type (and arg doc) +-- assemble result +-- TODO(@linj) +signatureHelpProvider :: PluginMethodHandler IdeState Method_TextDocumentSignatureHelp +signatureHelpProvider ideState _pluginId (SignatureHelpParams (TextDocumentIdentifier uri) position _mProgreeToken _mContext) = do + nfp <- getNormalizedFilePathE uri + names <- runIdeActionE "signatureHelp" (shakeExtras ideState) $ do + (HAR {hieAst}, positionMapping) <- useWithStaleFastE GetHieAst nfp + let ns = getNamesAtPoint hieAst position positionMapping + pure ns + mRangeAndDoc <- + runIdeActionE + "signatureHelp.getDoc" + (shakeExtras ideState) + (lift (getAtPoint nfp position)) + let (_mRange, contents) = case mRangeAndDoc of + Just (mRange, contents) -> (mRange, contents) + Nothing -> (Nothing, []) + + pure $ + InL $ + SignatureHelp + ( case mkSignatureHelpLabel names contents of + Just label -> + [ SignatureInformation + label + Nothing + (Just [ParameterInformation (InR (5, 8)) Nothing]) + Nothing + ] + Nothing -> [] + ) + (Just 0) + (Just $ InL 0) + where + mkSignatureHelpLabel names types = + case (chooseName $ printName <$> names, chooseType types >>= showType) of + (Just name, Just typ) -> Just $ T.pack name <> " :: " <> typ + _ -> Nothing + chooseName names = case names of + [] -> Nothing + name : names' -> Just $ NL.last (name NL.:| names') + chooseType types = case types of + [] -> Nothing + [t] -> Just t + _ -> Just $ types !! (length types - 2) + showType typ = getMatchedType $ typ =~ ("\n```haskell\n(.*) :: (.*)\n```\n" :: T.Text) + getMatchedType :: (T.Text, T.Text, T.Text, [T.Text]) -> Maybe T.Text + getMatchedType (_, _, _, [_, t]) = Just t + getMatchedType _ = Nothing diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 87a1af7392..ee416047b4 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -53,6 +53,10 @@ import qualified Ide.Plugin.Hlint as Hlint import qualified Ide.Plugin.Stan as Stan #endif +#if hls_signatureHelp +import qualified Ide.Plugin.SignatureHelp as SignatureHelp +#endif + #if hls_moduleName import qualified Ide.Plugin.ModuleName as ModuleName #endif @@ -214,6 +218,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins #if hls_stan let pId = "stan" in Stan.descriptor (pluginRecorder pId) pId : #endif +#if hls_signatureHelp + let pId = "signatureHelp" in SignatureHelp.descriptor (pluginRecorder pId) pId: +#endif #if hls_splice Splice.descriptor "splice" : #endif @@ -249,4 +256,3 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins let pId = "notes" in Notes.descriptor (pluginRecorder pId) pId : #endif GhcIde.descriptors (pluginRecorder "ghcide") - From 9168b740867611439c0b030d1c07e209e8489ace Mon Sep 17 00:00:00 2001 From: Lin Jian Date: Thu, 10 Jul 2025 16:59:55 +0800 Subject: [PATCH 2/5] WIP: finish signature help plugin MVP TODO: - handle more cases - add successful and (currently failed) tests - show documentation --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 5 +- haskell-language-server.cabal | 1 + .../src/Ide/Plugin/SignatureHelp.hs | 253 +++++++++++++----- 3 files changed, 191 insertions(+), 68 deletions(-) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 88834579e2..a577cae32e 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -574,8 +574,7 @@ pointCommand hf pos k = -- -- 'coerce' here to avoid an additional function for maintaining -- backwards compatibility. - case smallestContainingSatisfying (sp $ coerce fs) isFunction ast of - -- case selectSmallestContaining (sp $ coerce fs) ast of + case selectSmallestContaining (sp $ coerce fs) ast of Nothing -> Nothing Just ast' -> Just $ k ast' where @@ -584,8 +583,6 @@ pointCommand hf pos k = line :: UInt line = _line pos cha = _character pos - isFunction ast = not $ null $ flip M.mapMaybeWithKey (getSourcedNodeInfo $ sourcedNodeInfo ast) $ \_nodeOrigin (NodeInfo _nodeAnnotations _nodeType _nodeIdentifiers) -> - Just True -- In ghc9, nodeInfo is monomorphic, so we need a case split here nodeInfoH :: HieKind a -> HieAST a -> NodeInfo a diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index d3e991df41..c441289b01 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -861,6 +861,7 @@ library hls-signature-help-plugin OverloadedStrings build-depends: , containers + , ghc , ghcide == 2.11.0.0 , hashable , hls-plugin-api == 2.11.0.0 diff --git a/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs b/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs index 8e14e962e4..78219950ad 100644 --- a/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs +++ b/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs @@ -1,20 +1,62 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} module Ide.Plugin.SignatureHelp (descriptor) where -import Control.Monad.Trans (lift) -import qualified Data.List.NonEmpty as NL -import qualified Data.Text as T -import Development.IDE -import Development.IDE.Core.PluginUtils (runIdeActionE, - useWithStaleFastE) -import Development.IDE.Spans.AtPoint (getNamesAtPoint) -import Ide.Plugin.Error -import Ide.Types -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types -import Text.Regex.TDFA ((=~)) +import Control.Arrow ((>>>)) +import Data.Bifunctor (bimap) +import qualified Data.Map.Strict as M +import Data.Maybe (mapMaybe) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE (GetHieAst (GetHieAst), + HieAstResult (HAR, hieAst, hieKind), + HieKind (..), + IdeState (shakeExtras), + Pretty (pretty), + Recorder, WithPriority, + printOutputable) +import Development.IDE.Core.PluginUtils (runIdeActionE, + useWithStaleFastE) +import Development.IDE.Core.PositionMapping (fromCurrentPosition) +import Development.IDE.GHC.Compat (ContextInfo (Use), + FastStringCompat, HieAST, + HieASTs, + IdentifierDetails, Name, + RealSrcSpan, SDoc, + getAsts, + getSourceNodeIds, + hieTypeToIface, + hie_types, identInfo, + identType, + isAnnotationInNodeInfo, + mkRealSrcLoc, + mkRealSrcSpan, + nodeChildren, nodeSpan, + ppr, recoverFullType, + smallestContainingSatisfying, + sourceNodeInfo) +import Development.IDE.GHC.Compat.Util (LexicalFastString (LexicalFastString)) +import GHC.Data.Maybe (rightToMaybe) +import GHC.Types.SrcLoc (isRealSubspanOf) +import Ide.Plugin.Error (getNormalizedFilePathE) +import Ide.Types (PluginDescriptor (pluginHandlers), + PluginId, + PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Protocol.Message (Method (Method_TextDocumentSignatureHelp), + SMethod (SMethod_TextDocumentSignatureHelp)) +import Language.LSP.Protocol.Types (Null (Null), + ParameterInformation (ParameterInformation), + Position (Position), + SignatureHelp (SignatureHelp), + SignatureHelpParams (SignatureHelpParams), + SignatureInformation (SignatureInformation), + TextDocumentIdentifier (TextDocumentIdentifier), + UInt, + type (|?) (InL, InR)) data Log = LogDummy @@ -25,59 +67,142 @@ instance Pretty Log where descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor _recorder pluginId = (defaultPluginDescriptor pluginId "Provides signature help of something callable") - { pluginHandlers = mkPluginHandler SMethod_TextDocumentSignatureHelp signatureHelpProvider + { Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentSignatureHelp signatureHelpProvider } --- get src info --- function --- which arg is under the cursor --- get function type (and arg doc) --- assemble result --- TODO(@linj) +-- TODO(@linj) get doc signatureHelpProvider :: PluginMethodHandler IdeState Method_TextDocumentSignatureHelp signatureHelpProvider ideState _pluginId (SignatureHelpParams (TextDocumentIdentifier uri) position _mProgreeToken _mContext) = do nfp <- getNormalizedFilePathE uri - names <- runIdeActionE "signatureHelp" (shakeExtras ideState) $ do - (HAR {hieAst}, positionMapping) <- useWithStaleFastE GetHieAst nfp - let ns = getNamesAtPoint hieAst position positionMapping - pure ns - mRangeAndDoc <- - runIdeActionE - "signatureHelp.getDoc" - (shakeExtras ideState) - (lift (getAtPoint nfp position)) - let (_mRange, contents) = case mRangeAndDoc of - Just (mRange, contents) -> (mRange, contents) - Nothing -> (Nothing, []) - - pure $ - InL $ - SignatureHelp - ( case mkSignatureHelpLabel names contents of - Just label -> - [ SignatureInformation - label - Nothing - (Just [ParameterInformation (InR (5, 8)) Nothing]) - Nothing - ] - Nothing -> [] - ) - (Just 0) - (Just $ InL 0) + mResult <- runIdeActionE "signatureHelp" (shakeExtras ideState) $ do + -- TODO(@linj) why HAR {hieAst} may have more than one AST? + (HAR {hieAst, hieKind}, positionMapping) <- useWithStaleFastE GetHieAst nfp + case fromCurrentPosition positionMapping position of + Nothing -> pure Nothing + Just oldPosition -> do + let functionName = + extractInfoFromSmallestContainingFunctionApplicationAst + oldPosition + hieAst + (\span -> getLeftMostNode >>> getNodeName span) + functionType = + extractInfoFromSmallestContainingFunctionApplicationAst + oldPosition + hieAst + (\span -> getLeftMostNode >>> getNodeType hieKind span) + argumentNumber = + extractInfoFromSmallestContainingFunctionApplicationAst + oldPosition + hieAst + getArgumentNumber + pure $ Just (functionName, functionType, argumentNumber) + case mResult of + -- TODO(@linj) what do non-singleton lists mean? + Just (functionName : _, functionType : _, argumentNumber : _) -> do + pure $ InL $ mkSignatureHelp functionName functionType (fromIntegral argumentNumber - 1) + _ -> pure $ InR Null + +mkSignatureHelp :: Name -> Text -> UInt -> SignatureHelp +mkSignatureHelp functionName functionType argumentNumber = + let functionNameLabelPrefix = printOutputable (ppr functionName) <> " :: " + in SignatureHelp + [ SignatureInformation + (functionNameLabelPrefix <> functionType) + Nothing + (Just $ mkArguments (fromIntegral $ T.length functionNameLabelPrefix) functionType) + (Just $ InL argumentNumber) + ] + (Just 0) + (Just $ InL argumentNumber) + +-- TODO(@linj) can type string be a multi-line string? +mkArguments :: UInt -> Text -> [ParameterInformation] +mkArguments offset functionType = + let separator = " -> " + separatorLength = fromIntegral $ T.length separator + splits = T.breakOnAll separator functionType + prefixes = fst <$> splits + prefixLengths = fmap (T.length >>> fromIntegral) prefixes + ranges = + [ ( if previousPrefixLength == 0 then 0 else previousPrefixLength + separatorLength, + currentPrefixLength + ) + | (previousPrefixLength, currentPrefixLength) <- zip (0: prefixLengths) prefixLengths + ] + in [ ParameterInformation (InR range) Nothing + | range <- bimap (+offset) (+offset) <$> ranges + ] + +extractInfoFromSmallestContainingFunctionApplicationAst :: + Position -> HieASTs a -> (RealSrcSpan -> HieAST a -> Maybe b) -> [b] +extractInfoFromSmallestContainingFunctionApplicationAst position hieAsts extractInfo = + M.elems $ flip M.mapMaybeWithKey (getAsts hieAsts) $ \hiePath hieAst -> + smallestContainingSatisfying (positionToSpan hiePath position) (nodeHasAnnotation ("HsApp", "HsExpr")) hieAst + >>= extractInfo (positionToSpan hiePath position) where - mkSignatureHelpLabel names types = - case (chooseName $ printName <$> names, chooseType types >>= showType) of - (Just name, Just typ) -> Just $ T.pack name <> " :: " <> typ - _ -> Nothing - chooseName names = case names of - [] -> Nothing - name : names' -> Just $ NL.last (name NL.:| names') - chooseType types = case types of - [] -> Nothing - [t] -> Just t - _ -> Just $ types !! (length types - 2) - showType typ = getMatchedType $ typ =~ ("\n```haskell\n(.*) :: (.*)\n```\n" :: T.Text) - getMatchedType :: (T.Text, T.Text, T.Text, [T.Text]) -> Maybe T.Text - getMatchedType (_, _, _, [_, t]) = Just t - getMatchedType _ = Nothing + positionToSpan hiePath position = + let loc = mkLoc hiePath position in mkRealSrcSpan loc loc + mkLoc (LexicalFastString hiePath) (Position line character) = + mkRealSrcLoc hiePath (fromIntegral line + 1) (fromIntegral character + 1) + +type Annotation = (FastStringCompat, FastStringCompat) + +nodeHasAnnotation :: Annotation -> HieAST a -> Bool +nodeHasAnnotation annotation = sourceNodeInfo >>> maybe False (isAnnotationInNodeInfo annotation) + +-- TODO(@linj): the left most node may not be the function node. example: (if True then f else g) x +getLeftMostNode :: HieAST a -> HieAST a +getLeftMostNode thisNode = + case nodeChildren thisNode of + [] -> thisNode + leftChild: _ -> getLeftMostNode leftChild + +getNodeName :: RealSrcSpan -> HieAST a -> Maybe Name +getNodeName _span hieAst = + if nodeHasAnnotation ("HsVar", "HsExpr") hieAst + then + case mapMaybe extractName $ M.keys $ M.filter isUse $ getSourceNodeIds hieAst of + [name] -> Just name -- TODO(@linj) will there be more than one name? + _ -> Nothing + else Nothing -- TODO(@linj) must function node be HsVar? + where + extractName = rightToMaybe + +-- TODO(@linj) share code with getNodeName +getNodeType :: HieKind a -> RealSrcSpan -> HieAST a -> Maybe Text +getNodeType (hieKind :: HieKind a) _span hieAst = + if nodeHasAnnotation ("HsVar", "HsExpr") hieAst + then + case M.elems $ M.filter isUse $ getSourceNodeIds hieAst of + [identifierDetails] -> identType identifierDetails >>= (prettyType >>> Just) + _ -> Nothing -- TODO(@linj) will there be more than one identifierDetails? + else Nothing + where + -- modified from Development.IDE.Spans.AtPoint.atPoint + prettyType :: a -> Text + prettyType = expandType >>> printOutputable + + expandType :: a -> SDoc + expandType t = case hieKind of + HieFresh -> ppr t + HieFromDisk hieFile -> ppr $ hieTypeToIface $ recoverFullType t (hie_types hieFile) + +isUse :: IdentifierDetails a -> Bool +isUse = identInfo >>> S.member Use + +-- Just 1 means the first argument +getArgumentNumber :: RealSrcSpan -> HieAST a -> Maybe Integer +getArgumentNumber span hieAst = + if nodeHasAnnotation ("HsApp", "HsExpr") hieAst + then + case nodeChildren hieAst of + [leftChild, _] -> + if span `isRealSubspanOf` nodeSpan leftChild + then Nothing + else getArgumentNumber span leftChild >>= \argumentNumber -> Just (argumentNumber + 1) + _ -> Nothing -- impossible + else + case nodeChildren hieAst of + [] -> Just 0 -- the function is found + [child] -> getArgumentNumber span child -- ignore irrelevant nodes + _ -> Nothing -- TODO(@linj) handle more cases such as `if` From 4d7fa57a80c7873bbf9c17d2ef374f6646eaf61f Mon Sep 17 00:00:00 2001 From: Lin Jian Date: Wed, 16 Jul 2025 12:13:14 +0800 Subject: [PATCH 3/5] WIP: remove unused dependencies --- haskell-language-server.cabal | 7 ------- 1 file changed, 7 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index c441289b01..b31b02f8c8 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -863,16 +863,9 @@ library hls-signature-help-plugin , containers , ghc , ghcide == 2.11.0.0 - , hashable , hls-plugin-api == 2.11.0.0 - , haskell-language-server:hls-refactor-plugin - , lens , lsp-types - , mtl , text - , transformers - , unordered-containers - , regex-tdfa -- test-suite hls-signature-help-plugin-tests From 622c8ec65f3bccacf37338a3ccf096abae0b57b7 Mon Sep 17 00:00:00 2001 From: Lin Jian Date: Wed, 16 Jul 2025 13:49:40 +0800 Subject: [PATCH 4/5] WIP: fix func-tests --- test/testdata/schema/ghc910/default-config.golden.json | 3 +++ .../schema/ghc910/vscode-extension-schema.golden.json | 6 ++++++ test/testdata/schema/ghc912/default-config.golden.json | 3 +++ .../schema/ghc912/vscode-extension-schema.golden.json | 6 ++++++ test/testdata/schema/ghc96/default-config.golden.json | 3 +++ .../schema/ghc96/vscode-extension-schema.golden.json | 6 ++++++ test/testdata/schema/ghc98/default-config.golden.json | 3 +++ .../schema/ghc98/vscode-extension-schema.golden.json | 6 ++++++ 8 files changed, 36 insertions(+) diff --git a/test/testdata/schema/ghc910/default-config.golden.json b/test/testdata/schema/ghc910/default-config.golden.json index 3b4e687ef9..81b63dc6e4 100644 --- a/test/testdata/schema/ghc910/default-config.golden.json +++ b/test/testdata/schema/ghc910/default-config.golden.json @@ -150,6 +150,9 @@ }, "globalOn": false }, + "signatureHelp": { + "globalOn": true + }, "stan": { "globalOn": false } diff --git a/test/testdata/schema/ghc910/vscode-extension-schema.golden.json b/test/testdata/schema/ghc910/vscode-extension-schema.golden.json index 4ca08f296c..ba79ee22c7 100644 --- a/test/testdata/schema/ghc910/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc910/vscode-extension-schema.golden.json @@ -1037,6 +1037,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.signatureHelp.globalOn": { + "default": true, + "description": "Enables signatureHelp plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.stan.globalOn": { "default": false, "description": "Enables stan plugin", diff --git a/test/testdata/schema/ghc912/default-config.golden.json b/test/testdata/schema/ghc912/default-config.golden.json index 0dfbd39df2..598e3a4f2e 100644 --- a/test/testdata/schema/ghc912/default-config.golden.json +++ b/test/testdata/schema/ghc912/default-config.golden.json @@ -149,6 +149,9 @@ "variableToken": "variable" }, "globalOn": false + }, + "signatureHelp": { + "globalOn": true } }, "sessionLoading": "singleComponent" diff --git a/test/testdata/schema/ghc912/vscode-extension-schema.golden.json b/test/testdata/schema/ghc912/vscode-extension-schema.golden.json index 77d398438e..68f1b4f800 100644 --- a/test/testdata/schema/ghc912/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc912/vscode-extension-schema.golden.json @@ -1036,5 +1036,11 @@ "description": "Enables semanticTokens plugin", "scope": "resource", "type": "boolean" + }, + "haskell.plugin.signatureHelp.globalOn": { + "default": true, + "description": "Enables signatureHelp plugin", + "scope": "resource", + "type": "boolean" } } diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json index 8467b451f1..efe24df3ae 100644 --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -153,6 +153,9 @@ }, "globalOn": false }, + "signatureHelp": { + "globalOn": true + }, "splice": { "globalOn": true }, diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json index 1c0b19eb27..50ed005112 100644 --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -1043,6 +1043,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.signatureHelp.globalOn": { + "default": true, + "description": "Enables signatureHelp plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.splice.globalOn": { "default": true, "description": "Enables splice plugin", diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json index 8467b451f1..efe24df3ae 100644 --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -153,6 +153,9 @@ }, "globalOn": false }, + "signatureHelp": { + "globalOn": true + }, "splice": { "globalOn": true }, diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json index 1c0b19eb27..50ed005112 100644 --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -1043,6 +1043,12 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.signatureHelp.globalOn": { + "default": true, + "description": "Enables signatureHelp plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.splice.globalOn": { "default": true, "description": "Enables splice plugin", From 62fbccf409c01e79ba96dd1dc853cf6d02ca5606 Mon Sep 17 00:00:00 2001 From: Lin Jian Date: Wed, 16 Jul 2025 12:14:27 +0800 Subject: [PATCH 5/5] WIP: add basic tests --- .github/workflows/test.yml | 4 + haskell-language-server.cabal | 27 ++- .../hls-signature-help-plugin/test/Main.hs | 209 ++++++++++++++++++ 3 files changed, 229 insertions(+), 11 deletions(-) create mode 100644 plugins/hls-signature-help-plugin/test/Main.hs diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 984758a310..b2870d3076 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -261,6 +261,10 @@ jobs: name: Compile the plugin-tutorial run: cabal build plugin-tutorial + - if: matrix.test + name: Test hls-signature-help-plugin test suite + run: cabal test hls-signature-help-plugin-tests || cabal test hls-signature-help-plugin-tests + test_post_job: if: always() runs-on: ubuntu-latest diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index b31b02f8c8..eb655a37cc 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -868,17 +868,22 @@ library hls-signature-help-plugin , text --- test-suite hls-signature-help-plugin-tests --- import: defaults, pedantic, test-defaults, warnings --- if !flag(signatureHelp) --- buildable: False --- type: exitcode-stdio-1.0 --- hs-source-dirs: plugins/hls-signature-help-plugin/test --- main-is: Main.hs --- build-depends: --- , haskell-language-server:hls-signature-help-plugin --- , hls-test-utils == 2.11.0.0 --- , hls-plugin-api == 2.11.0.0 +test-suite hls-signature-help-plugin-tests + import: defaults, pedantic, test-defaults, warnings + if !flag(signatureHelp) + buildable: False + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-signature-help-plugin/test + main-is: Main.hs + build-depends: + , ghcide + , haskell-language-server:hls-signature-help-plugin + , hls-test-utils == 2.11.0.0 + , lens + , lsp-types + , text + default-extensions: + OverloadedStrings ----------------------------- -- module name plugin diff --git a/plugins/hls-signature-help-plugin/test/Main.hs b/plugins/hls-signature-help-plugin/test/Main.hs new file mode 100644 index 0000000000..4d7ecc2ee4 --- /dev/null +++ b/plugins/hls-signature-help-plugin/test/Main.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE QuasiQuotes #-} + +import Control.Exception (throw) +import Control.Lens ((^.)) +import Data.Maybe (fromJust) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (PosPrefixInfo)) +import Ide.Plugin.SignatureHelp (descriptor) +import qualified Language.LSP.Protocol.Lens as L +import Test.Hls +import Test.Hls.FileSystem (VirtualFileTree, + directCradle, file, + mkVirtualFileTree, + text) + + +main :: IO () +main = + defaultTestRunner $ + testGroup + "signatureHelp" + [ mkTest + "1 parameter" + [trimming| + f :: Int -> Int + f = _ + x = f 1 + ^^^^^^^^ + |] + [ Nothing, + Nothing, + Nothing, + Nothing, + Nothing, + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)), -- TODO(@linj) or Nothing? + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)), + Nothing -- TODO(@linj) or highlight the last parameter? + ], + mkTest + "2 parameters" + [trimming| + f :: Int -> Int -> Int + f = _ + x = f 1 2 + ^ ^^^ + |] + [ Nothing, + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)), + Nothing, -- TODO(@linj) or highligt the first/second parameter? + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1)) + ], + mkTest + "3 parameters" + [trimming| + f :: Int -> Int -> Int -> Int + f = _ + x = f 1 2 3 + ^ ^ ^ ^ + |] + [ Nothing, + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing, ParameterInformation (InR (19,22)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)), + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing, ParameterInformation (InR (19,22)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1)), + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing, ParameterInformation (InR (19,22)) Nothing]) (Just (InL 2))] (Just 0) (Just (InL 2)) + ], + mkTest + "parentheses" + [trimming| + f :: Int -> Int -> Int + f = _ + x = (f 1) 2 + ^^ ^^^^ + |] + [ Nothing, + Nothing, + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)), + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)), + Nothing, -- TODO(@linj) or the first/second parameter of f + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1)) + ], + mkTest + "newline" + [trimming| + f :: Int -> Int -> Int + f = _ + x = + ( + ^ + f + ^ + 1 + ^ + ) + ^ + 2 + ^ + + ^ + |] + [ Nothing, + Nothing, + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)), + Nothing, + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1)), + Nothing + ], + mkTest + "nested" + [trimming| + f :: Int -> Int -> Int + f = _ + g :: Int -> Int + g = _ + x = f (g 1) 2 + ^^^^ ^^^^ + |] + [ Nothing, + Nothing, + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)), + Nothing, + Just $ SignatureHelp [SignatureInformation "g :: Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)), + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)), + Nothing, -- TODO(@linj) or the first/second parameter of f + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1)) + ], + mkTest + "type constraint" + [trimming| + f :: (Num a) => a -> a -> a + f = _ + x = f 1 2 + ^ ^ ^ + |] + [ Nothing, + Just $ SignatureHelp [SignatureInformation "f :: forall a. Num a => a -> a -> a" Nothing (Just [ParameterInformation (InR (24,25)) Nothing, ParameterInformation (InR (29,30)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)), + Just $ SignatureHelp [SignatureInformation "f :: forall a. Num a => a -> a -> a" Nothing (Just [ParameterInformation (InR (24,25)) Nothing, ParameterInformation (InR (29,30)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1)) + ], + mkTest + "dynamic function" + [trimming| + f :: Int -> Int -> Int + f = _ + g :: Int -> Int -> Int + g = _ + x = (if _ then f else g) 1 2 + ^^ ^^^ ^ ^^^ ^ ^^^^^^^^ + |] + (replicate 18 Nothing), + mkTest + "multi-line type" + [trimming| + f :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + f = _ + x = f 1 + ^ ^ + |] + [ Nothing, + Just $ SignatureHelp [SignatureInformation "f :: Int\n-> Int\n-> Int\n-> Int\n-> Int\n-> Int\n-> Int\n-> Int\n-> Int\n-> Int\n-> Int\n-> Int" Nothing Nothing (Just (InL 0))] (Just 0) (Just (InL 0)) -- TODO(@linj) write the correct ParameterInformation after figuring out how to calculate ranges when newline exists + ], + mkTest + "multi-line type with type constraint" + [trimming| + f :: Num abcdefghijklmn => abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn + f = _ + x = f 1 + ^ ^ + |] + [ Nothing, + Just $ SignatureHelp [SignatureInformation "f :: forall abcdefghijklmn.\nNum abcdefghijklmn =>\nabcdefghijklmn\n-> abcdefghijklmn\n-> abcdefghijklmn\n-> abcdefghijklmn\n-> abcdefghijklmn" Nothing Nothing (Just (InL 0))] (Just 0) (Just (InL 0)) -- TODO(@linj) write the correct ParameterInformation after figuring out how to calculate ranges when newline exists + ] + ] + +mkTest :: TestName -> Text -> [Maybe SignatureHelp] -> TestTree +mkTest name sourceCode expectedSignatureHelps = + parameterisedCursorTest + name + sourceCode + expectedSignatureHelps + getSignatureHelpFromSession + +getSignatureHelpFromSession :: Text -> PosPrefixInfo -> IO (Maybe SignatureHelp) +getSignatureHelpFromSession sourceCode (PosPrefixInfo _ _ _ position) = + let fileName = "A.hs" + plugin = mkPluginTestDescriptor descriptor "signatureHelp" + virtualFileTree = mkVirtualFileTreeWithSingleFile fileName sourceCode + in runSessionWithServerInTmpDir def plugin virtualFileTree $ do + doc <- openDoc fileName "haskell" + getSignatureHelp doc position + +mkVirtualFileTreeWithSingleFile :: FilePath -> Text -> VirtualFileTree +mkVirtualFileTreeWithSingleFile fileName sourceCode = + let testDataDir = "/not-used-dir" + in mkVirtualFileTree + testDataDir + [ directCradle [T.pack fileName], + file fileName (text sourceCode) + ] + +-- TODO(@linj) upstream it to lsp-test +-- | Returns the signature help at the specified position. +getSignatureHelp :: TextDocumentIdentifier -> Position -> Session (Maybe SignatureHelp) +getSignatureHelp doc pos = + let params = SignatureHelpParams doc pos Nothing Nothing + in nullToMaybe . getResponseResult <$> request SMethod_TextDocumentSignatureHelp params + where + getResponseResult rsp = + case rsp ^. L.result of + Right x -> x + Left err -> throw $ UnexpectedResponseError (fromJust $ rsp ^. L.id) err