Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 9168b74

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

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
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 hieFile -> ppr $ hieTypeToIface $ recoverFullType t (hie_types hieFile)
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)

AltStyle によって変換されたページ (->オリジナル) /