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") -