Skip to content

Commit 7a02359

Browse files
jian-linjian-lin
committed
WIP: finish signature help plugin MVP
TODO: - handle more cases - add successful and (currently failed) tests - show documentation
1 parent 7a54a1d commit 7a02359

File tree

3 files changed

+191
-68
lines changed

3 files changed

+191
-68
lines changed

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

Lines changed: 1 addition & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -574,8 +574,7 @@ pointCommand hf pos k =
574574
--
575575
-- 'coerce' here to avoid an additional function for maintaining
576576
-- backwards compatibility.
577-
case smallestContainingSatisfying (sp $ coerce fs) isFunction ast of
578-
-- case selectSmallestContaining (sp $ coerce fs) ast of
577+
case selectSmallestContaining (sp $ coerce fs) ast of
579578
Nothing -> Nothing
580579
Just ast' -> Just $ k ast'
581580
where
@@ -584,8 +583,6 @@ pointCommand hf pos k =
584583
line :: UInt
585584
line = _line pos
586585
cha = _character pos
587-
isFunction ast = not $ null $ flip M.mapMaybeWithKey (getSourcedNodeInfo $ sourcedNodeInfo ast) $ \_nodeOrigin (NodeInfo _nodeAnnotations _nodeType _nodeIdentifiers) ->
588-
Just True
589586

590587
-- In ghc9, nodeInfo is monomorphic, so we need a case split here
591588
nodeInfoH :: HieKind a -> HieAST a -> NodeInfo a

‎haskell-language-server.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -861,6 +861,7 @@ library hls-signature-help-plugin
861861
OverloadedStrings
862862
build-depends:
863863
, containers
864+
, ghc
864865
, ghcide == 2.11.0.0
865866
, hashable
866867
, hls-plugin-api == 2.11.0.0

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

Lines changed: 189 additions & 64 deletions
Original file line numberDiff line numberDiff line change
@@ -1,20 +1,62 @@
1-
{-# LANGUAGE DataKinds #-}
2-
{-# LANGUAGE DuplicateRecordFields #-}
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE GADTs #-}
33

44
module Ide.Plugin.SignatureHelp (descriptor) where
55

6-
import Control.Monad.Trans (lift)
7-
import qualified Data.List.NonEmpty as NL
8-
import qualified Data.Text as T
9-
import Development.IDE
10-
import Development.IDE.Core.PluginUtils (runIdeActionE,
11-
useWithStaleFastE)
12-
import Development.IDE.Spans.AtPoint (getNamesAtPoint)
13-
import Ide.Plugin.Error
14-
import Ide.Types
15-
import Language.LSP.Protocol.Message
16-
import Language.LSP.Protocol.Types
17-
import Text.Regex.TDFA ((=~))
6+
import Control.Arrow ((>>>))
7+
import Data.Bifunctor (bimap)
8+
import qualified Data.Map.Strict as M
9+
import Data.Maybe (mapMaybe)
10+
import qualified Data.Set as S
11+
import Data.Text (Text)
12+
import qualified Data.Text as T
13+
import Development.IDE (GetHieAst (GetHieAst),
14+
HieAstResult (HAR, hieAst, hieKind),
15+
HieKind (..),
16+
IdeState (shakeExtras),
17+
Pretty (pretty),
18+
Recorder, WithPriority,
19+
printOutputable)
20+
import Development.IDE.Core.PluginUtils (runIdeActionE,
21+
useWithStaleFastE)
22+
import Development.IDE.Core.PositionMapping (fromCurrentPosition)
23+
import Development.IDE.GHC.Compat (ContextInfo (Use),
24+
FastStringCompat, HieAST,
25+
HieASTs,
26+
IdentifierDetails, Name,
27+
RealSrcSpan, SDoc,
28+
getAsts,
29+
getSourceNodeIds,
30+
hieTypeToIface,
31+
hie_types, identInfo,
32+
identType,
33+
isAnnotationInNodeInfo,
34+
mkRealSrcLoc,
35+
mkRealSrcSpan,
36+
nodeChildren, nodeSpan,
37+
ppr, recoverFullType,
38+
smallestContainingSatisfying,
39+
sourceNodeInfo)
40+
import Development.IDE.GHC.Compat.Util (LexicalFastString (LexicalFastString))
41+
import GHC.Data.Maybe (rightToMaybe)
42+
import GHC.Types.SrcLoc (isRealSubspanOf)
43+
import Ide.Plugin.Error (getNormalizedFilePathE)
44+
import Ide.Types (PluginDescriptor (pluginHandlers),
45+
PluginId,
46+
PluginMethodHandler,
47+
defaultPluginDescriptor,
48+
mkPluginHandler)
49+
import Language.LSP.Protocol.Message (Method (Method_TextDocumentSignatureHelp),
50+
SMethod (SMethod_TextDocumentSignatureHelp))
51+
import Language.LSP.Protocol.Types (Null (Null),
52+
ParameterInformation (ParameterInformation),
53+
Position (Position),
54+
SignatureHelp (SignatureHelp),
55+
SignatureHelpParams (SignatureHelpParams),
56+
SignatureInformation (SignatureInformation),
57+
TextDocumentIdentifier (TextDocumentIdentifier),
58+
UInt,
59+
type (|?) (InL, InR))
1860

1961
data Log = LogDummy
2062

@@ -25,59 +67,142 @@ instance Pretty Log where
2567
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
2668
descriptor _recorder pluginId =
2769
(defaultPluginDescriptor pluginId "Provides signature help of something callable")
28-
{ pluginHandlers = mkPluginHandler SMethod_TextDocumentSignatureHelp signatureHelpProvider
70+
{ Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentSignatureHelp signatureHelpProvider
2971
}
3072

31-
-- get src info
32-
-- function
33-
-- which arg is under the cursor
34-
-- get function type (and arg doc)
35-
-- assemble result
36-
-- TODO(@linj)
73+
-- TODO(@linj) get doc
3774
signatureHelpProvider :: PluginMethodHandler IdeState Method_TextDocumentSignatureHelp
3875
signatureHelpProvider ideState _pluginId (SignatureHelpParams (TextDocumentIdentifier uri) position _mProgreeToken _mContext) = do
3976
nfp <- getNormalizedFilePathE uri
40-
names <- runIdeActionE "signatureHelp" (shakeExtras ideState) $ do
41-
(HAR {hieAst}, positionMapping) <- useWithStaleFastE GetHieAst nfp
42-
let ns = getNamesAtPoint hieAst position positionMapping
43-
pure ns
44-
mRangeAndDoc <-
45-
runIdeActionE
46-
"signatureHelp.getDoc"
47-
(shakeExtras ideState)
48-
(lift (getAtPoint nfp position))
49-
let (_mRange, contents) = case mRangeAndDoc of
50-
Just (mRange, contents) -> (mRange, contents)
51-
Nothing -> (Nothing, [])
52-
53-
pure $
54-
InL $
55-
SignatureHelp
56-
( case mkSignatureHelpLabel names contents of
57-
Just label ->
58-
[ SignatureInformation
59-
label
60-
Nothing
61-
(Just [ParameterInformation (InR (5, 8)) Nothing])
62-
Nothing
63-
]
64-
Nothing -> []
65-
)
66-
(Just 0)
67-
(Just $ InL 0)
77+
mResult <- runIdeActionE "signatureHelp" (shakeExtras ideState) $ do
78+
-- TODO(@linj) why HAR {hieAst} may have more than one AST?
79+
(HAR {hieAst, hieKind}, positionMapping) <- useWithStaleFastE GetHieAst nfp
80+
case fromCurrentPosition positionMapping position of
81+
Nothing -> pure Nothing
82+
Just oldPosition -> do
83+
let functionName =
84+
extractInfoFromSmallestContainingFunctionApplicationAst
85+
oldPosition
86+
hieAst
87+
(\span -> getLeftMostNode >>> getNodeName span)
88+
functionType =
89+
extractInfoFromSmallestContainingFunctionApplicationAst
90+
oldPosition
91+
hieAst
92+
(\span -> getLeftMostNode >>> getNodeType hieKind span)
93+
argumentNumber =
94+
extractInfoFromSmallestContainingFunctionApplicationAst
95+
oldPosition
96+
hieAst
97+
getArgumentNumber
98+
pure $ Just (functionName, functionType, argumentNumber)
99+
case mResult of
100+
-- TODO(@linj) what do non-singleton lists mean?
101+
Just (functionName : _, functionType : _, argumentNumber : _) -> do
102+
pure $ InL $ mkSignatureHelp functionName functionType (fromIntegral argumentNumber - 1)
103+
_ -> pure $ InR Null
104+
105+
mkSignatureHelp :: Name -> Text -> UInt -> SignatureHelp
106+
mkSignatureHelp functionName functionType argumentNumber =
107+
let functionNameLabelPrefix = printOutputable (ppr functionName) <> " :: "
108+
in SignatureHelp
109+
[ SignatureInformation
110+
(functionNameLabelPrefix <> functionType)
111+
Nothing
112+
(Just $ mkArguments (fromIntegral $ T.length functionNameLabelPrefix) functionType)
113+
(Just $ InL argumentNumber)
114+
]
115+
(Just 0)
116+
(Just $ InL argumentNumber)
117+
118+
-- TODO(@linj) can type string be a multi-line string?
119+
mkArguments :: UInt -> Text -> [ParameterInformation]
120+
mkArguments offset functionType =
121+
let separator = " -> "
122+
separatorLength = fromIntegral $ T.length separator
123+
splits = T.breakOnAll separator functionType
124+
prefixes = fst <$> splits
125+
prefixLengths = fmap (T.length >>> fromIntegral) prefixes
126+
ranges =
127+
[ ( if previousPrefixLength == 0 then 0 else previousPrefixLength + separatorLength,
128+
currentPrefixLength
129+
)
130+
| (previousPrefixLength, currentPrefixLength) <- zip (0: prefixLengths) prefixLengths
131+
]
132+
in [ ParameterInformation (InR range) Nothing
133+
| range <- bimap (+offset) (+offset) <$> ranges
134+
]
135+
136+
extractInfoFromSmallestContainingFunctionApplicationAst ::
137+
Position -> HieASTs a -> (RealSrcSpan -> HieAST a -> Maybe b) -> [b]
138+
extractInfoFromSmallestContainingFunctionApplicationAst position hieAsts extractInfo =
139+
M.elems $ flip M.mapMaybeWithKey (getAsts hieAsts) $ \hiePath hieAst ->
140+
smallestContainingSatisfying (positionToSpan hiePath position) (nodeHasAnnotation ("HsApp", "HsExpr")) hieAst
141+
>>= extractInfo (positionToSpan hiePath position)
68142
where
69-
mkSignatureHelpLabel names types =
70-
case (chooseName $ printName <$> names, chooseType types >>= showType) of
71-
(Just name, Just typ) -> Just $ T.pack name <> " :: " <> typ
72-
_ -> Nothing
73-
chooseName names = case names of
74-
[] -> Nothing
75-
name : names' -> Just $ NL.last (name NL.:| names')
76-
chooseType types = case types of
77-
[] -> Nothing
78-
[t] -> Just t
79-
_ -> Just $ types !! (length types - 2)
80-
showType typ = getMatchedType $ typ =~ ("\n```haskell\n(.*) :: (.*)\n```\n" :: T.Text)
81-
getMatchedType :: (T.Text, T.Text, T.Text, [T.Text]) -> Maybe T.Text
82-
getMatchedType (_, _, _, [_, t]) = Just t
83-
getMatchedType _ = Nothing
143+
positionToSpan hiePath position =
144+
let loc = mkLoc hiePath position in mkRealSrcSpan loc loc
145+
mkLoc (LexicalFastString hiePath) (Position line character) =
146+
mkRealSrcLoc hiePath (fromIntegral line + 1) (fromIntegral character + 1)
147+
148+
type Annotation = (FastStringCompat, FastStringCompat)
149+
150+
nodeHasAnnotation :: Annotation -> HieAST a -> Bool
151+
nodeHasAnnotation annotation = sourceNodeInfo >>> maybe False (isAnnotationInNodeInfo annotation)
152+
153+
-- TODO(@linj): the left most node may not be the function node. example: (if True then f else g) x
154+
getLeftMostNode :: HieAST a -> HieAST a
155+
getLeftMostNode thisNode =
156+
case nodeChildren thisNode of
157+
[] -> thisNode
158+
leftChild: _ -> getLeftMostNode leftChild
159+
160+
getNodeName :: RealSrcSpan -> HieAST a -> Maybe Name
161+
getNodeName _span hieAst =
162+
if nodeHasAnnotation ("HsVar", "HsExpr") hieAst
163+
then
164+
case mapMaybe extractName $ M.keys $ M.filter isUse $ getSourceNodeIds hieAst of
165+
[name] -> Just name -- TODO(@linj) will there be more than one name?
166+
_ -> Nothing
167+
else Nothing -- TODO(@linj) must function node be HsVar?
168+
where
169+
extractName = rightToMaybe
170+
171+
-- TODO(@linj) share code with getNodeName
172+
getNodeType :: HieKind a -> RealSrcSpan -> HieAST a -> Maybe Text
173+
getNodeType (hieKind :: HieKind a) _span hieAst =
174+
if nodeHasAnnotation ("HsVar", "HsExpr") hieAst
175+
then
176+
case M.elems $ M.filter isUse $ getSourceNodeIds hieAst of
177+
[identifierDetails] -> identType identifierDetails >>= (prettyType >>> Just)
178+
_ -> Nothing -- TODO(@linj) will there be more than one identifierDetails?
179+
else Nothing
180+
where
181+
-- modified from Development.IDE.Spans.AtPoint.atPoint
182+
prettyType :: a -> Text
183+
prettyType = expandType >>> printOutputable
184+
185+
expandType :: a -> SDoc
186+
expandType t = case hieKind of
187+
HieFresh -> ppr t
188+
HieFromDisk full_file -> ppr $ hieTypeToIface $ recoverFullType t (hie_types full_file)
189+
190+
isUse :: IdentifierDetails a -> Bool
191+
isUse = identInfo >>> S.member Use
192+
193+
-- Just 1 means the first argument
194+
getArgumentNumber :: RealSrcSpan -> HieAST a -> Maybe Integer
195+
getArgumentNumber span hieAst =
196+
if nodeHasAnnotation ("HsApp", "HsExpr") hieAst
197+
then
198+
case nodeChildren hieAst of
199+
[leftChild, _] ->
200+
if span `isRealSubspanOf` nodeSpan leftChild
201+
then Nothing
202+
else getArgumentNumber span leftChild >>= \argumentNumber -> Just (argumentNumber + 1)
203+
_ -> Nothing -- impossible
204+
else
205+
case nodeChildren hieAst of
206+
[] -> Just 0 -- the function is found
207+
[child] -> getArgumentNumber span child -- ignore irrelevant nodes
208+
_ -> Nothing -- TODO(@linj) handle more cases such as `if`

0 commit comments

Comments
 (0)