@@ -26,8 +26,11 @@ module Ide.Plugin.Tactic.Judgements
26
26
, mkFirstJudgement
27
27
, hypothesisFromBindings
28
28
, isTopLevel
29
+ , hyNamesInScope
30
+ , hyByName
29
31
) where
30
32
33
+ import Control.Arrow
31
34
import Control.Lens hiding (Context )
32
35
import Data.Bool
33
36
import Data.Char
@@ -48,20 +51,20 @@ import Type
48
51
49
52
------------------------------------------------------------------------------
50
53
-- | Given a 'SrcSpan' and a 'Bindings', create a hypothesis.
51
- hypothesisFromBindings :: RealSrcSpan -> Bindings -> Map OccName ( HyInfo CType )
54
+ hypothesisFromBindings :: RealSrcSpan -> Bindings -> Hypothesis CType
52
55
hypothesisFromBindings span bs = buildHypothesis $ getLocalScope bs span
53
56
54
57
55
58
------------------------------------------------------------------------------
56
59
-- | Convert a @Set Id@ into a hypothesis.
57
- buildHypothesis :: [(Name , Maybe Type )] -> Map OccName ( HyInfo CType )
60
+ buildHypothesis :: [(Name , Maybe Type )] -> Hypothesis CType
58
61
buildHypothesis
59
- = M. fromList
62
+ = Hypothesis
60
63
. mapMaybe go
61
64
where
62
65
go (occName -> occ, t)
63
66
| Just ty <- t
64
- , isAlpha . head . occNameString $ occ = Just (occ, HyInfo UserPrv $ CType ty)
67
+ , isAlpha . head . occNameString $ occ = Just $ HyInfo occ UserPrv $ CType ty
65
68
| otherwise = Nothing
66
69
67
70
@@ -96,8 +99,8 @@ introducing
96
99
-> Judgement' a
97
100
-> Judgement' a
98
101
introducing f ns =
99
- field @ " _jHypothesis" <>~ M. fromList ( zip [0 .. ] ns <&>
100
- \ (pos, (name, ty)) -> (name, HyInfo (f pos) ty) )
102
+ field @ " _jHypothesis" <>~ ( Hypothesis $ zip [0 .. ] ns <&>
103
+ \ (pos, (name, ty)) -> HyInfo name (f pos) ty)
101
104
102
105
103
106
------------------------------------------------------------------------------
@@ -149,7 +152,7 @@ filterAncestry
149
152
-> Judgement
150
153
-> Judgement
151
154
filterAncestry ancestry reason jdg =
152
- disallowing reason (M. keys $ M. filterWithKey go $ jHypothesis jdg) jdg
155
+ disallowing reason (M. keys $ M. filterWithKey go $ hyByName $ jHypothesis jdg) jdg
153
156
where
154
157
go name _
155
158
= not
@@ -172,7 +175,7 @@ findPositionVal :: Judgement' a -> OccName -> Int -> Maybe OccName
172
175
findPositionVal jdg defn pos = listToMaybe $ do
173
176
-- It's important to inspect the entire hypothesis here, as we need to trace
174
177
-- ancstry through potentially disallowed terms in the hypothesis.
175
- (name, hi) <- M. toList $ M. map (overProvenance expandDisallowed) $ jEntireHypothesis jdg
178
+ (name, hi) <- M. toList $ M. map (overProvenance expandDisallowed) $ hyByName $ jEntireHypothesis jdg
176
179
case hi_provenance hi of
177
180
TopLevelArgPrv defn' pos'
178
181
| defn == defn'
@@ -188,7 +191,7 @@ findPositionVal jdg defn pos = listToMaybe $ do
188
191
-- 'filterSameTypeFromOtherPositions'.
189
192
findDconPositionVals :: Judgement' a -> DataCon -> Int -> [OccName ]
190
193
findDconPositionVals jdg dcon pos = do
191
- (name, hi) <- M. toList $ jHypothesis jdg
194
+ (name, hi) <- M. toList $ hyByName $ jHypothesis jdg
192
195
case hi_provenance hi of
193
196
PatternMatchPrv pv
194
197
| pv_datacon pv == Uniquely dcon
@@ -203,14 +206,15 @@ findDconPositionVals jdg dcon pos = do
203
206
-- other term which might match.
204
207
filterSameTypeFromOtherPositions :: DataCon -> Int -> Judgement -> Judgement
205
208
filterSameTypeFromOtherPositions dcon pos jdg =
206
- let hy = jHypothesis
209
+ let hy = hyByName
210
+ . jHypothesis
207
211
$ filterAncestry
208
212
(findDconPositionVals jdg dcon pos)
209
213
(WrongBranch pos)
210
214
jdg
211
215
tys = S. fromList $ hi_type <$> M. elems hy
212
216
to_remove =
213
- M. filter (flip S. member tys . hi_type) (jHypothesis jdg)
217
+ M. filter (flip S. member tys . hi_type) (hyByName $ jHypothesis jdg)
214
218
M. \\ hy
215
219
in disallowing Shadowed (M. keys to_remove) jdg
216
220
@@ -267,8 +271,8 @@ introducingPat scrutinee dc ns jdg
267
271
-- them from 'jHypothesis', but not from 'jEntireHypothesis'.
268
272
disallowing :: DisallowReason -> [OccName ] -> Judgement' a -> Judgement' a
269
273
disallowing reason (S. fromList -> ns) =
270
- field @ " _jHypothesis" %~ (M. mapWithKey $ \ name hi ->
271
- case S. member name ns of
274
+ field @ " _jHypothesis" %~ (\ z -> Hypothesis . flip fmap (unHypothesis z) $ \ hi ->
275
+ case S. member (hi_name hi) ns of
272
276
True -> overProvenance (DisallowedPrv reason) hi
273
277
False -> hi
274
278
)
@@ -277,20 +281,28 @@ disallowing reason (S.fromList -> ns) =
277
281
------------------------------------------------------------------------------
278
282
-- | The hypothesis, consisting of local terms and the ambient environment
279
283
-- (impors and class methods.) Hides disallowed values.
280
- jHypothesis :: Judgement' a -> Map OccName (HyInfo a )
281
- jHypothesis = M. filter (not . isDisallowed . hi_provenance) . jEntireHypothesis
284
+ jHypothesis :: Judgement' a -> Hypothesis a
285
+ jHypothesis
286
+ = Hypothesis
287
+ . filter (not . isDisallowed . hi_provenance)
288
+ . unHypothesis
289
+ . jEntireHypothesis
282
290
283
291
284
292
------------------------------------------------------------------------------
285
293
-- | The whole hypothesis, including things disallowed.
286
- jEntireHypothesis :: Judgement' a -> Map OccName ( HyInfo a )
294
+ jEntireHypothesis :: Judgement' a -> Hypothesis a
287
295
jEntireHypothesis = _jHypothesis
288
296
289
297
290
298
------------------------------------------------------------------------------
291
299
-- | Just the local hypothesis.
292
- jLocalHypothesis :: Judgement' a -> Map OccName (HyInfo a )
293
- jLocalHypothesis = M. filter (isLocalHypothesis . hi_provenance) . jHypothesis
300
+ jLocalHypothesis :: Judgement' a -> Hypothesis a
301
+ jLocalHypothesis
302
+ = Hypothesis
303
+ . filter (isLocalHypothesis . hi_provenance)
304
+ . unHypothesis
305
+ . jHypothesis
294
306
295
307
296
308
------------------------------------------------------------------------------
@@ -304,10 +316,30 @@ unsetIsTopHole :: Judgement' a -> Judgement' a
304
316
unsetIsTopHole = field @ " _jIsTopHole" .~ False
305
317
306
318
319
+ ------------------------------------------------------------------------------
320
+ -- | What names are currently in scope in the hypothesis?
321
+ hyNamesInScope :: Hypothesis a -> Set OccName
322
+ hyNamesInScope = M. keysSet . hyByName
323
+
324
+
325
+ ------------------------------------------------------------------------------
326
+ -- | Fold a hypothesis into a single mapping from name to info. This
327
+ -- unavoidably will cause duplicate names (things like methods) to shadow one
328
+ -- another.
329
+ hyByName :: Hypothesis a -> Map OccName (HyInfo a )
330
+ hyByName
331
+ = M. fromList
332
+ . fmap (hi_name &&& id )
333
+ . unHypothesis
334
+
335
+
307
336
------------------------------------------------------------------------------
308
337
-- | Only the hypothesis members which are pattern vals
309
338
jPatHypothesis :: Judgement' a -> Map OccName PatVal
310
- jPatHypothesis = M. mapMaybe (getPatVal . hi_provenance) . jHypothesis
339
+ jPatHypothesis
340
+ = M. mapMaybe (getPatVal . hi_provenance)
341
+ . hyByName
342
+ . jHypothesis
311
343
312
344
313
345
getPatVal :: Provenance -> Maybe PatVal
@@ -326,7 +358,7 @@ substJdg subst = fmap $ coerce . substTy subst . coerce
326
358
327
359
328
360
mkFirstJudgement
329
- :: M. Map OccName ( HyInfo CType )
361
+ :: Hypothesis CType
330
362
-> Bool -- ^ are we in the top level rhs hole?
331
363
-> Type
332
364
-> Judgement' CType
0 commit comments