@@ -1,17 +1,8 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.AST.Traversals
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | AST traversal helpers
12−--
13−-----------------------------------------------------------------------------
1+{-# LANGUAGE ScopedTypeVariables #-}
142
3+-- |
4+-- AST traversal helpers
5+--
156module Language.PureScript.AST.Traversals where
167
178import Prelude ()
@@ -26,15 +17,20 @@ import Control.Monad
2617import Control.Arrow ((***), (+++))
2718
2819import Language.PureScript.AST.Binders
20+import Language.PureScript.AST.Literals
2921import Language.PureScript.AST.Declarations
3022import Language.PureScript.Types
3123import Language.PureScript.Traversals
3224import Language.PureScript.Names
3325
34−everywhereOnValues :: (Declaration -> Declaration) ->
35− (Expr -> Expr) ->
36− (Binder -> Binder) ->
37− (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
26+everywhereOnValues
27+ :: (Declaration -> Declaration)
28+ -> (Expr -> Expr)
29+ -> (Binder -> Binder)
30+ -> ( Declaration -> Declaration
31+ , Expr -> Expr
32+ , Binder -> Binder
33+ )
3834everywhereOnValues f g h = (f', g', h')
3935 where
4036 f' :: Declaration -> Declaration
@@ -47,13 +43,12 @@ everywhereOnValues f g h = (f', g', h')
4743 f' other = f other
4844
4945 g' :: Expr -> Expr
46+ g' (Literal l) = g (Literal (lit g' l))
5047 g' (UnaryMinus v) = g (UnaryMinus (g' v))
5148 g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))
5249 g' (Parens v) = g (Parens (g' v))
5350 g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v))
5451 g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))
55− g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))
56− g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))
5752 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
5853 g' (Accessor prop v) = g (Accessor prop (g' v))
5954 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
@@ -71,13 +66,17 @@ everywhereOnValues f g h = (f', g', h')
7166 h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))
7267 h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))
7368 h' (ParensInBinder b) = h (ParensInBinder (h' b))
74− h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))
75− h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
69+ h' (LiteralBinder l) = h (LiteralBinder (lit h' l))
7670 h' (NamedBinder name b) = h (NamedBinder name (h' b))
7771 h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))
7872 h' (TypedBinder t b) = h (TypedBinder t (h' b))
7973 h' other = h other
8074
75+ lit :: (a -> a) -> Literal a -> Literal a
76+ lit go (ArrayLiteral as) = ArrayLiteral (map go as)
77+ lit go (ObjectLiteral as) = ObjectLiteral (map (fmap go) as)
78+ lit _ other = other
79+
8180 handleCaseAlternative :: CaseAlternative -> CaseAlternative
8281 handleCaseAlternative ca =
8382 ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
@@ -90,13 +89,20 @@ everywhereOnValues f g h = (f', g', h')
9089 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
9190 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)
9291
93−everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
94− (Declaration -> m Declaration) ->
95− (Expr -> m Expr) ->
96− (Binder -> m Binder) ->
97− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
92+everywhereOnValuesTopDownM
93+ :: forall m
94+ . (Functor m, Applicative m, Monad m)
95+ => (Declaration -> m Declaration)
96+ -> (Expr -> m Expr)
97+ -> (Binder -> m Binder)
98+ -> ( Declaration -> m Declaration
99+ , Expr -> m Expr
100+ , Binder -> m Binder
101+ )
98102everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
99103 where
104+
105+ f' :: Declaration -> m Declaration
100106 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds
101107 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
102108 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
@@ -105,13 +111,13 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
105111 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')
106112 f' other = f other
107113
114+ g' :: Expr -> m Expr
115+ g' (Literal l) = Literal <$> lit (g >=> g') l
108116 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
109117 g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')
110118 g' (Parens v) = Parens <$> (g v >>= g')
111119 g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))
112120 g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))
113− g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs
114− g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs
115121 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
116122 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
117123 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs
@@ -125,31 +131,47 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
125131 g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')
126132 g' other = g other
127133
134+ h' :: Binder -> m Binder
135+ h' (LiteralBinder l) = LiteralBinder <$> lit (h >=> h') l
128136 h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs
129137 h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')
130138 h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')
131− h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs
132− h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs
133139 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
134140 h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')
135141 h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')
136142 h' other = h other
137143
138− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse (h' <=< h) bs
139− <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
144+ lit :: (a -> m a) -> Literal a -> m (Literal a)
145+ lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as
146+ lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as
147+ lit _ other = pure other
148+
149+ handleCaseAlternative :: CaseAlternative -> m CaseAlternative
150+ handleCaseAlternative (CaseAlternative bs val) =
151+ CaseAlternative
152+ <$> traverse (h' <=< h) bs
153+ <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
140154
155+ handleDoNotationElement :: DoNotationElement -> m DoNotationElement
141156 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v
142157 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v
143158 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds
144159 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
145160
146−everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
147− (Declaration -> m Declaration) ->
148− (Expr -> m Expr) ->
149− (Binder -> m Binder) ->
150− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
161+everywhereOnValuesM
162+ :: forall m
163+ . (Functor m, Applicative m, Monad m)
164+ => (Declaration -> m Declaration)
165+ -> (Expr -> m Expr)
166+ -> (Binder -> m Binder)
167+ -> ( Declaration -> m Declaration
168+ , Expr -> m Expr
169+ , Binder -> m Binder
170+ )
151171everywhereOnValuesM f g h = (f', g', h')
152172 where
173+
174+ f' :: Declaration -> m Declaration
153175 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f
154176 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f
155177 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
@@ -158,13 +180,13 @@ everywhereOnValuesM f g h = (f', g', h')
158180 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f
159181 f' other = f other
160182
183+ g' :: Expr -> m Expr
184+ g' (Literal l) = (Literal <$> lit g' l) >>= g
161185 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
162186 g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g
163187 g' (Parens v) = (Parens <$> g' v) >>= g
164188 g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g
165189 g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g
166− g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g
167− g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g
168190 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
169191 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
170192 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g
@@ -178,33 +200,51 @@ everywhereOnValuesM f g h = (f', g', h')
178200 g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g
179201 g' other = g other
180202
203+ h' :: Binder -> m Binder
204+ h' (LiteralBinder l) = (LiteralBinder <$> lit h' l) >>= h
181205 h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h
182206 h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h
183207 h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h
184− h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h
185− h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h
186208 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
187209 h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h
188210 h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h
189211 h' other = h other
190212
191− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse h' bs
192− <*> eitherM (traverse (pairM g' g')) g' val
213+ lit :: (a -> m a) -> Literal a -> m (Literal a)
214+ lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as
215+ lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as
216+ lit _ other = pure other
217+
218+ handleCaseAlternative :: CaseAlternative -> m CaseAlternative
219+ handleCaseAlternative (CaseAlternative bs val) =
220+ CaseAlternative
221+ <$> traverse h' bs
222+ <*> eitherM (traverse (pairM g' g')) g' val
193223
224+ handleDoNotationElement :: DoNotationElement -> m DoNotationElement
194225 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v
195226 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v
196227 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds
197228 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
198229
199−everythingOnValues :: (r -> r -> r) ->
200− (Declaration -> r) ->
201− (Expr -> r) ->
202− (Binder -> r) ->
203− (CaseAlternative -> r) ->
204− (DoNotationElement -> r) ->
205− (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
230+everythingOnValues
231+ :: forall r
232+ . (r -> r -> r)
233+ -> (Declaration -> r)
234+ -> (Expr -> r)
235+ -> (Binder -> r)
236+ -> (CaseAlternative -> r)
237+ -> (DoNotationElement -> r)
238+ -> ( Declaration -> r
239+ , Expr -> r
240+ , Binder -> r
241+ , CaseAlternative -> r
242+ , DoNotationElement -> r
243+ )
206244everythingOnValues (<>) f g h i j = (f', g', h', i', j')
207245 where
246+
247+ f' :: Declaration -> r
208248 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
209249 f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
210250 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
@@ -214,13 +254,13 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
214254 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1
215255 f' d = f d
216256
257+ g' :: Expr -> r
258+ g' v@(Literal l) = lit (g v) g' l
217259 g' v@(UnaryMinus v1) = g v <> g' v1
218260 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2
219261 g' v@(Parens v1) = g v <> g' v1
220262 g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1
221263 g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1
222− g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
223− g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
224264 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
225265 g' v@(Accessor _ v1) = g v <> g' v1
226266 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
@@ -234,42 +274,53 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
234274 g' v@(PositionedValue _ _ v1) = g v <> g' v1
235275 g' v = g v
236276
277+ h' :: Binder -> r
278+ h' b@(LiteralBinder l) = lit (h b) h' l
237279 h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)
238280 h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3
239281 h' b@(ParensInBinder b1) = h b <> h' b1
240− h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)
241− h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)
242282 h' b@(NamedBinder _ b1) = h b <> h' b1
243283 h' b@(PositionedBinder _ _ b1) = h b <> h' b1
244284 h' b@(TypedBinder _ b1) = h b <> h' b1
245285 h' b = h b
246286
287+ lit :: r -> (a -> r) -> Literal a -> r
288+ lit r go (ArrayLiteral as) = foldl (<>) r (map go as)
289+ lit r go (ObjectLiteral as) = foldl (<>) r (map (go . snd) as)
290+ lit r _ _ = r
291+
292+ i' :: CaseAlternative -> r
247293 i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
248294 i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
249295
296+ j' :: DoNotationElement -> r
250297 j' e@(DoNotationValue v) = j e <> g' v
251298 j' e@(DoNotationBind b v) = j e <> h' b <> g' v
252299 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
253300 j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1
254301
255−everythingWithContextOnValues ::
256− s ->
257− r ->
258− (r -> r -> r) ->
259− (s -> Declaration -> (s, r)) ->
260− (s -> Expr -> (s, r)) ->
261− (s -> Binder -> (s, r)) ->
262− (s -> CaseAlternative -> (s, r)) ->
263− (s -> DoNotationElement -> (s, r)) ->
264− ( Declaration -> r
265− , Expr -> r
266− , Binder -> r
267− , CaseAlternative -> r
268− , DoNotationElement -> r)
302+everythingWithContextOnValues
303+ :: forall s r
304+ . s
305+ -> r
306+ -> (r -> r -> r)
307+ -> (s -> Declaration -> (s, r))
308+ -> (s -> Expr -> (s, r))
309+ -> (s -> Binder -> (s, r))
310+ -> (s -> CaseAlternative -> (s, r))
311+ -> (s -> DoNotationElement -> (s, r))
312+ -> ( Declaration -> r
313+ , Expr -> r
314+ , Binder -> r
315+ , CaseAlternative -> r
316+ , DoNotationElement -> r)
269317everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
270318 where
319+
320+ f'' :: s -> Declaration -> r
271321 f'' s d = let (s', r) = f s d in r <> f' s' d
272322
323+ f' :: s -> Declaration -> r
273324 f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)
274325 f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
275326 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
@@ -279,15 +330,16 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
279330 f' s (PositionedDeclaration _ _ d1) = f'' s d1
280331 f' _ _ = r0
281332
333+ g'' :: s -> Expr -> r
282334 g'' s v = let (s', r) = g s v in r <> g' s' v
283335
336+ g' :: s -> Expr -> r
337+ g' s (Literal l) = lit g'' s l
284338 g' s (UnaryMinus v1) = g'' s v1
285339 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
286340 g' s (Parens v1) = g'' s v1
287341 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v
288342 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
289− g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)
290− g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)
291343 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
292344 g' s (Accessor _ v1) = g'' s v1
293345 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
@@ -301,42 +353,54 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
301353 g' s (PositionedValue _ _ v1) = g'' s v1
302354 g' _ _ = r0
303355
356+ h'' :: s -> Binder -> r
304357 h'' s b = let (s', r) = h s b in r <> h' s' b
305358
359+ h' :: s -> Binder -> r
360+ h' s (LiteralBinder l) = lit h'' s l
306361 h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)
307362 h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3
308363 h' s (ParensInBinder b) = h'' s b
309− h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)
310− h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)
311364 h' s (NamedBinder _ b1) = h'' s b1
312365 h' s (PositionedBinder _ _ b1) = h'' s b1
313366 h' s (TypedBinder _ b1) = h'' s b1
314367 h' _ _ = r0
315368
369+ lit :: (s -> a -> r) -> s -> Literal a -> r
370+ lit go s (ArrayLiteral as) = foldl (<>) r0 (map (go s) as)
371+ lit go s (ObjectLiteral as) = foldl (<>) r0 (map (go s . snd) as)
372+ lit _ _ _ = r0
373+
374+ i'' :: s -> CaseAlternative -> r
316375 i'' s ca = let (s', r) = i s ca in r <> i' s' ca
317376
377+ i' :: s -> CaseAlternative -> r
318378 i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
319379 i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
320380
381+ j'' :: s -> DoNotationElement -> r
321382 j'' s e = let (s', r) = j s e in r <> j' s' e
322383
384+ j' :: s -> DoNotationElement -> r
323385 j' s (DoNotationValue v) = g'' s v
324386 j' s (DoNotationBind b v) = h'' s b <> g'' s v
325387 j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)
326388 j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
327389
328−everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>
329− s ->
330− (s -> Declaration -> m (s, Declaration)) ->
331− (s -> Expr -> m (s, Expr)) ->
332− (s -> Binder -> m (s, Binder)) ->
333− (s -> CaseAlternative -> m (s, CaseAlternative)) ->
334− (s -> DoNotationElement -> m (s, DoNotationElement)) ->
335− ( Declaration -> m Declaration
336− , Expr -> m Expr
337− , Binder -> m Binder
338− , CaseAlternative -> m CaseAlternative
339− , DoNotationElement -> m DoNotationElement)
390+everywhereWithContextOnValuesM
391+ :: forall m s
392+ . (Functor m, Applicative m, Monad m)
393+ => s
394+ -> (s -> Declaration -> m (s, Declaration))
395+ -> (s -> Expr -> m (s, Expr))
396+ -> (s -> Binder -> m (s, Binder))
397+ -> (s -> CaseAlternative -> m (s, CaseAlternative))
398+ -> (s -> DoNotationElement -> m (s, DoNotationElement))
399+ -> ( Declaration -> m Declaration
400+ , Expr -> m Expr
401+ , Binder -> m Binder
402+ , CaseAlternative -> m CaseAlternative
403+ , DoNotationElement -> m DoNotationElement)
340404everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
341405 where
342406 f'' s = uncurry f' <=< f s
@@ -351,13 +415,12 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
351415
352416 g'' s = uncurry g' <=< g s
353417
418+ g' s (Literal l) = Literal <$> lit g'' s l
354419 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v
355420 g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2
356421 g' s (Parens v) = Parens <$> g'' s v
357422 g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)
358423 g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)
359− g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs
360− g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs
361424 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
362425 g' s (Accessor prop v) = Accessor prop <$> g'' s v
363426 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs
@@ -373,16 +436,20 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
373436
374437 h'' s = uncurry h' <=< h s
375438
439+ h' s (LiteralBinder l) = LiteralBinder <$> lit h'' s l
376440 h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs
377441 h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3
378442 h' s (ParensInBinder b) = ParensInBinder <$> h'' s b
379− h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs
380− h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs
381443 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
382444 h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b
383445 h' s (TypedBinder t b) = TypedBinder t <$> h'' s b
384446 h' _ other = return other
385447
448+ lit :: (s -> a -> m a) -> s -> Literal a -> m (Literal a)
449+ lit go s (ArrayLiteral as) = ArrayLiteral <$> traverse (go s) as
450+ lit go s (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM (go s)) as
451+ lit _ _ other = return other
452+
386453 i'' s = uncurry i' <=< i s
387454
388455 i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val
@@ -394,25 +461,29 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
394461 j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds
395462 j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1
396463
397−everythingWithScope ::
398− (Monoid r) =>
399− (S.Set Ident -> Declaration -> r) ->
400− (S.Set Ident -> Expr -> r) ->
401− (S.Set Ident -> Binder -> r) ->
402− (S.Set Ident -> CaseAlternative -> r) ->
403− (S.Set Ident -> DoNotationElement -> r) ->
404− ( S.Set Ident -> Declaration -> r
405− , S.Set Ident -> Expr -> r
406− , S.Set Ident -> Binder -> r
407− , S.Set Ident -> CaseAlternative -> r
408− , S.Set Ident -> DoNotationElement -> r)
464+everythingWithScope
465+ :: forall r
466+ . (Monoid r)
467+ => (S.Set Ident -> Declaration -> r)
468+ -> (S.Set Ident -> Expr -> r)
469+ -> (S.Set Ident -> Binder -> r)
470+ -> (S.Set Ident -> CaseAlternative -> r)
471+ -> (S.Set Ident -> DoNotationElement -> r)
472+ -> ( S.Set Ident -> Declaration -> r
473+ , S.Set Ident -> Expr -> r
474+ , S.Set Ident -> Binder -> r
475+ , S.Set Ident -> CaseAlternative -> r
476+ , S.Set Ident -> DoNotationElement -> r
477+ )
409478everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
410479 where
411480 -- Avoid importing Data.Monoid and getting shadowed names above
412481 (<>) = mappend
413482
483+ f'' :: S.Set Ident -> Declaration -> r
414484 f'' s a = f s a <> f' s a
415485
486+ f' :: S.Set Ident -> Declaration -> r
416487 f' s (DataBindingGroupDeclaration ds) =
417488 let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))
418489 in foldMap (f'' s') ds
@@ -431,15 +502,16 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
431502 f' s (PositionedDeclaration _ _ d) = f'' s d
432503 f' _ _ = mempty
433504
505+ g'' :: S.Set Ident -> Expr -> r
434506 g'' s a = g s a <> g' s a
435507
508+ g' :: S.Set Ident -> Expr -> r
509+ g' s (Literal l) = lit g'' s l
436510 g' s (UnaryMinus v1) = g'' s v1
437511 g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2
438512 g' s (Parens v1) = g'' s v1
439513 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v
440514 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
441− g' s (ArrayLiteral vs) = foldMap (g'' s) vs
442− g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs
443515 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
444516 g' s (Accessor _ v1) = g'' s v1
445517 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs
@@ -460,20 +532,28 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
460532 g' s (PositionedValue _ _ v1) = g'' s v1
461533 g' _ _ = mempty
462534
535+ h'' :: S.Set Ident -> Binder -> r
463536 h'' s a = h s a <> h' s a
464537
538+ h' :: S.Set Ident -> Binder -> r
539+ h' s (LiteralBinder l) = lit h'' s l
465540 h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs
466541 h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
467542 h' s (ParensInBinder b) = h'' s b
468− h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs
469− h' s (ArrayBinder bs) = foldMap (h'' s) bs
470543 h' s (NamedBinder name b1) = h'' (S.insert name s) b1
471544 h' s (PositionedBinder _ _ b1) = h'' s b1
472545 h' s (TypedBinder _ b1) = h'' s b1
473546 h' _ _ = mempty
474547
548+ lit :: (S.Set Ident -> a -> r) -> S.Set Ident -> Literal a -> r
549+ lit go s (ArrayLiteral as) = foldMap (go s) as
550+ lit go s (ObjectLiteral as) = foldMap (go s . snd) as
551+ lit _ _ _ = mempty
552+
553+ i'' :: S.Set Ident -> CaseAlternative -> r
475554 i'' s a = i s a <> i' s a
476555
556+ i' :: S.Set Ident -> CaseAlternative -> r
477557 i' s (CaseAlternative bs (Right val)) =
478558 let s' = S.union s (S.fromList (concatMap binderNames bs))
479559 in foldMap (h'' s) bs <> g'' s' val
@@ -481,8 +561,10 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
481561 let s' = S.union s (S.fromList (concatMap binderNames bs))
482562 in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs
483563
564+ j'' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)
484565 j'' s a = let (s', r) = j' s a in (s', j s a <> r)
485566
567+ j' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)
486568 j' s (DoNotationValue v) = (s, g'' s v)
487569 j' s (DoNotationBind b v) =
488570 let s' = S.union (S.fromList (binderNames b)) s
@@ -498,7 +580,15 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
498580 getDeclIdent (TypeDeclaration ident _) = Just ident
499581 getDeclIdent _ = Nothing
500582
501−accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
583+accumTypes
584+ :: (Monoid r)
585+ => (Type -> r)
586+ -> ( Declaration -> r
587+ , Expr -> r
588+ , Binder -> r
589+ , CaseAlternative -> r
590+ , DoNotationElement -> r
591+ )
502592accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
503593 where
504594 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)