Use structured type and type string to generate signature help

jian-lin · jian-lin · commit 9bea0e37a7a3 · 2025-08-07T16:30:26.000+08:00
See comment for a comparison with alternative methods.
diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/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
diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/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]
diff --git a/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs b/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs
@@ -16,29 +16,29 @@ import           Development.IDE                      (GetHieAst (GetHieAst),
                                                        IdeState (shakeExtras),
                                                        Pretty (pretty),
                                                        Recorder, WithPriority,
-                                                       printOutputable)
+                                                       printOutputableOneLine)
 import           Development.IDE.Core.PluginUtils     (runIdeActionE,
                                                        useWithStaleFastE)
 import           Development.IDE.Core.PositionMapping (fromCurrentPosition)
 import           Development.IDE.GHC.Compat           (FastStringCompat, Name,
-                                                       RealSrcSpan, SDoc,
+                                                       RealSrcSpan,
                                                        getSourceNodeIds,
-                                                       hie_types,
                                                        isAnnotationInNodeInfo,
                                                        mkRealSrcLoc,
                                                        mkRealSrcSpan, ppr,
                                                        sourceNodeInfo)
 import           Development.IDE.GHC.Compat.Util      (LexicalFastString (LexicalFastString))
 import           GHC.Core.Map.Type                    (deBruijnize)
+import           GHC.Core.Type                        (FunTyFlag (FTF_T_T),
+                                                       Type, dropForAlls,
+                                                       splitFunTy_maybe)
 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.Iface.Ext.Utils                  (smallestContainingSatisfying)
 import           GHC.Types.SrcLoc                     (isRealSubspanOf)
 import           Ide.Plugin.Error                     (getNormalizedFilePathE)
 import           Ide.Types                            (PluginDescriptor (pluginHandlers),
@@ -91,44 +91,99 @@ signatureHelpProvider ideState _pluginId (SignatureHelpParams (TextDocumentIdent
                               Just (functionName, functionTypes, argumentNumber)
                         )
     case results of
-        -- TODO(@linj) what does non-singleton list mean?
+        [(_functionName, [], _argumentNumber)] -> pure $ InR Null
         [(functionName, functionTypes, argumentNumber)] ->
             pure $ InL $ mkSignatureHelp (fromIntegral argumentNumber - 1) functionName functionTypes
+        -- TODO(@linj) what does non-singleton list mean?
         _ -> pure $ InR Null
 
-mkSignatureHelp :: UInt -> Name -> [Text] -> SignatureHelp
+mkSignatureHelp :: UInt -> Name -> [Type] -> SignatureHelp
 mkSignatureHelp argumentNumber functionName functionTypes =
     SignatureHelp
         (mkSignatureInformation argumentNumber functionName <$> functionTypes)
         (Just 0)
         (Just $ InL argumentNumber)
 
-mkSignatureInformation :: UInt -> Name -> Text -> SignatureInformation
+mkSignatureInformation :: UInt -> Name -> Type -> SignatureInformation
 mkSignatureInformation argumentNumber functionName functionType =
-    let functionNameLabelPrefix = printOutputable (ppr functionName) <> " :: "
+    let functionNameLabelPrefix = printOutputableOneLine (ppr functionName) <> " :: "
      in SignatureInformation
-            (functionNameLabelPrefix <> functionType)
+            (functionNameLabelPrefix <> printOutputableOneLine 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 :: UInt -> Type -> [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
-        ]
+    [ ParameterInformation (InR range) Nothing
+    | range <- bimap (+offset) (+offset) <$> findArgumentRanges functionType
+    ]
+
+findArgumentRanges :: Type -> [(UInt, UInt)]
+findArgumentRanges functionType =
+    let functionTypeString = printOutputableOneLine functionType
+        functionTypeStringLength = fromIntegral $ T.length functionTypeString
+        splitFunctionTypes = filter notTypeConstraint $ splitFunTysIgnoringForAll functionType
+        splitFunctionTypeStrings = printOutputableOneLine . fst <$> splitFunctionTypes
+        -- reverse to avoid matching "a" of "forall a" in "forall a. a -> a"
+        reversedRanges =
+            drop 1 $ -- do not need the range of the result (last) type
+                findArgumentStringRanges
+                    0
+                    (T.reverse functionTypeString)
+                    (T.reverse <$> reverse splitFunctionTypeStrings)
+     in reverse $ modifyRange functionTypeStringLength <$> reversedRanges
+    where
+        modifyRange functionTypeStringLength (start, end) =
+            (functionTypeStringLength - end, functionTypeStringLength - start)
+
+{-
+The implemented method uses both structured type and unstructured type string.
+It provides good enough results and is easier to implement than alternative
+method 1 or 2.
+
+Alternative method 1: use only structured type
+This method is hard to implement because we need to duplicate some logic of 'ppr' for 'Type'.
+Some tricky cases are as follows:
+- 'Eq a => Num b -> c' is shown as '(Eq a, Numb) => c'
+- 'forall' can appear anywhere in a type when RankNTypes is enabled
+  f :: forall a. Maybe a -> forall b. (a, b) -> b
+- '=>' can appear anywhere in a type
+  g :: forall a b. Eq a => a -> Num b => b -> b
+- ppr the first argument type of '(a -> b) -> a -> b' is 'a -> b' (no parentheses)
+- 'forall' is not always shown
+
+Alternative method 2: use only unstructured type string
+This method is hard to implement because we need to parse the type string.
+Some tricky cases are as follows:
+- h :: forall a (m :: Type -> Type). Monad m => a -> m a
+-}
+findArgumentStringRanges :: UInt -> Text -> [Text] -> [(UInt, UInt)]
+findArgumentStringRanges _totalPrefixLength _functionTypeString [] = []
+findArgumentStringRanges totalPrefixLength functionTypeString (argumentTypeString:restArgumentTypeStrings) =
+    let (prefix, match) = T.breakOn argumentTypeString functionTypeString
+        prefixLength = fromIntegral $ T.length prefix
+        argumentTypeStringLength = fromIntegral $ T.length argumentTypeString
+        start = totalPrefixLength + prefixLength
+     in (start, start + argumentTypeStringLength)
+            : findArgumentStringRanges
+              (totalPrefixLength + prefixLength + argumentTypeStringLength)
+              (T.drop (fromIntegral argumentTypeStringLength) match)
+              restArgumentTypeStrings
+
+-- similar to 'splitFunTys' but
+--   1) the result (last) type is included and
+--   2) toplevel foralls are ignored
+splitFunTysIgnoringForAll :: Type -> [(Type, Maybe FunTyFlag)]
+splitFunTysIgnoringForAll ty = case ty & dropForAlls & splitFunTy_maybe of
+    Just (funTyFlag, _mult, argumentType, resultType) ->
+        (argumentType, Just funTyFlag) : splitFunTysIgnoringForAll resultType
+    Nothing -> [(ty, Nothing)]
+
+notTypeConstraint :: (Type, Maybe FunTyFlag) -> Bool
+notTypeConstraint (_type, Just FTF_T_T) = True
+notTypeConstraint (_type, Nothing)      = True
+notTypeConstraint _                     = False
 
 extractInfoFromSmallestContainingFunctionApplicationAst ::
     Position -> HieASTs a -> (RealSrcSpan -> HieAST a -> Maybe b) -> [b]
@@ -156,7 +211,7 @@ getLeftMostNode thisNode =
         []           -> thisNode
         leftChild: _ -> getLeftMostNode leftChild
 
-getNodeNameAndTypes :: forall a. HieKind a -> HieAST a -> Maybe (Name, [Text])
+getNodeNameAndTypes :: HieKind a -> HieAST a -> Maybe (Name, [Type])
 getNodeNameAndTypes hieKind hieAst =
     if nodeHasAnnotation ("HsVar", "HsExpr") hieAst
         then case hieAst & getSourceNodeIds & M.filter isUse & M.assocs of
@@ -171,26 +226,21 @@ getNodeNameAndTypes hieKind hieAst =
                             allTypes = case mTypeOfName of
                                 Nothing -> typesOfNode
                                 Just typeOfName -> typeOfName : filter (isDifferentType typeOfName) typesOfNode
-                         in Just (name, prettyType <$> allTypes)
+                         in Just (name, filterCoreTypes 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
+            HieFresh       -> deBruijnize type1 /= deBruijnize type2
+            HieFromDisk {} -> type1 /= type2
 
-        expandType :: a -> SDoc
-        expandType t = case hieKind of
-            HieFresh -> ppr t
-            HieFromDisk hieFile -> ppr $ hieTypeToIface $ recoverFullType t (hie_types hieFile)
+        filterCoreTypes types = case hieKind of
+            HieFresh       -> types
+            -- ignore this case since this only happens before we finish startup
+            HieFromDisk {} -> []
 
 isUse :: IdentifierDetails a -> Bool
 isUse = identInfo >>> S.member Use
diff --git a/plugins/hls-signature-help-plugin/test/Main.hs b/plugins/hls-signature-help-plugin/test/Main.hs
@@ -132,7 +132,7 @@ main =
                           ^ ^
                   |]
                   [ 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))
+                    Just $ SignatureHelp [SignatureInformation "f :: (Int -> Int) -> Int -> Int" Nothing (Just [ParameterInformation (InR (6,16)) Nothing, ParameterInformation (InR (21,24)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))
                   ],
               mkTest
                   "type constraint"
@@ -168,26 +168,26 @@ main =
                   |]
                   (replicate 18 Nothing),
               mkTest
-                  "multi-line type"
+                  "very long 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))
+                    Just $ SignatureHelp [SignatureInformation "f :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int" Nothing (Just [ParameterInformation (InR (5,8)) Nothing, ParameterInformation (InR (12,15)) Nothing, ParameterInformation (InR (19,22)) Nothing, ParameterInformation (InR (26,29)) Nothing, ParameterInformation (InR (33,36)) Nothing, ParameterInformation (InR (40,43)) Nothing, ParameterInformation (InR (47,50)) Nothing, ParameterInformation (InR (54,57)) Nothing, ParameterInformation (InR (61,64)) Nothing, ParameterInformation (InR (68,71)) Nothing, ParameterInformation (InR (75,78)) Nothing]) (Just (InL 0))] (Just 0) (Just (InL 0))
                   ],
               mkTest
-                  "multi-line type with type constraint"
+                  "very long 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))
+                    Just $ SignatureHelp [SignatureInformation "f :: forall abcdefghijklmn. Num abcdefghijklmn => abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn" Nothing (Just [ParameterInformation (InR (50,64)) Nothing, ParameterInformation (InR (68,82)) Nothing, ParameterInformation (InR (86,100)) Nothing, ParameterInformation (InR (104,118)) 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))
                   ]
             ]
 
