Skip to content

Commit 41ebd2e

Browse files
isovectorisovector
committed
Pull LSP-specific stuff out of the main module
1 parent c71b3f7 commit 41ebd2e

File tree

2 files changed

+183
-150
lines changed

2 files changed

+183
-150
lines changed

‎plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs

Lines changed: 6 additions & 150 deletions
Original file line numberDiff line numberDiff line change
@@ -14,53 +14,37 @@ module Ide.Plugin.Tactic
1414
) where
1515

1616
import Bag (listToBag, bagToList)
17-
import Control.Arrow
1817
import Control.Monad
1918
import Control.Monad.Trans
2019
import Control.Monad.Trans.Maybe
2120
import Data.Aeson
2221
import Data.Bool (bool)
23-
import Data.Coerce
2422
import Data.Data (Data)
25-
import Data.Functor ((<&>))
2623
import Data.Generics.Aliases (mkQ)
2724
import Data.Generics.Schemes (everything)
28-
import Data.Map (Map)
29-
import qualified Data.Map as M
3025
import Data.Maybe
3126
import Data.Monoid
32-
import qualified Data.Set as S
3327
import qualified Data.Text as T
3428
import Data.Traversable
35-
import Development.IDE.Core.PositionMapping
36-
import Development.IDE.Core.RuleTypes
37-
import Development.IDE.Core.Service (runAction)
38-
import Development.IDE.Core.Shake (useWithStale, IdeState (..))
29+
import Development.IDE.Core.Shake (IdeState (..))
3930
import Development.IDE.GHC.Compat
40-
import Development.IDE.GHC.Error (realSrcSpanToRange)
4131
import Development.IDE.GHC.ExactPrint
42-
import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings)
43-
import Development.Shake (RuleResult, Action)
44-
import qualified FastString
32+
import Development.Shake.Classes
4533
import Ide.Plugin.Tactic.CaseSplit
46-
import Ide.Plugin.Tactic.Context
4734
import Ide.Plugin.Tactic.GHC
48-
import Ide.Plugin.Tactic.Judgements
35+
import Ide.Plugin.Tactic.LanguageServer
4936
import Ide.Plugin.Tactic.LanguageServer.TacticProviders
5037
import Ide.Plugin.Tactic.Range
5138
import Ide.Plugin.Tactic.Tactics
5239
import Ide.Plugin.Tactic.TestTypes
5340
import Ide.Plugin.Tactic.Types
5441
import Ide.Types
5542
import Language.LSP.Server
56-
import Language.LSP.Types.Capabilities
5743
import Language.LSP.Types
44+
import Language.LSP.Types.Capabilities
5845
import OccName
5946
import Prelude hiding (span)
60-
import SrcLoc (containsSpan)
6147
import System.Timeout
62-
import TcRnTypes (tcg_binds)
63-
import Development.Shake.Classes
6448

6549

6650
descriptor :: PluginId -> PluginDescriptor IdeState
@@ -86,20 +70,6 @@ tcCommandName :: TacticCommand -> T.Text
8670
tcCommandName = T.pack . show
8771

8872

89-
runIde :: IdeState -> Action a -> IO a
90-
runIde state = runAction "tactic" state
91-
92-
runStaleIde
93-
:: forall a r
94-
. ( r ~ RuleResult a
95-
, Eq a , Hashable a , Binary a , Show a , Typeable a , NFData a
96-
, Show r, Typeable r, NFData r
97-
)
98-
=> IdeState
99-
-> NormalizedFilePath
100-
-> a
101-
-> MaybeT IO (r, PositionMapping)
102-
runStaleIde state nfp a = MaybeT $ runIde state $ useWithStale a nfp
10373

10474

10575
codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
@@ -119,90 +89,6 @@ codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri)
11989
codeActionProvider _ _ _ = pure $ Right $ List []
12090

12191

122-
123-
------------------------------------------------------------------------------
124-
-- | Find the last typechecked module, and find the most specific span, as well
125-
-- as the judgement at the given range.
126-
judgementForHole
127-
:: IdeState
128-
-> NormalizedFilePath
129-
-> Range
130-
-> MaybeT IO (Range, Judgement, Context, DynFlags)
131-
judgementForHole state nfp range = do
132-
(asts, amapping) <- runStaleIde state nfp GetHieAst
133-
case asts of
134-
HAR _ _ _ _ (HieFromDisk _) -> fail "Need a fresh hie file"
135-
HAR _ hf _ _ HieFresh -> do
136-
(binds, _) <- runStaleIde state nfp GetBindings
137-
(tcmod, _) <- runStaleIde state nfp TypeCheck
138-
(rss, g) <- liftMaybe $ getSpanAndTypeAtHole amapping range hf
139-
resulting_range <- liftMaybe $ toCurrentRange amapping $ realSrcSpanToRange rss
140-
let (jdg, ctx) = mkJudgementAndContext g binds rss tcmod
141-
dflags <- getIdeDynflags state nfp
142-
pure (resulting_range, jdg, ctx, dflags)
143-
144-
145-
getIdeDynflags
146-
:: IdeState
147-
-> NormalizedFilePath
148-
-> MaybeT IO DynFlags
149-
getIdeDynflags state nfp = do
150-
-- Ok to use the stale 'ModIface', since all we need is its 'DynFlags'
151-
-- which don't change very often.
152-
((modsum,_), _) <- runStaleIde state nfp GetModSummaryWithoutTimestamps
153-
pure $ ms_hspp_opts modsum
154-
155-
156-
getSpanAndTypeAtHole
157-
:: PositionMapping
158-
-> Range
159-
-> HieASTs b
160-
-> Maybe (Span, b)
161-
getSpanAndTypeAtHole amapping range hf = do
162-
range' <- fromCurrentRange amapping range
163-
join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast ->
164-
case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range') ast of
165-
Nothing -> Nothing
166-
Just ast' -> do
167-
let info = nodeInfo ast'
168-
ty <- listToMaybe $ nodeType info
169-
guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info
170-
pure (nodeSpan ast', ty)
171-
172-
173-
mkJudgementAndContext
174-
:: Type
175-
-> Bindings
176-
-> RealSrcSpan
177-
-> TcModuleResult
178-
-> (Judgement, Context)
179-
mkJudgementAndContext g binds rss tcmod = do
180-
let tcg = tmrTypechecked tcmod
181-
tcs = tcg_binds tcg
182-
ctx = mkContext
183-
(mapMaybe (sequenceA . (occName *** coerce))
184-
$ getDefiningBindings binds rss)
185-
tcg
186-
top_provs = getRhsPosVals rss tcs
187-
local_hy = spliceProvenance top_provs
188-
$ hypothesisFromBindings rss binds
189-
cls_hy = contextMethodHypothesis ctx
190-
in ( mkFirstJudgement
191-
(local_hy <> cls_hy)
192-
(isRhsHole rss tcs)
193-
g
194-
, ctx
195-
)
196-
197-
spliceProvenance
198-
:: Map OccName Provenance
199-
-> Hypothesis a
200-
-> Hypothesis a
201-
spliceProvenance provs x =
202-
Hypothesis $ flip fmap (unHypothesis x) $ \hi ->
203-
overProvenance (maybe id const $ M.lookup (hi_name hi) provs) hi
204-
205-
20692
tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams
20793
tacticCmd tac state (TacticParams uri range var_name)
20894
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
@@ -355,46 +241,16 @@ fromMaybeT :: Functor m => a -> MaybeT m a -> m a
355241
fromMaybeT def = fmap (fromMaybe def) . runMaybeT
356242

357243

358-
liftMaybe :: Monad m => Maybe a -> MaybeT m a
359-
liftMaybe a = MaybeT $ pure a
360244

361245

362-
------------------------------------------------------------------------------
363-
-- | Is this hole immediately to the right of an equals sign?
364-
isRhsHole :: RealSrcSpan -> TypecheckedSource -> Bool
365-
isRhsHole rss tcs = everything (||) (mkQ False $ \case
366-
TopLevelRHS _ _ (L (RealSrcSpan span) _) -> containsSpan rss span
367-
_ -> False
368-
) tcs
369-
370-
371-
------------------------------------------------------------------------------
372-
-- | Compute top-level position vals of a function
373-
getRhsPosVals :: RealSrcSpan -> TypecheckedSource -> Map OccName Provenance
374-
getRhsPosVals rss tcs
375-
= M.fromList
376-
$ join
377-
$ maybeToList
378-
$ getFirst
379-
$ everything (<>) (mkQ mempty $ \case
380-
TopLevelRHS name ps
381-
(L (RealSrcSpan span) -- body with no guards and a single defn
382-
(HsVar _ (L _ hole)))
383-
| containsSpan rss span -- which contains our span
384-
, isHole $ occName hole -- and the span is a hole
385-
-> First $ do
386-
patnames <- traverse getPatName ps
387-
pure $ zip patnames $ [0..] <&> TopLevelArgPrv name
388-
_ -> mempty
389-
) tcs
390-
391246

392247
locateBiggest :: (Data r, Data a) => SrcSpan -> a -> Maybe r
393248
locateBiggest ss x = getFirst $ everything (<>)
394249
( mkQ mempty $ \case
395250
L span r | ss `isSubspanOf` span -> pure r
396251
_ -> mempty
397-
)x
252+
) x
253+
398254

399255
locateFirst :: (Data r, Data a) => a -> Maybe r
400256
locateFirst x = getFirst $ everything (<>)

‎plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs

Lines changed: 177 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,177 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE LambdaCase #-}
3+
{-# LANGUAGE OverloadedStrings #-}
4+
{-# LANGUAGE ScopedTypeVariables #-}
5+
6+
module Ide.Plugin.Tactic.LanguageServer where
7+
8+
import Control.Arrow
9+
import Control.Monad
10+
import Control.Monad.Trans.Maybe
11+
import Data.Coerce
12+
import Data.Functor ((<&>))
13+
import Data.Generics.Aliases (mkQ)
14+
import Data.Generics.Schemes (everything)
15+
import Data.Map (Map)
16+
import qualified Data.Map as M
17+
import Data.Maybe
18+
import Data.Monoid
19+
import qualified Data.Set as S
20+
import Data.Traversable
21+
import Development.IDE.Core.PositionMapping
22+
import Development.IDE.Core.RuleTypes
23+
import Development.IDE.Core.Service (runAction)
24+
import Development.IDE.Core.Shake (useWithStale, IdeState (..))
25+
import Development.IDE.GHC.Compat
26+
import Development.IDE.GHC.Error (realSrcSpanToRange)
27+
import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings)
28+
import Development.Shake (RuleResult, Action)
29+
import Development.Shake.Classes
30+
import qualified FastString
31+
import Ide.Plugin.Tactic.Context
32+
import Ide.Plugin.Tactic.GHC
33+
import Ide.Plugin.Tactic.Judgements
34+
import Ide.Plugin.Tactic.Range
35+
import Ide.Plugin.Tactic.Types
36+
import Language.LSP.Types
37+
import OccName
38+
import Prelude hiding (span)
39+
import SrcLoc (containsSpan)
40+
import TcRnTypes (tcg_binds)
41+
42+
43+
runIde :: IdeState -> Action a -> IO a
44+
runIde state = runAction "tactic" state
45+
46+
47+
runStaleIde
48+
:: forall a r
49+
. ( r ~ RuleResult a
50+
, Eq a , Hashable a , Binary a , Show a , Typeable a , NFData a
51+
, Show r, Typeable r, NFData r
52+
)
53+
=> IdeState
54+
-> NormalizedFilePath
55+
-> a
56+
-> MaybeT IO (r, PositionMapping)
57+
runStaleIde state nfp a = MaybeT $ runIde state $ useWithStale a nfp
58+
59+
60+
getIdeDynflags
61+
:: IdeState
62+
-> NormalizedFilePath
63+
-> MaybeT IO DynFlags
64+
getIdeDynflags state nfp = do
65+
-- Ok to use the stale 'ModIface', since all we need is its 'DynFlags'
66+
-- which don't change very often.
67+
((modsum,_), _) <- runStaleIde state nfp GetModSummaryWithoutTimestamps
68+
pure $ ms_hspp_opts modsum
69+
70+
71+
------------------------------------------------------------------------------
72+
-- | Find the last typechecked module, and find the most specific span, as well
73+
-- as the judgement at the given range.
74+
judgementForHole
75+
:: IdeState
76+
-> NormalizedFilePath
77+
-> Range
78+
-> MaybeT IO (Range, Judgement, Context, DynFlags)
79+
judgementForHole state nfp range = do
80+
(asts, amapping) <- runStaleIde state nfp GetHieAst
81+
case asts of
82+
HAR _ _ _ _ (HieFromDisk _) -> fail "Need a fresh hie file"
83+
HAR _ hf _ _ HieFresh -> do
84+
(binds, _) <- runStaleIde state nfp GetBindings
85+
(tcmod, _) <- runStaleIde state nfp TypeCheck
86+
(rss, g) <- liftMaybe $ getSpanAndTypeAtHole amapping range hf
87+
resulting_range <- liftMaybe $ toCurrentRange amapping $ realSrcSpanToRange rss
88+
let (jdg, ctx) = mkJudgementAndContext g binds rss tcmod
89+
dflags <- getIdeDynflags state nfp
90+
pure (resulting_range, jdg, ctx, dflags)
91+
92+
93+
mkJudgementAndContext
94+
:: Type
95+
-> Bindings
96+
-> RealSrcSpan
97+
-> TcModuleResult
98+
-> (Judgement, Context)
99+
mkJudgementAndContext g binds rss tcmod = do
100+
let tcg = tmrTypechecked tcmod
101+
tcs = tcg_binds tcg
102+
ctx = mkContext
103+
(mapMaybe (sequenceA . (occName *** coerce))
104+
$ getDefiningBindings binds rss)
105+
tcg
106+
top_provs = getRhsPosVals rss tcs
107+
local_hy = spliceProvenance top_provs
108+
$ hypothesisFromBindings rss binds
109+
cls_hy = contextMethodHypothesis ctx
110+
in ( mkFirstJudgement
111+
(local_hy <> cls_hy)
112+
(isRhsHole rss tcs)
113+
g
114+
, ctx
115+
)
116+
117+
118+
getSpanAndTypeAtHole
119+
:: PositionMapping
120+
-> Range
121+
-> HieASTs b
122+
-> Maybe (Span, b)
123+
getSpanAndTypeAtHole amapping range hf = do
124+
range' <- fromCurrentRange amapping range
125+
join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast ->
126+
case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range') ast of
127+
Nothing -> Nothing
128+
Just ast' -> do
129+
let info = nodeInfo ast'
130+
ty <- listToMaybe $ nodeType info
131+
guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info
132+
pure (nodeSpan ast', ty)
133+
134+
135+
136+
liftMaybe :: Monad m => Maybe a -> MaybeT m a
137+
liftMaybe a = MaybeT $ pure a
138+
139+
140+
spliceProvenance
141+
:: Map OccName Provenance
142+
-> Hypothesis a
143+
-> Hypothesis a
144+
spliceProvenance provs x =
145+
Hypothesis $ flip fmap (unHypothesis x) $ \hi ->
146+
overProvenance (maybe id const $ M.lookup (hi_name hi) provs) hi
147+
148+
149+
------------------------------------------------------------------------------
150+
-- | Compute top-level position vals of a function
151+
getRhsPosVals :: RealSrcSpan -> TypecheckedSource -> Map OccName Provenance
152+
getRhsPosVals rss tcs
153+
= M.fromList
154+
$ join
155+
$ maybeToList
156+
$ getFirst
157+
$ everything (<>) (mkQ mempty $ \case
158+
TopLevelRHS name ps
159+
(L (RealSrcSpan span) -- body with no guards and a single defn
160+
(HsVar _ (L _ hole)))
161+
| containsSpan rss span -- which contains our span
162+
, isHole $ occName hole -- and the span is a hole
163+
-> First $ do
164+
patnames <- traverse getPatName ps
165+
pure $ zip patnames $ [0..] <&> TopLevelArgPrv name
166+
_ -> mempty
167+
) tcs
168+
169+
170+
------------------------------------------------------------------------------
171+
-- | Is this hole immediately to the right of an equals sign?
172+
isRhsHole :: RealSrcSpan -> TypecheckedSource -> Bool
173+
isRhsHole rss tcs = everything (||) (mkQ False $ \case
174+
TopLevelRHS _ _ (L (RealSrcSpan span) _) -> containsSpan rss span
175+
_ -> False
176+
) tcs
177+

0 commit comments

Comments
 (0)