Skip to content

Commit e5329a9

Browse files
isovectorisovector
committed
Compute an interval map of what's in scope
1 parent 975ba77 commit e5329a9

File tree

4 files changed

+59
-163
lines changed

4 files changed

+59
-163
lines changed

‎haskell-language-server.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -115,6 +115,7 @@ executable haskell-language-server
115115
, bytestring
116116
, containers
117117
, deepseq
118+
, fingertree
118119
, floskell ^>=0.10
119120
, fourmolu ^>=0.1
120121
, ghc

‎plugins/default/src/Ide/LocalBindings.hs

Lines changed: 45 additions & 154 deletions
Original file line numberDiff line numberDiff line change
@@ -1,177 +1,69 @@
1-
{-# LANGUAGE LambdaCase #-}
2-
{-# LANGUAGE ScopedTypeVariables #-}
1+
{-# LANGUAGE DerivingStrategies #-}
2+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+
{-# LANGUAGE LambdaCase #-}
4+
{-# LANGUAGE ScopedTypeVariables #-}
35

46
module Ide.LocalBindings
5-
( Bindings (..)
6-
, bindings
7+
( Bindings
8+
, getLocalScope
79
, mostSpecificSpan
810
, holify
11+
, bindings
912
) where
1013

11-
import Bag
12-
import Control.Lens
13-
import Control.Monad
14-
import Data.Data.Lens
1514
import Data.Function
1615
import Data.Generics
16+
import Data.IntervalMap.FingerTree (IntervalMap, Interval (..))
17+
import qualified Data.IntervalMap.FingerTree as IM
1718
import Data.List
18-
import Data.Map (Map)
1919
import qualified Data.Map as M
2020
import Data.Maybe
2121
import Data.Ord
2222
import Data.Set (Set)
2323
import qualified Data.Set as S
24-
import Development.IDE.GHC.Compat (TypecheckedModule (..), GhcTc, noExt, RefMap, identType)
25-
import HsBinds
24+
import Development.IDE.GHC.Compat (GhcTc, RefMap, identType, noExt)
2625
import HsExpr
2726
import Id
2827
import OccName
2928
import SrcLoc
3029

30+
------------------------------------------------------------------------------
31+
-- | Turn a 'RealSrcSpan' into an 'Interval'.
32+
realSrcSpanToInterval :: RealSrcSpan -> Interval RealSrcLoc
33+
realSrcSpanToInterval rss =
34+
Interval
35+
(realSrcSpanStart rss)
36+
(realSrcSpanEnd rss)
37+
3138

3239
------------------------------------------------------------------------------
33-
-- | WIP function for getting 'bindings' from HIE, rather than stupidly
34-
-- traversing the entire AST.
35-
_bindigsHIE :: RefMap -> SrcSpan -> Set Id
36-
_bindigsHIE _ (UnhelpfulSpan _) = mempty
37-
_bindigsHIE refmap (RealSrcSpan span) = S.fromList $ do
40+
-- | Compute which identifiers are in scpoe at every point in the AST. Use
41+
-- 'getLocalScope' to find the results.
42+
bindings :: RefMap -> Bindings
43+
bindings refmap = Bindings $ foldr (uncurry IM.insert) mempty $ do
3844
(ident, refs) <- M.toList refmap
39-
Right _name <- pure ident
45+
Right name <- pure ident
4046
(ref_span, ident_details) <- refs
41-
Just _ty <- pure $ identType ident_details
42-
guard $ ref_span `containsSpan` span
43-
mempty
44-
45-
47+
Just ty <- pure $ identType ident_details
48+
pure ( realSrcSpanToInterval ref_span
49+
, S.singleton $ mkVanillaGlobal name ty
50+
)
4651

4752
------------------------------------------------------------------------------
4853
-- | The available bindings at every point in a Haskell tree.
49-
data Bindings = Bindings
50-
{ bGlobalBinds :: Set Id
51-
, bLocalBinds :: Map SrcSpan (Set Id)
52-
} deriving (Eq, Ord)
53-
54-
instance Semigroup Bindings where
55-
Bindings g1 l1 <> Bindings g2 l2 = Bindings (g1 <> g2) (l1 <> l2)
56-
57-
instance Monoid Bindings where
58-
mempty = Bindings mempty mempty
59-
60-
61-
------------------------------------------------------------------------------
62-
-- | Determine what bindings are in scope at every point in a program.
63-
--
64-
-- **WARNING:** This doesn't find bindings inside of TH splices or arrow syntax
65-
-- --- and possibly other obscure pieces of the AST.
66-
bindings :: TypecheckedModule -> Bindings
67-
bindings = uncurry Bindings . bindsBindings mempty . tm_typechecked_source
54+
newtype Bindings = Bindings
55+
{ getBindings :: IntervalMap RealSrcLoc (Set Id)
56+
} deriving newtype (Eq, Ord, Semigroup, Monoid)
6857

6958

7059
------------------------------------------------------------------------------
71-
-- | Helper function for implementing 'binding'.
72-
--
73-
-- **WARNING:** This doesn't yet work over TH splices or arrow syntax --- and
74-
-- possibly other obscure pieces of the AST.
75-
dataBindings :: Data a => S.Set Id -> a -> M.Map SrcSpan (S.Set Id)
76-
dataBindings in_scope = foldMapOf biplate $ cool collect
77-
where
78-
cool
79-
:: (HsExpr GhcTc -> M.Map SrcSpan (S.Set Id))
80-
-> LHsExpr GhcTc -> M.Map SrcSpan (S.Set Id)
81-
cool f (L src expr) = M.union (f expr) (M.singleton src in_scope)
82-
83-
collect :: HsExpr GhcTc -> M.Map SrcSpan (S.Set Id)
84-
collect (HsLam _ matches) = matchGroupBindings in_scope matches
85-
collect (HsLamCase _ matches) = matchGroupBindings in_scope matches
86-
collect (HsCase _ scrutinee matches) =
87-
M.union (dataBindings in_scope scrutinee) $ matchGroupBindings in_scope matches
88-
collect (HsLet _ (L _ binds) expr) =
89-
let (new, res) = localBindsBindings in_scope binds
90-
in_scope' = S.union new in_scope
91-
in M.union (dataBindings in_scope' expr) res
92-
collect (HsVar _ _) = mempty
93-
collect (HsUnboundVar _ _) = mempty
94-
collect (HsConLikeOut _ _) = mempty
95-
collect (HsRecFld _ _) = mempty
96-
collect (HsOverLabel _ _ _) = mempty
97-
collect (HsIPVar _ _) = mempty
98-
collect (HsOverLit _ _) = mempty
99-
collect (HsLit _ _) = mempty
100-
collect (HsApp _ a b) = M.union (dataBindings in_scope a) (dataBindings in_scope b)
101-
collect (HsAppType _ _ a) = dataBindings in_scope a
102-
collect (OpApp _ a b c) =
103-
mconcat
104-
[ dataBindings in_scope a
105-
, dataBindings in_scope b
106-
, dataBindings in_scope c
107-
]
108-
collect (NegApp _ a _) = dataBindings in_scope a
109-
collect (HsPar _ a) = dataBindings in_scope a
110-
collect (SectionL _ a b) =
111-
mconcat
112-
[ dataBindings in_scope a
113-
, dataBindings in_scope b
114-
]
115-
collect (SectionR _ a b) =
116-
mconcat
117-
[ dataBindings in_scope a
118-
, dataBindings in_scope b
119-
]
120-
collect (ExplicitTuple _ a _) = dataBindings in_scope a
121-
collect (ExplicitSum _ _ _ a) = dataBindings in_scope a
122-
collect (HsIf _ _ a b c) =
123-
mconcat
124-
[ dataBindings in_scope a
125-
, dataBindings in_scope b
126-
, dataBindings in_scope c
127-
]
128-
collect (HsMultiIf _ a) = dataBindings in_scope a
129-
collect (HsDo _ _ a) = dataBindings in_scope a
130-
collect (ExplicitList _ _ a) = dataBindings in_scope a
131-
collect (RecordCon _ _ a) = dataBindings in_scope a
132-
collect (RecordUpd _ _ a) = dataBindings in_scope a
133-
collect (ExprWithTySig _ _ a) = dataBindings in_scope a
134-
collect (ArithSeq _ _ a) = dataBindings in_scope a
135-
collect (HsSCC _ _ _ a) = dataBindings in_scope a
136-
collect (HsBracket _ a) = dataBindings in_scope a
137-
collect (HsStatic _ a) = dataBindings in_scope a
138-
-- TODO(sandy): This doesn't do arrow syntax
139-
collect _ = mempty
140-
141-
142-
------------------------------------------------------------------------------
143-
-- | Map the binds from a match group into over their containing spans.
144-
matchGroupBindings :: S.Set Id -> MatchGroup GhcTc (LHsExpr GhcTc) -> M.Map SrcSpan (S.Set Id)
145-
matchGroupBindings _ (XMatchGroup _) = M.empty
146-
matchGroupBindings in_scope (MG _ (L _ alts) _) = M.fromList $ do
147-
L _ (Match _ _ pats body) <- alts
148-
let bound = S.filter isId $ everything S.union (mkQ S.empty S.singleton) pats
149-
M.toList $ dataBindings (S.union bound in_scope) body
150-
151-
152-
------------------------------------------------------------------------------
153-
-- | Map the binds from a local binds into over their containing spans.
154-
localBindsBindings :: S.Set Id -> HsLocalBindsLR GhcTc GhcTc -> (S.Set Id, M.Map SrcSpan (S.Set Id))
155-
localBindsBindings in_scope (HsValBinds _ (ValBinds _ binds _sigs)) = bindsBindings in_scope binds
156-
localBindsBindings in_scope (HsValBinds _ (XValBindsLR (NValBinds groups _sigs))) =
157-
flip foldMap groups $ bindsBindings in_scope . snd
158-
localBindsBindings _ _ = (mempty, mempty)
159-
160-
161-
------------------------------------------------------------------------------
162-
-- | Map the binds from a hsbindlr into over their containing spans.
163-
bindsBindings :: S.Set Id -> Bag (LHsBindLR GhcTc GhcTc) -> (S.Set Id, M.Map SrcSpan (S.Set Id))
164-
bindsBindings in_scope binds =
165-
flip foldMap (fmap unLoc $ bagToList binds) $ \case
166-
FunBind _ (L _ name) matches _ _ ->
167-
(S.singleton name, matchGroupBindings (S.insert name in_scope) matches)
168-
PatBind _ pat rhs _ ->
169-
let bound = S.filter isId $ everything S.union (mkQ S.empty S.singleton) pat
170-
in (bound, dataBindings (S.union bound in_scope) rhs)
171-
AbsBinds _ _ _ _ _ binds' _ -> bindsBindings in_scope binds'
172-
VarBind _ name c _ -> (S.singleton name, dataBindings in_scope c)
173-
PatSynBind _ _ -> mempty
174-
XHsBindsLR _ -> mempty
60+
-- | Given a 'Bindings' get every identifier in scope at the given
61+
-- 'RealSrcSpan',
62+
getLocalScope :: Bindings -> RealSrcSpan -> Set Id
63+
getLocalScope bs rss
64+
= foldMap snd
65+
$ IM.dominators (realSrcSpanToInterval rss)
66+
$ getBindings bs
17567

17668

17769
------------------------------------------------------------------------------
@@ -196,19 +88,18 @@ mostSpecificSpan span z
19688
_ -> [])
19789
$ z
19890

91+
19992
------------------------------------------------------------------------------
20093
-- | Convert an HsVar back into an HsUnboundVar if it isn't actually in scope.
20194
-- TODO(sandy): this will throw away the type >:(
20295
holify :: Bindings -> LHsExpr GhcTc -> LHsExpr GhcTc
203-
holify (Bindings _ local) v@(L span (HsVar _ (L _ var))) =
96+
holify bs v@(L s@(RealSrcSpan span) (HsVar _ (L _ var))) =
20497
let occ = occName var
205-
in case M.lookup span local of
206-
Nothing -> v
207-
Just binds ->
208-
-- Make sure the binding is not in scope and that it begins with an
209-
-- underscore
210-
case not (S.member var binds) && take 1 (occNameString occ) == "_" of
211-
True -> L span $ HsUnboundVar noExt $ TrueExprHole occ
212-
False -> v
98+
binds = getLocalScope bs span
99+
in -- Make sure the binding is not in scope and that it begins with an
100+
-- underscore
101+
case not (S.member var binds) && take 1 (occNameString occ) == "_" of
102+
True -> L s $ HsUnboundVar noExt $ TrueExprHole occ
103+
False -> v
213104
holify _ v = v
214105

‎plugins/default/src/Ide/Plugin/Tactic.hs

Lines changed: 11 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,7 @@ import Data.Maybe
2323
import qualified Data.Text as T
2424
import Data.Traversable
2525
import Development.IDE.Core.PositionMapping
26-
import Development.IDE.Core.RuleTypes (TcModuleResult (tmrModule), TypeCheck (..), GhcSession(..))
26+
import Development.IDE.Core.RuleTypes (TcModuleResult (tmrModule), TypeCheck (..), GhcSession(..), GetHieAst (..), refMap)
2727
import Development.IDE.Core.Service (runAction)
2828
import Development.IDE.Core.Shake (useWithStale, IdeState (..))
2929
import Development.IDE.GHC.Compat
@@ -245,11 +245,18 @@ judgmentForHole state nfp range = runMaybeT $ do
245245

246246
(mss@(L span' (HsVar _ (L _ v))))
247247
<- liftMaybe $ mostSpecificSpan @_ @GhcTc span (tm_typechecked_source mod)
248+
rss <-
249+
liftMaybe $ case span' of
250+
RealSrcSpan rss -> Just rss
251+
_ -> Nothing
252+
253+
(har, _) <- MaybeT $ runIde state $ useWithStale GetHieAst nfp
254+
let refs = refMap har
255+
binds2 = bindings refs
248256

249257
let goal = varType v
250-
binds = bindings mod
251-
hyps = hypothesisFromBindings span' binds
252-
pure (pos, holify binds mss, Judgement hyps $ CType goal)
258+
hyps = hypothesisFromBindings rss binds2
259+
pure (pos, holify binds2 mss, Judgement hyps $ CType goal)
253260

254261

255262
tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction TacticParams

‎plugins/default/src/Ide/Plugin/Tactic/Machinery.hs

Lines changed: 2 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,6 @@ import Data.Function
1515
import Data.List
1616
import Data.Map (Map)
1717
import qualified Data.Map as M
18-
import Data.Maybe
1918
import Data.Set (Set)
2019
import qualified Data.Set as S
2120
import Data.Traversable
@@ -54,10 +53,8 @@ instance Ord CType where
5453

5554
------------------------------------------------------------------------------
5655
-- | Given a 'SrcSpan' and a 'Bindings', create a hypothesis.
57-
hypothesisFromBindings :: SrcSpan -> Bindings -> Map OccName CType
58-
hypothesisFromBindings span (Bindings global local) =
59-
buildHypothesis global
60-
<> buildHypothesis (fromMaybe mempty $ M.lookup span local)
56+
hypothesisFromBindings :: RealSrcSpan -> Bindings -> Map OccName CType
57+
hypothesisFromBindings span bs = buildHypothesis (getLocalScope bs span)
6158

6259

6360
------------------------------------------------------------------------------

0 commit comments

Comments
 (0)