Skip to content

Commit 9024e6e

Browse files
jetjinserjetjinser
committed
Init inlay hints plugin
Fixity information is now available in the inlay hints plugin
1 parent a2a9991 commit 9024e6e

File tree

8 files changed

+262
-1
lines changed

8 files changed

+262
-1
lines changed

‎haskell-language-server.cabal

Lines changed: 46 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1134,6 +1134,51 @@ test-suite hls-gadt-plugin-tests
11341134
, hls-test-utils == 2.7.0.0
11351135
, text
11361136

1137+
1138+
-----------------------------
1139+
-- inlay hints plugin
1140+
-----------------------------
1141+
1142+
flag inlayHints
1143+
description: Enable inlayHints plugin
1144+
default: True
1145+
manual: True
1146+
1147+
common inlayHints
1148+
if flag(inlayHints)
1149+
build-depends: haskell-language-server:hls-inlay-hints-plugin
1150+
cpp-options: -DinlayHints
1151+
1152+
library hls-inlay-hints-plugin
1153+
import: defaults, pedantic, warnings
1154+
exposed-modules: Ide.Plugin.InlayHints
1155+
hs-source-dirs: plugins/hls-inlay-hints-plugin/src
1156+
build-depends:
1157+
base >=4.12 && <5
1158+
, containers
1159+
, deepseq
1160+
, extra
1161+
, ghcide == 2.7.0.0
1162+
, hashable
1163+
, hls-plugin-api == 2.7.0.0
1164+
, lsp >=2.4
1165+
, transformers
1166+
, text
1167+
1168+
default-extensions: DataKinds
1169+
1170+
test-suite hls-inlay-hints-plugin-tests
1171+
import: defaults, pedantic, test-defaults, warnings
1172+
type: exitcode-stdio-1.0
1173+
hs-source-dirs: plugins/hls-inlay-hints-plugin/test
1174+
main-is: Main.hs
1175+
build-depends:
1176+
, base
1177+
, filepath
1178+
, haskell-language-server:hls-inlay-hints-plugin
1179+
, hls-test-utils == 2.7.0.0
1180+
, text
1181+
11371182
-----------------------------
11381183
-- explicit fixity plugin
11391184
-----------------------------
@@ -1666,6 +1711,7 @@ library
16661711
, refactor
16671712
, overloadedRecordDot
16681713
, semanticTokens
1714+
, inlayHints
16691715

16701716
exposed-modules:
16711717
Ide.Arguments

‎hls-plugin-api/src/Ide/Types.hs

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -539,7 +539,10 @@ instance PluginMethod Request Method_CallHierarchyOutgoingCalls where
539539
<> pluginFeatureEnabled plcCallHierarchyOn pluginDesc conf
540540

541541
instance PluginMethod Request Method_WorkspaceExecuteCommand where
542-
handlesRequest _ _ _ _= HandlesRequest
542+
handlesRequest _ _ _ _ = HandlesRequest
543+
544+
instance PluginMethod Request Method_TextDocumentInlayHint where
545+
handlesRequest _ _ _ _ = HandlesRequest
543546

544547
instance PluginMethod Request (Method_CustomMethod m) where
545548
handlesRequest _ _ _ _ = HandlesRequest
@@ -764,6 +767,9 @@ instance PluginRequestMethod Method_TextDocumentSemanticTokensFull where
764767
instance PluginRequestMethod Method_TextDocumentSemanticTokensFullDelta where
765768
combineResponses _ _ _ _ (x :| _) = x
766769

770+
instance PluginRequestMethod Method_TextDocumentInlayHint where
771+
combineResponses _ _ _ _ (x :| _) = x
772+
767773
takeLefts :: [a |? b] -> [a]
768774
takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x])
769775

‎plugins/hls-inlay-hints-plugin/src/Ide/Plugin/InlayHints.hs

Lines changed: 150 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,150 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE TypeFamilies #-}
4+
5+
{-# OPTIONS_GHC -Wno-orphans #-}
6+
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
7+
8+
module Ide.Plugin.InlayHints(descriptor) where
9+
10+
import Control.DeepSeq (NFData (rnf), rwhnf)
11+
import Control.Monad.IO.Class (MonadIO (liftIO))
12+
import Data.Either (isRight)
13+
import Data.Hashable (Hashable)
14+
import qualified Data.Map.Strict as M
15+
import Data.Maybe (fromMaybe)
16+
import Data.String (IsString (fromString))
17+
import Data.Text (Text)
18+
import Development.IDE (GhcSessionDeps (GhcSessionDeps),
19+
HieAstResult (HAR, refMap),
20+
IdeState,
21+
Position (Position),
22+
Pretty (pretty),
23+
RuleResult, Rules,
24+
TcModuleResult (tmrTypechecked),
25+
TypeCheck (TypeCheck),
26+
cmapWithPrio, define,
27+
hscEnv, printOutputable,
28+
use_)
29+
import Development.IDE.Core.PluginUtils (runActionE,
30+
useWithStaleE)
31+
import Development.IDE.Core.PositionMapping (idDelta)
32+
import Development.IDE.Core.RuleTypes (GetHieAst (GetHieAst))
33+
import Development.IDE.Core.Shake (addPersistentRule)
34+
import qualified Development.IDE.Core.Shake as Shake
35+
import Development.IDE.GHC.Compat (Fixity (Fixity), Name,
36+
TcGblEnv, defaultFixity,
37+
initTcWithGbl,
38+
lookupFixityRn,
39+
mkRealSrcLoc,
40+
realSrcLocSpan,
41+
realSrcSpanEnd,
42+
realSrcSpanStart,
43+
srcLocCol, srcLocLine)
44+
import Development.IDE.GHC.Compat.Core (HscEnv)
45+
import qualified Development.IDE.GHC.Compat.Util as Util
46+
import GHC.Generics (Generic)
47+
import Ide.Logger (Recorder, WithPriority)
48+
import Ide.Plugin.Error (getNormalizedFilePathE)
49+
import Ide.Types (PluginDescriptor (pluginHandlers, pluginRules),
50+
PluginId,
51+
PluginMethodHandler,
52+
defaultPluginDescriptor,
53+
mkPluginHandler)
54+
import Language.LSP.Protocol.Message (Method (Method_TextDocumentInlayHint),
55+
SMethod (SMethod_TextDocumentInlayHint))
56+
import Language.LSP.Protocol.Types (InlayHint (InlayHint),
57+
InlayHintParams (InlayHintParams),
58+
TextDocumentIdentifier (TextDocumentIdentifier),
59+
maybeToNull,
60+
type (|?) (InL))
61+
62+
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
63+
descriptor recorder pluginId = (defaultPluginDescriptor pluginId "Provides Info in Inlay Hints")
64+
{
65+
pluginRules = fixityRule recorder,
66+
pluginHandlers = mkPluginHandler SMethod_TextDocumentInlayHint inlayHint
67+
}
68+
69+
inlayHint :: PluginMethodHandler IdeState Method_TextDocumentInlayHint
70+
inlayHint state _pid (InlayHintParams _ (TextDocumentIdentifier uri) _range) = do
71+
nfp <- getNormalizedFilePathE uri
72+
runActionE "InlayHints" state $ do
73+
(FixityMap fixmap, _) <- useWithStaleE GetFixity nfp
74+
pure $ maybeToNull $ toAbsInlayHints fixmap
75+
where
76+
toAbsInlayHints :: M.Map Position Fixity -> Maybe [InlayHint]
77+
toAbsInlayHints fixmap =
78+
Just (M.elems $ M.mapWithKey (\(Position x y) (Fixity _ pre direction) ->
79+
InlayHint
80+
(Position (x - 1) (y - 1))
81+
(InL (printOutputable direction <> printOutputable pre))
82+
Nothing Nothing Nothing Nothing Nothing Nothing
83+
) fixmap)
84+
85+
newtype Log = LogShake Shake.Log
86+
87+
instance Pretty Log where
88+
pretty = \case
89+
LogShake log -> pretty log
90+
91+
newtype FixityMap = FixityMap (M.Map Position Fixity)
92+
instance Show FixityMap where
93+
show _ = "FixityMap"
94+
95+
instance NFData FixityMap where
96+
rnf (FixityMap xs) = rnf xs
97+
98+
instance NFData Fixity where
99+
rnf = rwhnf
100+
101+
data GetFixity = GetFixity deriving (Show, Eq, Generic)
102+
103+
instance Hashable GetFixity
104+
instance NFData GetFixity
105+
106+
type instance RuleResult GetFixity = FixityMap
107+
108+
fixityRule :: Recorder (WithPriority Log) -> Rules ()
109+
fixityRule recorder = do
110+
define (cmapWithPrio LogShake recorder) $ \GetFixity nfp -> do
111+
HAR{refMap} <- use_ GetHieAst nfp
112+
-- deps necessary so that we can consult already loaded in ifaces instead of loading in duplicates
113+
env <- hscEnv <$> use_ GhcSessionDeps nfp
114+
tcGblEnv <- tmrTypechecked <$> use_ TypeCheck nfp
115+
fs <- lookupFixities env tcGblEnv $
116+
M.mapKeys (\(Right x) -> x)
117+
$ M.filterWithKey (\k _ -> isRight k)
118+
$ M.map
119+
(fmap (
120+
(\loc -> Position (fromIntegral $ srcLocLine loc) (fromIntegral $ srcLocCol loc))
121+
. realSrcSpanEnd
122+
. fst))
123+
refMap
124+
pure ([], Just (FixityMap fs))
125+
126+
-- Ensure that this plugin doesn't block on startup
127+
addPersistentRule GetFixity $ const $ pure $ Just (FixityMap M.empty, idDelta, Nothing)
128+
129+
-- | Convert a HieAST to FixityTree with fixity info gathered
130+
lookupFixities :: MonadIO m => HscEnv -> TcGblEnv -> M.Map Name [Position] -> m (M.Map Position Fixity)
131+
lookupFixities hscEnv tcGblEnv names
132+
= liftIO
133+
$ fmap (fromMaybe M.empty . snd)
134+
$ initTcWithGbl hscEnv tcGblEnv (realSrcLocSpan $ mkRealSrcLoc "<dummy>" 0 0)
135+
$ M.traverseMaybeWithKey (\_ v -> v)
136+
$ M.fromList
137+
$ concat
138+
$ M.elems
139+
$ M.mapWithKey lookupFixity names
140+
where
141+
lookupFixity name positions =
142+
fmap (,fixity) positions
143+
where
144+
fixity = do
145+
f <- Util.handleGhcException
146+
(const $ pure Nothing)
147+
(Just <$> lookupFixityRn name)
148+
if f == Just defaultFixity
149+
then pure Nothing
150+
else pure f

‎plugins/hls-inlay-hints-plugin/test/Main.hs

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
module Main where
2+
3+
main :: IO ()
4+
main = print "ok"

‎plugins/hls-inlay-hints-plugin/test/testdata/Hover.hs

Lines changed: 40 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,40 @@
1+
{-# LANGUAGE RecordWildCards #-}
2+
module Hover where
3+
import Control.Monad
4+
import Data.Function (on)
5+
import Control.Applicative ((<|>))
6+
f1 = (++)
7+
f2 = ($)
8+
f3 = (.)
9+
f4 = (+)
10+
f5 = 1 - 2
11+
f6 = (<>)
12+
f7 = (>>=)
13+
f8 = (>=>)
14+
f9 = elem
15+
f10 = on
16+
f11 = (||)
17+
f12 = mod
18+
f13 = (**)
19+
f14 = (^)
20+
f15 = (<$)
21+
f16 = seq
22+
f17 = (<|>)
23+
24+
infixr 7 >>:
25+
infix 9 >>::
26+
data F = G
27+
{ (>>:) :: Int -> Int -> Int
28+
, c :: Int
29+
, (>>::) :: Char
30+
}
31+
f G{..} = undefined
32+
33+
infixl 1 `f`
34+
35+
infixr 9 >>>:
36+
(>>>:) :: Int -> Int
37+
(>>>:) x = 3
38+
39+
infixl 3 ~\:
40+
(~\:) x y = 3

‎plugins/hls-inlay-hints-plugin/test/testdata/HoverImport.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module HoverImport where
2+
3+
import Hover
4+
5+
g = (>>>:)

‎plugins/hls-inlay-hints-plugin/test/testdata/hie.yaml

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
cradle:
2+
direct:
3+
arguments: []

‎src/HlsPlugins.hs

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -85,6 +85,10 @@ import qualified Ide.Plugin.GADT as GADT
8585
import qualified Ide.Plugin.ExplicitFixity as ExplicitFixity
8686
#endif
8787

88+
#if inlayHints
89+
import qualified Ide.Plugin.InlayHints as InlayHints
90+
#endif
91+
8892
#if explicitFields
8993
import qualified Ide.Plugin.ExplicitFields as ExplicitFields
9094
#endif
@@ -225,6 +229,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins
225229
#if explicitFixity
226230
let pId = "explicit-fixity" in ExplicitFixity.descriptor (pluginRecorder pId) pId :
227231
#endif
232+
#if inlayHints
233+
let pId = "inlay-hints" in InlayHints.descriptor (pluginRecorder pId) pId :
234+
#endif
228235
#if explicitFields
229236
let pId = "explicit-fields" in ExplicitFields.descriptor (pluginRecorder pId) pId :
230237
#endif

0 commit comments

Comments
 (0)