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 bfa4f40185..eb655a37cc 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -834,6 +834,57 @@ 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 + , hls-plugin-api == 2.11.0.0 + , lsp-types + , 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: + , 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 ----------------------------- @@ -1846,6 +1897,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..8164859392 --- /dev/null +++ b/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module Ide.Plugin.SignatureHelp (descriptor) where + +import Control.Arrow ((>>>)) +import Data.Bifunctor (bimap) +import Data.Function ((&)) +import qualified Data.Map.Strict as M +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 (FastStringCompat, Name, + RealSrcSpan, SDoc, + getSourceNodeIds, + hie_types, + isAnnotationInNodeInfo, + mkRealSrcLoc, + mkRealSrcSpan, ppr, + sourceNodeInfo) +import Development.IDE.GHC.Compat.Util (LexicalFastString (LexicalFastString)) +import GHC.Core.Map.Type (deBruijnize) +import GHC.Data.Maybe (rightToMaybe) +import GHC.Iface.Ext.Types (ContextInfo (Use), + HieAST (nodeChildren, nodeSpan), + HieASTs (getAsts), + IdentifierDetails (identInfo, identType), + nodeType) +import GHC.Iface.Ext.Utils (hieTypeToIface, + recoverFullType, + smallestContainingSatisfying) +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 + results <- 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 [] + Just oldPosition -> do + pure $ + extractInfoFromSmallestContainingFunctionApplicationAst + oldPosition + hieAst + ( \span hieAst -> do + let functionNode = getLeftMostNode hieAst + (functionName, functionTypes) <- getNodeNameAndTypes hieKind functionNode + argumentNumber <- getArgumentNumber span hieAst + Just (functionName, functionTypes, argumentNumber) + ) + case results of + -- TODO(@linj) what does non-singleton list mean? + [(functionName, functionTypes, argumentNumber)] -> + pure $ InL $ mkSignatureHelp (fromIntegral argumentNumber - 1) functionName functionTypes + _ -> pure $ InR Null + +mkSignatureHelp :: UInt -> Name -> [Text] -> SignatureHelp +mkSignatureHelp argumentNumber functionName functionTypes = + SignatureHelp + (mkSignatureInformation argumentNumber functionName <$> functionTypes) + (Just 0) + (Just $ InL argumentNumber) + +mkSignatureInformation :: UInt -> Name -> Text -> SignatureInformation +mkSignatureInformation argumentNumber functionName functionType = + let functionNameLabelPrefix = printOutputable (ppr functionName) <> " :: " + in SignatureInformation + (functionNameLabelPrefix <> functionType) + Nothing + (Just $ mkArguments (fromIntegral $ T.length functionNameLabelPrefix) functionType) + (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 hieAst = case sourceNodeInfo hieAst of + Nothing -> False + Just nodeInfo -> isAnnotationInNodeInfo annotation nodeInfo + +-- 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 + +getNodeNameAndTypes :: forall a. HieKind a -> HieAST a -> Maybe (Name, [Text]) +getNodeNameAndTypes hieKind hieAst = + if nodeHasAnnotation ("HsVar", "HsExpr") hieAst + then case hieAst & getSourceNodeIds & M.filter isUse & M.assocs of + [(identifier, identifierDetails)] -> + case extractName identifier of + Nothing -> Nothing + Just name -> + let mTypeOfName = identType identifierDetails + typesOfNode = case sourceNodeInfo hieAst of + Nothing -> [] + Just nodeInfo -> nodeType nodeInfo + allTypes = case mTypeOfName of + Nothing -> typesOfNode + Just typeOfName -> typeOfName : filter (isDifferentType typeOfName) typesOfNode + in Just (name, prettyType <$> allTypes) + [] -> Nothing + _ -> Nothing -- seems impossible + else Nothing -- TODO(@linj) must function node be HsVar? + where + extractName = rightToMaybe + + isDifferentType :: a -> a -> Bool + isDifferentType type1 type2 = case hieKind of + HieFresh -> deBruijnize type1 /= deBruijnize type2 + HieFromDisk _hieFile -> type1 /= type2 + + -- 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/plugins/hls-signature-help-plugin/test/Main.hs b/plugins/hls-signature-help-plugin/test/Main.hs new file mode 100644 index 0000000000..b18d43b66f --- /dev/null +++ b/plugins/hls-signature-help-plugin/test/Main.hs @@ -0,0 +1,230 @@ +{-# 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, + Nothing, + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)), + Just $ SignatureHelp [SignatureInformation "f :: Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)) + ], + 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)), + 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 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, + 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 "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)), + 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 + "higher-order function" + [trimming| + f :: (Int -> Int) -> Int -> Int + f = _ + x = f (+ 1) 2 + ^ ^ + |] + [ Nothing, + Just $ SignatureHelp [SignatureInformation "f :: (Int -> Int) -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,17)) Nothing, ParameterInformation (InR (21,24)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)) + ], + 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)), SignatureInformation "f :: Integer -> Integer -> Integer" Nothing (Just [ParameterInformation (InR (5,12)) Nothing, ParameterInformation (InR (16,23)) 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)), SignatureInformation "f :: Integer -> Integer -> Integer" Nothing (Just [ParameterInformation (InR (5,12)) Nothing, ParameterInformation (InR (16,23)) Nothing]) (Just (InL 1))] (Just 0) (Just (InL 1)) + ], + mkTest + "type constraint with kind signatures" + [trimming| + x :: IO Bool + x = pure True + ^ ^ + |] + [ Nothing, + Just $ SignatureHelp [SignatureInformation "pure :: forall (f :: Type -> Type) a. Applicative f => a -> f a" Nothing (Just [ParameterInformation (InR (55,56)) Nothing]) (Just (InL 0)), SignatureInformation "pure :: Bool -> IO Bool" Nothing (Just [ParameterInformation (InR (8,12)) Nothing]) (Just (InL 0)), SignatureInformation "pure :: forall a. a -> IO a" Nothing (Just [ParameterInformation (InR (18,19)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)) + ], + 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 (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (13,16)) Nothing, ParameterInformation (InR (21,24)) Nothing, ParameterInformation (InR (29,32)) Nothing, ParameterInformation (InR (37,40)) Nothing, ParameterInformation (InR (45,48)) Nothing, ParameterInformation (InR (53,56)) Nothing, ParameterInformation (InR (61,64)) Nothing, ParameterInformation (InR (69,72)) Nothing, ParameterInformation (InR (77,80)) Nothing, ParameterInformation (InR (85,88)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)) + ], + 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 (Just [ParameterInformation (InR (52,66)) Nothing, ParameterInformation (InR (71,85)) Nothing, ParameterInformation (InR (90,104)) Nothing, ParameterInformation (InR (109,123)) Nothing]) (Just (InL 0)), SignatureInformation "f :: Integer -> Integer -> Integer -> Integer -> Integer" Nothing (Just [ParameterInformation (InR (5,12)) Nothing, ParameterInformation (InR (16,23)) Nothing, ParameterInformation (InR (27,34)) Nothing, ParameterInformation (InR (38,45)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0)) + ] + ] + +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 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") - 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",