Skip to content

Commit bdd8a09

Browse files
alexbiehlpaf31
alexbiehl
authored and
paf31
committed
Pattern guards (purescript#2588)
* WIP Pattern guards * Introduce GuardedExpr constructor * Longer names for alternative desugaring * isIrrefutable * Consistently value binders `vb` * Introduce isIrrefutable in Purescrupt/AST/Binders * Consolidate out of line code generation * Comment on special casing ConditionalGuards * Why do we need to scrutinize again * Remove warnings from AST/Traversals * Remove trueLit constant * Remove (***) import from CoreFn/Desugar * Removed shadowing in Linter/Exhaustive * Missed a tick * Make SourceFileSpec work * Fix AST/Traversals * Desugar with less cases * Desugar remaining alternatives if there are no guards remaining ``` g n | p = ... g n | b <- f = ... ``` The pattern guard wouldn't be desugared without this patch because `p` was the only guarded expression in the first alternative which resulted in the empty list case in `desugarGuardedAlternative` so the remaining second alternative is passed as-is upwards again. * Update comment * Remove redundant Show constraint * Remove redundant Monad constraint * Remove duplication * Use short-circuiting fold in CodeGen/JS * Correct generation of pattern guards with irrefutable patterns Consider ``` f ... | i <- g = ... ``` Where i is an irrefutable pattern we would generate ``` case ... of ... -> case g of i -> ... _ -> ... ``` We generated an unreachable case alternative Which is bogus of course! A pattern match on `i` will never fail! This patch stops generating the unreachable case. * Fix everythingWithScope This lead to undetected shadowing. Fortunately the fix was to delete some wrong "duplicated" code. * Error on desugaring pattern guards to CoreFn * Use scoped type variable m to dry code * Error when trying to typecheck pattern guard These are desugared to usual cases and guards already * Make sure to not evaluate scrutinees twice * Typos * A few examples
1 parent 52385b7 commit bdd8a09

File tree

26 files changed

+584
-197
lines changed

26 files changed

+584
-197
lines changed

‎examples/failing/NonExhaustivePatGuard.purs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
-- @shouldFailWith NoInstanceFound
2+
module Main where
3+
4+
f :: Int -> Int
5+
f x | 1 <- x = x

‎examples/passing/Guards.purs‎

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,4 +27,38 @@ testIndentation x y | x > 0.0
2727
| otherwise
2828
= y - x
2929

30+
-- pattern guard example with two clauses
31+
clunky1 :: Int -> Int -> Int
32+
clunky1 a b | x <- max a b
33+
, x > 5
34+
= x
35+
clunky1 a _ = a
36+
37+
clunky2 :: Int -> Int -> Int
38+
clunky2 a b | x <- max a b
39+
, x > 5
40+
= x
41+
| otherwise
42+
= a + b
43+
44+
-- pattern guards on case epxressions
45+
clunky_case1 :: Int -> Int -> Int
46+
clunky_case1 a b =
47+
case unit of
48+
unit | x <- max a b
49+
, x > 5
50+
-> x
51+
| otherwise -> a + b
52+
53+
-- test indentation
54+
clunky_case2 :: Int -> Int -> Int
55+
clunky_case2 a b =
56+
case unit of
57+
unit
58+
| x <- max a b
59+
, x > 5
60+
-> x
61+
| otherwise
62+
-> a + b
63+
3064
main = log $ min "Done" "ZZZZ"

‎examples/warning/ShadowedBinderPatternGuard.purs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
-- @shouldWarnWith ShadowedName
2+
module Main where
3+
4+
f :: Int -> Int
5+
f n | i <- true -- this i is shadowed
6+
, i <- 1234
7+
= i

‎src/Language/PureScript/AST/Binders.hs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -81,3 +81,11 @@ binderNames = go []
8181
lit ns (ObjectLiteral bs) = foldl go ns (map snd bs)
8282
lit ns (ArrayLiteral bs) = foldl go ns bs
8383
lit ns _ = ns
84+
85+
isIrrefutable :: Binder -> Bool
86+
isIrrefutable NullBinder = True
87+
isIrrefutable (VarBinder _) = True
88+
isIrrefutable (PositionedBinder _ _ b) = isIrrefutable b
89+
isIrrefutable (TypedBinder _ b) = isIrrefutable b
90+
isIrrefutable _ = False
91+

‎src/Language/PureScript/AST/Declarations.hs‎

Lines changed: 22 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -391,7 +391,7 @@ data Declaration
391391
-- |
392392
-- A value declaration (name, top-level binders, optional guard, value)
393393
--
394-
| ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)
394+
| ValueDeclaration Ident NameKind [Binder] [GuardedExpr]
395395
-- |
396396
-- A minimal mutually recursive set of value declarations
397397
--
@@ -553,7 +553,18 @@ flattenDecls = concatMap flattenOne
553553
-- |
554554
-- A guard is just a boolean-valued expression that appears alongside a set of binders
555555
--
556-
type Guard = Expr
556+
data Guard = ConditionGuard Expr
557+
| PatternGuard Binder Expr
558+
deriving (Show)
559+
560+
-- |
561+
-- The right hand side of a binder in value declarations
562+
-- and case expressions.
563+
data GuardedExpr = GuardedExpr [Guard] Expr
564+
deriving (Show)
565+
566+
pattern MkUnguarded :: Expr -> GuardedExpr
567+
pattern MkUnguarded e = GuardedExpr [] e
557568

558569
-- |
559570
-- Data type for expressions and terms
@@ -685,7 +696,7 @@ data CaseAlternative = CaseAlternative
685696
-- |
686697
-- The result expression or a collect of guarded expressions
687698
--
688-
, caseAlternativeResult :: Either [(Guard, Expr)] Expr
699+
, caseAlternativeResult :: [GuardedExpr]
689700
} deriving (Show)
690701

691702
-- |
@@ -745,3 +756,11 @@ newtype AssocList k t = AssocList { runAssocList :: [(k, t)] }
745756

746757
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
747758
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)
759+
760+
isTrueExpr :: Expr -> Bool
761+
isTrueExpr (Literal (BooleanLiteral True)) = True
762+
isTrueExpr (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True
763+
isTrueExpr (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True
764+
isTrueExpr (TypedValue _ e _) = isTrueExpr e
765+
isTrueExpr (PositionedValue _ _ e) = isTrueExpr e
766+
isTrueExpr _ = False

‎src/Language/PureScript/AST/Traversals.hs‎

Lines changed: 68 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,6 @@ module Language.PureScript.AST.Traversals where
66
import Prelude.Compat
77

88
import Control.Monad
9-
import Control.Arrow ((***), (+++))
109

1110
import Data.Foldable (fold)
1211
import Data.List (mapAccumL)
@@ -21,6 +20,21 @@ import Language.PureScript.Names
2120
import Language.PureScript.Traversals
2221
import Language.PureScript.Types
2322

23+
guardedExprM :: Applicative m
24+
=> (Guard -> m Guard)
25+
-> (Expr -> m Expr)
26+
-> GuardedExpr
27+
-> m GuardedExpr
28+
guardedExprM f g (GuardedExpr guards rhs) =
29+
GuardedExpr <$> traverse f guards <*> g rhs
30+
31+
mapGuardedExpr :: (Guard -> Guard)
32+
-> (Expr -> Expr)
33+
-> GuardedExpr
34+
-> GuardedExpr
35+
mapGuardedExpr f g (GuardedExpr guards rhs) =
36+
GuardedExpr (map f guards) (g rhs)
37+
2438
everywhereOnValues
2539
:: (Declaration -> Declaration)
2640
-> (Expr -> Expr)
@@ -33,7 +47,7 @@ everywhereOnValues f g h = (f', g', h')
3347
where
3448
f' :: Declaration -> Declaration
3549
f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))
36-
f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))
50+
f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) (map (mapGuardedExpr handleGuard g') val))
3751
f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
3852
f' (TypeClassDeclaration name args implies deps ds) = f (TypeClassDeclaration name args implies deps (map f' ds))
3953
f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds))
@@ -77,7 +91,7 @@ everywhereOnValues f g h = (f', g', h')
7791
handleCaseAlternative :: CaseAlternative -> CaseAlternative
7892
handleCaseAlternative ca =
7993
ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
80-
, caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
94+
, caseAlternativeResult = map (mapGuardedExpr handleGuard g') (caseAlternativeResult ca)
8195
}
8296

8397
handleDoNotationElement :: DoNotationElement -> DoNotationElement
@@ -86,6 +100,10 @@ everywhereOnValues f g h = (f', g', h')
86100
handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
87101
handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)
88102

103+
handleGuard :: Guard -> Guard
104+
handleGuard (ConditionGuard e) = ConditionGuard (g' e)
105+
handleGuard (PatternGuard b e) = PatternGuard (h' b) (g' e)
106+
89107
everywhereOnValuesTopDownM
90108
:: forall m
91109
. (Monad m)
@@ -101,7 +119,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
101119

102120
f' :: Declaration -> m Declaration
103121
f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds
104-
f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
122+
f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val
105123
f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
106124
f' (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f' <=< f) ds
107125
f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds
@@ -146,14 +164,18 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
146164
handleCaseAlternative (CaseAlternative bs val) =
147165
CaseAlternative
148166
<$> traverse (h' <=< h) bs
149-
<*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
167+
<*> traverse (guardedExprM handleGuard (g' <=< g)) val
150168

151169
handleDoNotationElement :: DoNotationElement -> m DoNotationElement
152170
handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v
153171
handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v
154172
handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds
155173
handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
156174

175+
handleGuard :: Guard -> m Guard
176+
handleGuard (ConditionGuard e) = ConditionGuard <$> (g' <=< g) e
177+
handleGuard (PatternGuard b e) = PatternGuard <$> (h' <=< h) b <*> (g' <=< g) e
178+
157179
everywhereOnValuesM
158180
:: forall m
159181
. (Monad m)
@@ -169,7 +191,7 @@ everywhereOnValuesM f g h = (f', g', h')
169191

170192
f' :: Declaration -> m Declaration
171193
f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f
172-
f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f
194+
f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val) >>= f
173195
f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
174196
f' (TypeClassDeclaration name args implies deps ds) = (TypeClassDeclaration name args implies deps <$> traverse f' ds) >>= f
175197
f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f
@@ -214,14 +236,18 @@ everywhereOnValuesM f g h = (f', g', h')
214236
handleCaseAlternative (CaseAlternative bs val) =
215237
CaseAlternative
216238
<$> traverse h' bs
217-
<*> eitherM (traverse (pairM g' g')) g' val
239+
<*> traverse (guardedExprM handleGuard g') val
218240

219241
handleDoNotationElement :: DoNotationElement -> m DoNotationElement
220242
handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v
221243
handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v
222244
handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds
223245
handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
224246

247+
handleGuard :: Guard -> m Guard
248+
handleGuard (ConditionGuard e) = ConditionGuard <$> g' e
249+
handleGuard (PatternGuard b e) = PatternGuard <$> h' b <*> g' e
250+
225251
everythingOnValues
226252
:: forall r
227253
. (r -> r -> r)
@@ -241,8 +267,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
241267

242268
f' :: Declaration -> r
243269
f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
244-
f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
245-
f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
270+
f' d@(ValueDeclaration _ _ bs val) = foldl (<>) (f d) (map h' bs ++ concatMap (\(GuardedExpr grd v) -> map k' grd ++ [g' v]) val)
246271
f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)
247272
f' d@(TypeClassDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)
248273
f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds)
@@ -284,15 +309,19 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
284309
lit r _ _ = r
285310

286311
i' :: CaseAlternative -> r
287-
i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
288-
i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
312+
i' ca@(CaseAlternative bs gs) =
313+
foldl (<>) (i ca) (map h' bs ++ concatMap (\(GuardedExpr grd val) -> map k' grd ++ [g' val]) gs)
289314

290315
j' :: DoNotationElement -> r
291316
j' e@(DoNotationValue v) = j e <> g' v
292317
j' e@(DoNotationBind b v) = j e <> h' b <> g' v
293318
j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
294319
j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1
295320

321+
k' :: Guard -> r
322+
k' (ConditionGuard e) = g' e
323+
k' (PatternGuard b e) = h' b <> g' e
324+
296325
everythingWithContextOnValues
297326
:: forall s r
298327
. s
@@ -316,8 +345,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
316345

317346
f' :: s -> Declaration -> r
318347
f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)
319-
f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
320-
f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
348+
f' s (ValueDeclaration _ _ bs val) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(GuardedExpr grd v) -> map (k' s) grd ++ [g'' s v]) val)
321349
f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)
322350
f' s (TypeClassDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
323351
f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (map (f'' s) ds)
@@ -368,8 +396,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
368396
i'' s ca = let (s', r) = i s ca in r <> i' s' ca
369397

370398
i' :: s -> CaseAlternative -> r
371-
i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
372-
i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
399+
i' s (CaseAlternative bs gs) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> map (k' s) grd ++ [g'' s val]) gs)
373400

374401
j'' :: s -> DoNotationElement -> r
375402
j'' s e = let (s', r) = j s e in r <> j' s' e
@@ -380,6 +407,10 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
380407
j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)
381408
j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
382409

410+
k' :: s -> Guard -> r
411+
k' s (ConditionGuard e) = g'' s e
412+
k' s (PatternGuard b e) = h'' s b <> g'' s e
413+
383414
everywhereWithContextOnValuesM
384415
:: forall m s
385416
. (Monad m)
@@ -393,13 +424,14 @@ everywhereWithContextOnValuesM
393424
, Expr -> m Expr
394425
, Binder -> m Binder
395426
, CaseAlternative -> m CaseAlternative
396-
, DoNotationElement -> m DoNotationElement)
427+
, DoNotationElement -> m DoNotationElement
428+
)
397429
everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
398430
where
399431
f'' s = uncurry f' <=< f s
400432

401433
f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds
402-
f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val
434+
f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val
403435
f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds
404436
f' s (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f'' s) ds
405437
f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds
@@ -444,7 +476,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
444476

445477
i'' s = uncurry i' <=< i s
446478

447-
i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val
479+
i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val
448480

449481
j'' s = uncurry j' <=< j s
450482

@@ -453,6 +485,9 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
453485
j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds
454486
j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1
455487

488+
k' s (ConditionGuard e) = ConditionGuard <$> g'' s e
489+
k' s (PatternGuard b e) = PatternGuard <$> h'' s b <*> g'' s e
490+
456491
everythingWithScope
457492
:: forall r
458493
. (Monoid r)
@@ -479,14 +514,10 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
479514
f' s (DataBindingGroupDeclaration ds) =
480515
let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))
481516
in foldMap (f'' s') ds
482-
f' s (ValueDeclaration name _ bs (Right val)) =
517+
f' s (ValueDeclaration name _ bs val) =
483518
let s' = S.insert name s
484519
s'' = S.union s' (S.fromList (concatMap binderNames bs))
485-
in foldMap (h'' s') bs <> g'' s'' val
486-
f' s (ValueDeclaration name _ bs (Left gs)) =
487-
let s' = S.insert name s
488-
s'' = S.union s' (S.fromList (concatMap binderNames bs))
489-
in foldMap (h'' s') bs <> foldMap (\(grd, val) -> g'' s'' grd <> g'' s'' val) gs
520+
in foldMap (h'' s') bs <> foldMap (l' s'') val
490521
f' s (BindingGroupDeclaration ds) =
491522
let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds))
492523
in foldMap (\(_, _, val) -> g'' s' val) ds
@@ -546,12 +577,9 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
546577
i'' s a = i s a <> i' s a
547578

548579
i' :: S.Set Ident -> CaseAlternative -> r
549-
i' s (CaseAlternative bs (Right val)) =
580+
i' s (CaseAlternative bs gs) =
550581
let s' = S.union s (S.fromList (concatMap binderNames bs))
551-
in foldMap (h'' s) bs <> g'' s' val
552-
i' s (CaseAlternative bs (Left gs)) =
553-
let s' = S.union s (S.fromList (concatMap binderNames bs))
554-
in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs
582+
in foldMap (h'' s) bs <> foldMap (l' s') gs
555583

556584
j'' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)
557585
j'' s a = let (s', r) = j' s a in (s', j s a <> r)
@@ -566,6 +594,17 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
566594
in (s', foldMap (f'' s') ds)
567595
j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
568596

597+
k' :: S.Set Ident -> Guard -> (S.Set Ident, r)
598+
k' s (ConditionGuard e) = (s, g'' s e)
599+
k' s (PatternGuard b e) =
600+
let s' = S.union (S.fromList (binderNames b)) s
601+
in (s', h'' s b <> g'' s' e)
602+
603+
l' s (GuardedExpr [] e) = g'' s e
604+
l' s (GuardedExpr (grd:gs) e) =
605+
let (s', r) = k' s grd
606+
in r <> l' s' (GuardedExpr gs e)
607+
569608
getDeclIdent :: Declaration -> Maybe Ident
570609
getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
571610
getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
@@ -642,4 +681,3 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
642681
g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
643682
g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints
644683
g other = other
645-

0 commit comments

Comments
 (0)