1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
module Language.Fiddle.Ast.Internal.Instances.Walk (Walk (..), GWalk (..), walk_, WalkContinuation (..)) where
import Data.Typeable
import GHC.Generics
-- | Like walk, but assumes no local state and always continue
walk_ ::
(Monad m, Traversable f, Typeable f, Typeable a, Walk t) =>
(forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> m ()) ->
t f a ->
m ()
walk_ fn t = walk (\t _ -> fn t >> return (Continue ())) t ()
data WalkContinuation s where
Continue :: s -> WalkContinuation s
Stop :: WalkContinuation s
class (Typeable t) => Walk t where
walk ::
(Monad m, Traversable f, Typeable f, Typeable a) =>
(forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> s -> m (WalkContinuation s)) ->
t f a ->
s ->
m ()
default walk ::
(GWalk (Rep (t f a)) f a, Generic (t f a), Monad m, Traversable f, Typeable f, Typeable a) =>
(forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> s -> m (WalkContinuation s)) ->
t f a ->
s ->
m ()
walk fn = gwalk fn . from
class GWalk r f a where
gwalk ::
(Monad m, Typeable f, Typeable a, Traversable f) =>
(forall t'. (Walk t', Typeable t') => t' f a -> s -> m (WalkContinuation s)) ->
r x ->
s ->
m ()
instance (Traversable f, GWalk t f a) => (GWalk (M1 i c t) f a) where
gwalk fn (M1 a) = gwalk fn a
instance
( Traversable f,
GWalk l f a,
GWalk r f a
) =>
(GWalk (l :+: r) f a)
where
gwalk fn (L1 l) = gwalk fn l
gwalk fn (R1 l) = gwalk fn l
instance
( Traversable f,
GWalk l f a,
GWalk r f a
) =>
(GWalk (l :*: r) f a)
where
gwalk fn (l :*: r) s = gwalk fn l s >> gwalk fn r s
instance
( Traversable f,
Walk t
) =>
GWalk (Rec0 (t f a)) f a
where
gwalk fn (K1 k) s = do
( \case
Continue s' -> walk fn k s'
_ -> return ()
)
=<< fn k s
instance
( Traversable f,
Traversable func,
Walk t
) =>
GWalk (Rec0 (func (t f a))) f a
where
gwalk fn (K1 fk) s = do
mapM_
( \tfa -> do
( \case
Continue s' -> walk fn tfa s'
_ -> return ()
)
=<< fn tfa s
)
fk
instance GWalk (Rec0 q) f a where
gwalk _ _ _ = return ()
|
