Skip to content

Commit 9bea0e3

Browse files
jian-linjian-lin
committed
Use structured type and type string to generate signature help
See comment for a comparison with alternative methods.
1 parent faa4e48 commit 9bea0e3

File tree

4 files changed

+114
-49
lines changed

4 files changed

+114
-49
lines changed

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

Lines changed: 10 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ module Development.IDE.GHC.Compat.Outputable (
99
ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate,
1010
printSDocQualifiedUnsafe,
1111
printWithoutUniques,
12+
printWithoutUniquesOneLine,
1213
mkPrintUnqualifiedDefault,
1314
PrintUnqualified,
1415
defaultUserStyle,
@@ -27,6 +28,7 @@ module Development.IDE.GHC.Compat.Outputable (
2728
pprMsgEnvelopeBagWithLoc,
2829
Error.getMessages,
2930
renderWithContext,
31+
showSDocOneLine,
3032
defaultSDocContext,
3133
errMsgDiagnostic,
3234
unDecorated,
@@ -76,8 +78,14 @@ type PrintUnqualified = NamePprCtx
7678
--
7779
-- It print with a user-friendly style like: `a_a4ME` as `a`.
7880
printWithoutUniques :: Outputable a => a -> String
79-
printWithoutUniques =
80-
renderWithContext (defaultSDocContext
81+
printWithoutUniques = printWithoutUniques' renderWithContext
82+
83+
printWithoutUniquesOneLine :: Outputable a => a -> String
84+
printWithoutUniquesOneLine = printWithoutUniques' showSDocOneLine
85+
86+
printWithoutUniques' :: Outputable a => (SDocContext -> SDoc -> String) -> a -> String
87+
printWithoutUniques' showSDoc =
88+
showSDoc (defaultSDocContext
8189
{
8290
sdocStyle = defaultUserStyle
8391
, sdocSuppressUniques = True

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

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ module Development.IDE.GHC.Util(
2727
dontWriteHieFiles,
2828
disableWarningsAsErrors,
2929
printOutputable,
30+
printOutputableOneLine,
3031
getExtensions,
3132
stripOccNamePrefix,
3233
) where
@@ -264,11 +265,17 @@ ioe_dupHandlesNotCompatible h =
264265
-- 1. print with a user-friendly style: `a_a4ME` as `a`.
265266
-- 2. unescape escape sequences of printable unicode characters within a pair of double quotes
266267
printOutputable :: Outputable a => a -> T.Text
267-
printOutputable =
268+
printOutputable = printOutputable' printWithoutUniques
269+
270+
printOutputableOneLine :: Outputable a => a -> T.Text
271+
printOutputableOneLine = printOutputable' printWithoutUniquesOneLine
272+
273+
printOutputable' :: Outputable a => (a -> String) -> a -> T.Text
274+
printOutputable' print =
268275
-- IfaceTyLit from GHC.Iface.Type implements Outputable with 'show'.
269276
-- Showing a String escapes non-ascii printable characters. We unescape it here.
270277
-- More discussion at https://github.com/haskell/haskell-language-server/issues/3115.
271-
unescape . T.pack . printWithoutUniques
278+
unescape . T.pack . print
272279
{-# INLINE printOutputable #-}
273280

274281
getExtensions :: ParsedModule -> [Extension]

‎plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs

Lines changed: 90 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -16,29 +16,29 @@ import Development.IDE (GetHieAst (GetHieAst),
1616
IdeState (shakeExtras),
1717
Pretty (pretty),
1818
Recorder, WithPriority,
19-
printOutputable)
19+
printOutputableOneLine)
2020
import Development.IDE.Core.PluginUtils (runIdeActionE,
2121
useWithStaleFastE)
2222
import Development.IDE.Core.PositionMapping (fromCurrentPosition)
2323
import Development.IDE.GHC.Compat (FastStringCompat, Name,
24-
RealSrcSpan, SDoc,
24+
RealSrcSpan,
2525
getSourceNodeIds,
26-
hie_types,
2726
isAnnotationInNodeInfo,
2827
mkRealSrcLoc,
2928
mkRealSrcSpan, ppr,
3029
sourceNodeInfo)
3130
import Development.IDE.GHC.Compat.Util (LexicalFastString (LexicalFastString))
3231
import GHC.Core.Map.Type (deBruijnize)
32+
import GHC.Core.Type (FunTyFlag (FTF_T_T),
33+
Type, dropForAlls,
34+
splitFunTy_maybe)
3335
import GHC.Data.Maybe (rightToMaybe)
3436
import GHC.Iface.Ext.Types (ContextInfo (Use),
3537
HieAST (nodeChildren, nodeSpan),
3638
HieASTs (getAsts),
3739
IdentifierDetails (identInfo, identType),
3840
nodeType)
39-
import GHC.Iface.Ext.Utils (hieTypeToIface,
40-
recoverFullType,
41-
smallestContainingSatisfying)
41+
import GHC.Iface.Ext.Utils (smallestContainingSatisfying)
4242
import GHC.Types.SrcLoc (isRealSubspanOf)
4343
import Ide.Plugin.Error (getNormalizedFilePathE)
4444
import Ide.Types (PluginDescriptor (pluginHandlers),
@@ -91,44 +91,99 @@ signatureHelpProvider ideState _pluginId (SignatureHelpParams (TextDocumentIdent
9191
Just (functionName, functionTypes, argumentNumber)
9292
)
9393
case results of
94-
-- TODO(@linj) what does non-singleton list mean?
94+
[(_functionName, [], _argumentNumber)] -> pure $ InR Null
9595
[(functionName, functionTypes, argumentNumber)] ->
9696
pure $ InL $ mkSignatureHelp (fromIntegral argumentNumber - 1) functionName functionTypes
97+
-- TODO(@linj) what does non-singleton list mean?
9798
_ -> pure $ InR Null
9899

99-
mkSignatureHelp :: UInt -> Name -> [Text] -> SignatureHelp
100+
mkSignatureHelp :: UInt -> Name -> [Type] -> SignatureHelp
100101
mkSignatureHelp argumentNumber functionName functionTypes =
101102
SignatureHelp
102103
(mkSignatureInformation argumentNumber functionName <$> functionTypes)
103104
(Just 0)
104105
(Just $ InL argumentNumber)
105106

106-
mkSignatureInformation :: UInt -> Name -> Text -> SignatureInformation
107+
mkSignatureInformation :: UInt -> Name -> Type -> SignatureInformation
107108
mkSignatureInformation argumentNumber functionName functionType =
108-
let functionNameLabelPrefix = printOutputable (ppr functionName) <> " :: "
109+
let functionNameLabelPrefix = printOutputableOneLine (ppr functionName) <> " :: "
109110
in SignatureInformation
110-
(functionNameLabelPrefix <> functionType)
111+
(functionNameLabelPrefix <> printOutputableOneLine functionType)
111112
Nothing
112113
(Just $ mkArguments (fromIntegral $ T.length functionNameLabelPrefix) functionType)
113114
(Just $ InL argumentNumber)
114115

115-
-- TODO(@linj) can type string be a multi-line string?
116-
mkArguments :: UInt -> Text -> [ParameterInformation]
116+
mkArguments :: UInt -> Type -> [ParameterInformation]
117117
mkArguments offset functionType =
118-
let separator = " -> "
119-
separatorLength = fromIntegral $ T.length separator
120-
splits = T.breakOnAll separator functionType
121-
prefixes = fst <$> splits
122-
prefixLengths = fmap (T.length >>> fromIntegral) prefixes
123-
ranges =
124-
[ ( if previousPrefixLength == 0 then 0 else previousPrefixLength + separatorLength,
125-
currentPrefixLength
126-
)
127-
| (previousPrefixLength, currentPrefixLength) <- zip (0: prefixLengths) prefixLengths
128-
]
129-
in [ ParameterInformation (InR range) Nothing
130-
| range <- bimap (+offset) (+offset) <$> ranges
131-
]
118+
[ ParameterInformation (InR range) Nothing
119+
| range <- bimap (+offset) (+offset) <$> findArgumentRanges functionType
120+
]
121+
122+
findArgumentRanges :: Type -> [(UInt, UInt)]
123+
findArgumentRanges functionType =
124+
let functionTypeString = printOutputableOneLine functionType
125+
functionTypeStringLength = fromIntegral $ T.length functionTypeString
126+
splitFunctionTypes = filter notTypeConstraint $ splitFunTysIgnoringForAll functionType
127+
splitFunctionTypeStrings = printOutputableOneLine . fst <$> splitFunctionTypes
128+
-- reverse to avoid matching "a" of "forall a" in "forall a. a -> a"
129+
reversedRanges =
130+
drop 1 $ -- do not need the range of the result (last) type
131+
findArgumentStringRanges
132+
0
133+
(T.reverse functionTypeString)
134+
(T.reverse <$> reverse splitFunctionTypeStrings)
135+
in reverse $ modifyRange functionTypeStringLength <$> reversedRanges
136+
where
137+
modifyRange functionTypeStringLength (start, end) =
138+
(functionTypeStringLength - end, functionTypeStringLength - start)
139+
140+
{-
141+
The implemented method uses both structured type and unstructured type string.
142+
It provides good enough results and is easier to implement than alternative
143+
method 1 or 2.
144+
145+
Alternative method 1: use only structured type
146+
This method is hard to implement because we need to duplicate some logic of 'ppr' for 'Type'.
147+
Some tricky cases are as follows:
148+
- 'Eq a => Num b -> c' is shown as '(Eq a, Numb) => c'
149+
- 'forall' can appear anywhere in a type when RankNTypes is enabled
150+
f :: forall a. Maybe a -> forall b. (a, b) -> b
151+
- '=>' can appear anywhere in a type
152+
g :: forall a b. Eq a => a -> Num b => b -> b
153+
- ppr the first argument type of '(a -> b) -> a -> b' is 'a -> b' (no parentheses)
154+
- 'forall' is not always shown
155+
156+
Alternative method 2: use only unstructured type string
157+
This method is hard to implement because we need to parse the type string.
158+
Some tricky cases are as follows:
159+
- h :: forall a (m :: Type -> Type). Monad m => a -> m a
160+
-}
161+
findArgumentStringRanges :: UInt -> Text -> [Text] -> [(UInt, UInt)]
162+
findArgumentStringRanges _totalPrefixLength _functionTypeString [] = []
163+
findArgumentStringRanges totalPrefixLength functionTypeString (argumentTypeString:restArgumentTypeStrings) =
164+
let (prefix, match) = T.breakOn argumentTypeString functionTypeString
165+
prefixLength = fromIntegral $ T.length prefix
166+
argumentTypeStringLength = fromIntegral $ T.length argumentTypeString
167+
start = totalPrefixLength + prefixLength
168+
in (start, start + argumentTypeStringLength)
169+
: findArgumentStringRanges
170+
(totalPrefixLength + prefixLength + argumentTypeStringLength)
171+
(T.drop (fromIntegral argumentTypeStringLength) match)
172+
restArgumentTypeStrings
173+
174+
-- similar to 'splitFunTys' but
175+
-- 1) the result (last) type is included and
176+
-- 2) toplevel foralls are ignored
177+
splitFunTysIgnoringForAll :: Type -> [(Type, Maybe FunTyFlag)]
178+
splitFunTysIgnoringForAll ty = case ty & dropForAlls & splitFunTy_maybe of
179+
Just (funTyFlag, _mult, argumentType, resultType) ->
180+
(argumentType, Just funTyFlag) : splitFunTysIgnoringForAll resultType
181+
Nothing -> [(ty, Nothing)]
182+
183+
notTypeConstraint :: (Type, Maybe FunTyFlag) -> Bool
184+
notTypeConstraint (_type, Just FTF_T_T) = True
185+
notTypeConstraint (_type, Nothing) = True
186+
notTypeConstraint _ = False
132187

133188
extractInfoFromSmallestContainingFunctionApplicationAst ::
134189
Position -> HieASTs a -> (RealSrcSpan -> HieAST a -> Maybe b) -> [b]
@@ -156,7 +211,7 @@ getLeftMostNode thisNode =
156211
[] -> thisNode
157212
leftChild: _ -> getLeftMostNode leftChild
158213

159-
getNodeNameAndTypes :: forall a. HieKind a -> HieAST a -> Maybe (Name, [Text])
214+
getNodeNameAndTypes :: HieKind a -> HieAST a -> Maybe (Name, [Type])
160215
getNodeNameAndTypes hieKind hieAst =
161216
if nodeHasAnnotation ("HsVar", "HsExpr") hieAst
162217
then case hieAst & getSourceNodeIds & M.filter isUse & M.assocs of
@@ -171,26 +226,21 @@ getNodeNameAndTypes hieKind hieAst =
171226
allTypes = case mTypeOfName of
172227
Nothing -> typesOfNode
173228
Just typeOfName -> typeOfName : filter (isDifferentType typeOfName) typesOfNode
174-
in Just (name, prettyType <$> allTypes)
229+
in Just (name, filterCoreTypes allTypes)
175230
[] -> Nothing
176231
_ -> Nothing -- seems impossible
177232
else Nothing -- TODO(@linj) must function node be HsVar?
178233
where
179234
extractName = rightToMaybe
180235

181-
isDifferentType :: a -> a -> Bool
182236
isDifferentType type1 type2 = case hieKind of
183-
HieFresh -> deBruijnize type1 /= deBruijnize type2
184-
HieFromDisk _hieFile -> type1 /= type2
185-
186-
-- modified from Development.IDE.Spans.AtPoint.atPoint
187-
prettyType :: a -> Text
188-
prettyType = expandType >>> printOutputable
237+
HieFresh -> deBruijnize type1 /= deBruijnize type2
238+
HieFromDisk {} -> type1 /= type2
189239

190-
expandType :: a -> SDoc
191-
expandType t = case hieKind of
192-
HieFresh -> ppr t
193-
HieFromDisk hieFile -> ppr $ hieTypeToIface $ recoverFullType t (hie_types hieFile)
240+
filterCoreTypes types = case hieKind of
241+
HieFresh -> types
242+
-- ignore this case since this only happens before we finish startup
243+
HieFromDisk {} -> []
194244

195245
isUse :: IdentifierDetails a -> Bool
196246
isUse = identInfo >>> S.member Use

‎plugins/hls-signature-help-plugin/test/Main.hs

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -132,7 +132,7 @@ main =
132132
^ ^
133133
|]
134134
[ Nothing,
135-
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))
135+
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))
136136
],
137137
mkTest
138138
"type constraint"
@@ -168,26 +168,26 @@ main =
168168
|]
169169
(replicate 18 Nothing),
170170
mkTest
171-
"multi-line type"
171+
"very long type"
172172
[trimming|
173173
f :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
174174
f = _
175175
x = f 1
176176
^ ^
177177
|]
178178
[ Nothing,
179-
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))
179+
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))
180180
],
181181
mkTest
182-
"multi-line type with type constraint"
182+
"very long type with type constraint"
183183
[trimming|
184184
f :: Num abcdefghijklmn => abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn -> abcdefghijklmn
185185
f = _
186186
x = f 1
187187
^ ^
188188
|]
189189
[ Nothing,
190-
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))
190+
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))
191191
]
192192
]
193193

0 commit comments

Comments
 (0)