Implement signature help

.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

CODEOWNERS

@@ -38,6 +38,7 @@
 /plugins/hls-rename-plugin
 /plugins/hls-retrie-plugin @wz1000
 /plugins/hls-semantic-tokens-plugin @soulomoon
+/plugins/hls-signature-help-plugin @jian-lin
 /plugins/hls-splice-plugin @konn
 /plugins/hls-stan-plugin @0rphee
 /plugins/hls-stylish-haskell-plugin @michaelpj

docs/features.md

@@ -7,6 +7,7 @@ Many of these are standard LSP features, but a lot of special features are provi
 | --------------------------------------------------- | ------------------------------------------------------------------------------------------------- |
 | [Diagnostics](#diagnostics)                         | `textDocument/publishDiagnostics`                                                                 |
 | [Hovers](#hovers)                                   | `textDocument/hover`                                                                              |
+| [Signature help](#signature-help)                   | `textDocument/signatureHelp`                                                                      |
 | [Jump to definition](#jump-to-definition)           | `textDocument/definition`                                                                         |
 | [Jump to type definition](#jump-to-type-definition) | `textDocument/typeDefinition`                                                                     |
 | [Find references](#find-references)                 | `textDocument/references`                                                                         |
@@ -63,6 +64,12 @@ Provided by: `hls-explicit-fixity-plugin`
 
 Provides fixity information.
 
+## Signature help
+
+Provided by: `hls-signature-help-plugin`
+
+Shows and highlights the function signature, the function documentation and the arguments documentation when the cursor is at a function argument.
+
 ## Jump to definition
 
 Provided by: `ghcide`
@@ -445,7 +452,6 @@ Contributions welcome!
 
 | Feature                | Status            | [LSP method](./what-is-hls.md#lsp-terminology) |
 | ---------------------- | ----------------- | ---------------------------------------------- |
-| Signature help         | Unimplemented     | `textDocument/signatureHelp`                   |
 | Jump to declaration    | Unclear if useful | `textDocument/declaration`                     |
 | Jump to implementation | Unclear if useful | `textDocument/implementation`                  |
 | Linked editing         | Unimplemented     | `textDocument/linkedEditingRange`              |

docs/support/plugin-support.md

@@ -51,6 +51,7 @@ For example, a plugin to provide a formatter which has itself been abandoned has
 | `hls-class-plugin`                   | 2    |                          |
 | `hls-change-type-signature-plugin`   | 2    |                          |
 | `hls-eval-plugin`                    | 2    |                          |
+| `hls-signature-help-plugin`          | 2    |                          |
 | `hls-explicit-fixity-plugin`         | 2    |                          |
 | `hls-explicit-record-fields-plugin`  | 2    |                          |
 | `hls-fourmolu-plugin`                | 2    |                          |

ghcide/src/Development/IDE/Core/Actions.hs

@@ -62,7 +62,7 @@ getAtPoint file pos = runMaybeT $ do
 
   (hf, mapping) <- useWithStaleFastMT GetHieAst file
   env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file
-  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)
+  dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)
 
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
   MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos'

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -249,9 +249,9 @@ type instance RuleResult GetHieAst = HieAstResult
 -- | A IntervalMap telling us what is in scope at each point
 type instance RuleResult GetBindings = Bindings
 
-data DocAndTyThingMap = DKMap {getDocMap :: !DocMap, getTyThingMap :: !TyThingMap}
+data DocAndTyThingMap = DKMap {getDocMap :: !DocMap, getTyThingMap :: !TyThingMap, getArgDocMap :: !ArgDocMap}
 instance NFData DocAndTyThingMap where
-    rnf (DKMap a b) = rwhnf a `seq` rwhnf b
+    rnf (DKMap a b c) = rwhnf a `seq` rwhnf b `seq` rwhnf c
 
 instance Show DocAndTyThingMap where
     show = const "docmap"

ghcide/src/Development/IDE/Core/Rules.hs

@@ -576,7 +576,7 @@
 
 -- | Persistent rule to ensure that hover doesn't block on startup
 persistentDocMapRule :: Rules ()
-persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing)
+persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty mempty, idDelta, Nothing)
 
 readHieFileForSrcFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath -> MaybeT IdeAction Compat.HieFile
 readHieFileForSrcFromDisk recorder file = do
@@ -809,7 +809,7 @@
       hsc_env' <- setFileCacheHook (hscEnv session)
       r <- loadInterface hsc_env' ms linkableType recompInfo
       case r of
         (diags, Nothing) -> return (Nothing, (diags, Nothing))
         (diags, Just x) -> do
           let !fp = Just $! hiFileFingerPrint x
           return (fp, (diags, Just x))

ghcide/src/Development/IDE/GHC/Compat/Outputable.hs

@@ -9,6 +9,7 @@ module Development.IDE.GHC.Compat.Outputable (
     ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate,
     printSDocQualifiedUnsafe,
     printWithoutUniques,
+    printWithoutUniquesOneLine,
     mkPrintUnqualifiedDefault,
     PrintUnqualified,
     defaultUserStyle,
@@ -27,6 +28,7 @@ module Development.IDE.GHC.Compat.Outputable (
     pprMsgEnvelopeBagWithLoc,
     Error.getMessages,
     renderWithContext,
+    showSDocOneLine,
     defaultSDocContext,
     errMsgDiagnostic,
     unDecorated,
@@ -76,8 +78,14 @@ type PrintUnqualified = NamePprCtx
 --
 -- It print with a user-friendly style like: `a_a4ME` as `a`.
 printWithoutUniques :: Outputable a => a -> String
-printWithoutUniques =
-  renderWithContext (defaultSDocContext
+printWithoutUniques = printWithoutUniques' renderWithContext
+
+printWithoutUniquesOneLine :: Outputable a => a -> String
+printWithoutUniquesOneLine = printWithoutUniques' showSDocOneLine
+
+printWithoutUniques' :: Outputable a => (SDocContext -> SDoc -> String) -> a -> String
+printWithoutUniques' showSDoc =
+  showSDoc (defaultSDocContext
     {
       sdocStyle = defaultUserStyle
     , sdocSuppressUniques = True

ghcide/src/Development/IDE/GHC/Util.hs

@@ -27,6 +27,7 @@ module Development.IDE.GHC.Util(
     dontWriteHieFiles,
     disableWarningsAsErrors,
     printOutputable,
+    printOutputableOneLine,
     getExtensions,
     stripOccNamePrefix,
     ) where
@@ -264,11 +265,17 @@ ioe_dupHandlesNotCompatible h =
 --   1. print with a user-friendly style: `a_a4ME` as `a`.
 --   2. unescape escape sequences of printable unicode characters within a pair of double quotes
 printOutputable :: Outputable a => a -> T.Text
-printOutputable =
+printOutputable = printOutputable' printWithoutUniques
+
+printOutputableOneLine :: Outputable a => a -> T.Text
+printOutputableOneLine = printOutputable' printWithoutUniquesOneLine
+
+printOutputable' :: Outputable a => (a -> String) -> a -> T.Text
+printOutputable' print =
     -- IfaceTyLit from GHC.Iface.Type implements Outputable with 'show'.
     -- Showing a String escapes non-ascii printable characters. We unescape it here.
     -- More discussion at https://github.com/haskell/haskell-language-server/issues/3115.
-    unescape . T.pack . printWithoutUniques
+    unescape . T.pack . print
 {-# INLINE printOutputable #-}
 
 getExtensions :: ParsedModule -> [Extension]

ghcide/src/Development/IDE/Plugin/Completions.hs

@@ -132,11 +132,11 @@ resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} ur
     name <- liftIO $ lookupNameCache nc mod occ
     mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file
     let (dm,km) = case mdkm of
-          Just (DKMap docMap tyThingMap, _) -> (docMap,tyThingMap)
-          Nothing                           -> (mempty, mempty)
+          Just (DKMap docMap tyThingMap _argDocMap, _) -> (docMap,tyThingMap)
+          Nothing                                      -> (mempty, mempty)
     doc <- case lookupNameEnv dm name of
       Just doc -> pure $ spanDocToMarkdown doc
-      Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name
+      Nothing -> liftIO $ spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) name
     typ <- case lookupNameEnv km name of
       _ | not needType -> pure Nothing
       Just ty -> pure (safeTyThingType ty)

ghcide/src/Development/IDE/Spans/AtPoint.hs

@@ -239,7 +239,7 @@ atPoint
   -> HscEnv
   -> Position
   -> IO (Maybe (Maybe Range, [T.Text]))
-atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km) env pos =
+atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km _am) env pos =
     listToMaybe <$> sequence (pointCommand hf pos hoverInfo)
   where
     -- Hover info for values/data

ghcide/src/Development/IDE/Spans/Common.hs

@@ -13,6 +13,7 @@ module Development.IDE.Spans.Common (
 , spanDocToMarkdownForTest
 , DocMap
 , TyThingMap
+, ArgDocMap
 , srcSpanToMdLink
 ) where
 
@@ -29,13 +30,15 @@ import           GHC.Generics
 import           System.FilePath
 
 import           Control.Lens
+import           Data.IntMap                  (IntMap)
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Orphans  ()
 import qualified Language.LSP.Protocol.Lens   as JL
 import           Language.LSP.Protocol.Types
 
 type DocMap = NameEnv SpanDoc
 type TyThingMap = NameEnv TyThing
+type ArgDocMap = NameEnv (IntMap SpanDoc)
 
 -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier.
 unqualIEWrapName :: IEWrappedName GhcPs -> T.Text

ghcide/src/Development/IDE/Spans/Documentation.hs

@@ -16,6 +16,7 @@ import           Control.Monad.Extra             (findM)
 import           Control.Monad.IO.Class
 import           Data.Either
 import           Data.Foldable
+import           Data.IntMap                     (IntMap)
 import           Data.List.Extra
 import qualified Data.Map                        as M
 import           Data.Maybe
@@ -41,21 +42,27 @@ mkDocMap
   -> IO DocAndTyThingMap
 mkDocMap env rm this_mod =
   do
-     (Just Docs{docs_decls = UniqMap this_docs}) <- extractDocs (hsc_dflags env) this_mod
+     (Just Docs{docs_decls = UniqMap this_docs, docs_args = UniqMap this_arg_docs}) <- extractDocs (hsc_dflags env) this_mod
      d <- foldrM getDocs (fmap (\(_, x) -> (map hsDocString x) `SpanDocString` SpanDocUris Nothing Nothing) this_docs) names
      k <- foldrM getType (tcg_type_env this_mod) names
-     pure $ DKMap d k
+     a <- foldrM getArgDocs (fmap (\(_, m) -> fmap (\x -> [hsDocString x] `SpanDocString` SpanDocUris Nothing Nothing) m) this_arg_docs) names
+     pure $ DKMap d k a
   where
     getDocs n nameMap
       | maybe True (mod ==) $ nameModule_maybe n = pure nameMap -- we already have the docs in this_docs, or they do not exist
       | otherwise = do
-      doc <- getDocumentationTryGhc env n
+      (doc, _argDoc) <- getDocumentationTryGhc env n
       pure $ extendNameEnv nameMap n doc
     getType n nameMap
       | Nothing <- lookupNameEnv nameMap n
       = do kind <- lookupKind env n
            pure $ maybe nameMap (extendNameEnv nameMap n) kind
       | otherwise = pure nameMap
+    getArgDocs n nameMap
+      | maybe True (mod ==) $ nameModule_maybe n = pure nameMap
+      | otherwise = do
+      (_doc, argDoc) <- getDocumentationTryGhc env n
+      pure $ extendNameEnv nameMap n argDoc
     names = rights $ S.toList idents
     idents = M.keysSet rm
     mod = tcg_mod this_mod
@@ -64,23 +71,23 @@ lookupKind :: HscEnv -> Name -> IO (Maybe TyThing)
 lookupKind env =
     fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env
 
-getDocumentationTryGhc :: HscEnv -> Name -> IO SpanDoc
+getDocumentationTryGhc :: HscEnv -> Name -> IO (SpanDoc, IntMap SpanDoc)
 getDocumentationTryGhc env n =
-  (fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env [n])
-    `catch` (\(_ :: IOEnvFailure) -> pure emptySpanDoc)
+  (fromMaybe (emptySpanDoc, mempty) . listToMaybe <$> getDocumentationsTryGhc env [n])
+    `catch` (\(_ :: IOEnvFailure) -> pure (emptySpanDoc, mempty))
 
-getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [SpanDoc]
+getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)]
 getDocumentationsTryGhc env names = do
   resOr <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names
   case resOr of
       Left _    -> return []
       Right res -> zipWithM unwrap res names
   where
-    unwrap (Right (Just docs, _)) n = SpanDocString (map hsDocString docs) <$> getUris n
+    unwrap (Right (Just docs, argDocs)) n = (\uris -> (SpanDocString (map hsDocString docs) uris, fmap (\x -> SpanDocString [hsDocString x] uris) argDocs)) <$> getUris n
     unwrap _ n                      = mkSpanDocText n
 
     mkSpanDocText name =
-      SpanDocText [] <$> getUris name
+      (\uris -> (SpanDocText [] uris, mempty)) <$> getUris name
 
     -- Get the uris to the documentation and source html pages if they exist
     getUris name = do

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
+    , hls-plugin-api        == 2.11.0.0
+    , lsp-types
+    , text
+    , transformers
+
+
+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
+    , regex-tdfa
+    , text
+  default-extensions:
+    OverloadedStrings
+
 -----------------------------
 -- module name plugin
 -----------------------------
@@ -1846,6 +1899,7 @@ library
                   , retrie
                   , hlint
                   , stan
+                  , signatureHelp
                   , moduleName
                   , pragmas
                   , splice

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

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]