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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
{- |
/DEPRECATED/: Use "Data.Generics.Uniplate.Operations" instead.
This is the main Uniplate module, which defines all the essential operations
in a Haskell 98 compatible manner.
Most functions have an example of a possible use for the function.
To illustate, I have used the @Expr@ type as below:
> data Expr = Val Int
> | Neg Expr
> | Add Expr Expr
-}
module Data.Generics.UniplateStr
{- DEPRECATED "Use Data.Generics.Uniplate.Operations instead" -}
(
module Data.Generics.UniplateStr,
module Data.Generics.Str
) where
import Control.Monad hiding (mapM)
import Data.Traversable
import Prelude hiding (mapM)
import Data.Generics.Uniplate.Internal.Utils
import Data.Generics.Str
-- * The Class
-- | The type of replacing all the children of a node
--
-- Taking a value, the function should return all the immediate children
-- of the same type, and a function to replace them.
type UniplateType on = on -> (Str on, Str on -> on)
-- | The standard Uniplate class, all operations require this.
class Uniplate on where
-- | The underlying method in the class.
--
-- Given @uniplate x = (cs, gen)@
--
-- @cs@ should be a @Str on@, constructed of @Zero@, @One@ and @Two@,
-- containing all @x@'s direct children of the same type as @x@. @gen@
-- should take a @Str on@ with exactly the same structure as @cs@,
-- and generate a new element with the children replaced.
--
-- Example instance:
--
-- > instance Uniplate Expr where
-- > uniplate (Val i ) = (Zero , \Zero -> Val i )
-- > uniplate (Neg a ) = (One a , \(One a) -> Neg a )
-- > uniplate (Add a b) = (Two (One a) (One b), \(Two (One a) (One b)) -> Add a b)
uniplate :: UniplateType on
-- | Compatibility method, for direct users of the old list-based 'uniplate' function
uniplateList :: Uniplate on => on -> ([on], [on] -> on)
uniplateList x = (c, b . d)
where
(a,b) = uniplate x
(c,d) = strStructure a
-- * The Operations
-- ** Queries
-- | Get all the children of a node, including itself and all children.
--
-- > universe (Add (Val 1) (Neg (Val 2))) =
-- > [Add (Val 1) (Neg (Val 2)), Val 1, Neg (Val 2), Val 2]
--
-- This method is often combined with a list comprehension, for example:
--
-- > vals x = [i | Val i <- universe x]
universe :: Uniplate on => on -> [on]
universe x = builder f
where
f cons nil = g cons nil (One x) nil
g cons nil Zero res = res
g cons nil (One x) res = x `cons` g cons nil (fst $ uniplate x) res
g cons nil (Two x y) res = g cons nil x (g cons nil y res)
-- | Get the direct children of a node. Usually using 'universe' is more appropriate.
--
-- @children = fst . 'uniplate'@
children :: Uniplate on => on -> [on]
children x = builder f
where
f cons nil = g cons nil (fst $ uniplate x) nil
g cons nil Zero res = res
g cons nil (One x) res = x `cons` res
g cons nil (Two x y) res = g cons nil x (g cons nil y res)
-- ** Transformations
-- | Transform every element in the tree, in a bottom-up manner.
--
-- For example, replacing negative literals with literals:
--
-- > negLits = transform f
-- > where f (Neg (Lit i)) = Lit (negate i)
-- > f x = x
transform :: Uniplate on => (on -> on) -> on -> on
transform f = f . descend (transform f)
-- | Monadic variant of 'transform'
transformM :: (Monad m, Uniplate on) => (on -> m on) -> on -> m on
transformM f x = f =<< descendM (transformM f) x
-- | Rewrite by applying a rule everywhere you can. Ensures that the rule cannot
-- be applied anywhere in the result:
--
-- > propRewrite r x = all (isNothing . r) (universe (rewrite r x))
--
-- Usually 'transform' is more appropriate, but 'rewrite' can give better
-- compositionality. Given two single transformations @f@ and @g@, you can
-- construct @f `mplus` g@ which performs both rewrites until a fixed point.
rewrite :: Uniplate on => (on -> Maybe on) -> on -> on
rewrite f = transform g
where g x = maybe x (rewrite f) (f x)
-- | Monadic variant of 'rewrite'
rewriteM :: (Monad m, Uniplate on) => (on -> m (Maybe on)) -> on -> m on
rewriteM f = transformM g
where g x = f x >>= maybe (return x) (rewriteM f)
-- | Perform a transformation on all the immediate children, then combine them back.
-- This operation allows additional information to be passed downwards, and can be
-- used to provide a top-down transformation.
descend :: Uniplate on => (on -> on) -> on -> on
descend f x = generate $ fmap f current
where (current, generate) = uniplate x
-- | Monadic variant of 'descend'
descendM :: (Monad m, Uniplate on) => (on -> m on) -> on -> m on
descendM f x = liftM generate $ mapM f current
where (current, generate) = uniplate x
-- ** Others
-- | Return all the contexts and holes.
--
-- > propUniverse x = universe x == map fst (contexts x)
-- > propId x = all (== x) [b a | (a,b) <- contexts x]
contexts :: Uniplate on => on -> [(on, on -> on)]
contexts x = (x,id) : f (holes x)
where
f xs = [ (y, ctx . context)
| (child, ctx) <- xs
, (y, context) <- contexts child]
-- | The one depth version of 'contexts'
--
-- > propChildren x = children x == map fst (holes x)
-- > propId x = all (== x) [b a | (a,b) <- holes x]
holes :: Uniplate on => on -> [(on, on -> on)]
holes x = uncurry f (uniplate x)
where f Zero _ = []
f (One i) generate = [(i, generate . One)]
f (Two l r) gen = f l (gen . (\i -> Two i r))
++ f r (gen . (\i -> Two l i))
-- | Perform a fold-like computation on each value,
-- technically a paramorphism
para :: Uniplate on => (on -> [r] -> r) -> on -> r
para op x = op x $ map (para op) $ children x
|
