diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index bfa4f40185..c441289b01 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -834,6 +834,59 @@ 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 + , 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 +-- 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 +1899,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..78219950ad --- /dev/null +++ b/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module Ide.Plugin.SignatureHelp (descriptor) where + +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 + +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") + { Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentSignatureHelp signatureHelpProvider + } + +-- TODO(@linj) get doc +signatureHelpProvider :: PluginMethodHandler IdeState Method_TextDocumentSignatureHelp +signatureHelpProvider ideState _pluginId (SignatureHelpParams (TextDocumentIdentifier uri) position _mProgreeToken _mContext) = do + nfp <- getNormalizedFilePathE uri + 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 + 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` 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") -