1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeSynonymInstances #-}
7
8#if __GLASGOW_HASKELL__ >= 701
9{-# LANGUAGE DefaultSignatures #-}
10{-# LANGUAGE Trustworthy #-}
11#endif
12
13#if __GLASGOW_HASKELL__ >= 705
14{-# LANGUAGE PolyKinds #-}
15#endif
16
17#if __GLASGOW_HASKELL__ < 709
18{-# LANGUAGE OverlappingInstances #-}
19#endif
20
21{- |
22Module      :  Generics.Deriving.Uniplate
23Copyright   :  2011-2012 Universiteit Utrecht, University of Oxford
24License     :  BSD3
25
26Maintainer  :  generics@haskell.org
27Stability   :  experimental
28Portability :  non-portable
29
30Summary: Functions inspired by the Uniplate generic programming library,
31mostly implemented by Sean Leather.
32-}
33
34module Generics.Deriving.Uniplate (
35  -- * Generic Uniplate class
36    Uniplate(..)
37
38  -- * Derived functions
39  , uniplate
40  , universe
41  , rewrite
42  , rewriteM
43  , contexts
44  , holes
45  , para
46
47  -- * Default definitions
48  , childrendefault
49  , contextdefault
50  , descenddefault
51  , descendMdefault
52  , transformdefault
53  , transformMdefault
54
55  -- * Internal Uniplate class
56  , Uniplate'(..)
57
58  -- * Internal Context class
59  , Context'(..)
60  ) where
61
62
63import Generics.Deriving.Base
64
65import Control.Monad (liftM, liftM2)
66import GHC.Exts (build)
67
68--------------------------------------------------------------------------------
69-- Generic Uniplate
70--------------------------------------------------------------------------------
71
72class Uniplate' f b where
73  children'  :: f a -> [b]
74  descend'   :: (b -> b) -> f a -> f a
75  descendM'  :: Monad m => (b -> m b) -> f a -> m (f a)
76  transform' :: (b -> b) -> f a -> f a
77  transformM'  :: Monad m => (b -> m b) -> f a -> m (f a)
78
79instance Uniplate' U1 a where
80  children' U1 = []
81  descend' _ U1 = U1
82  descendM' _ U1 = return U1
83  transform' _ U1 = U1
84  transformM' _ U1 = return U1
85
86instance
87#if __GLASGOW_HASKELL__ >= 709
88    {-# OVERLAPPING #-}
89#endif
90    (Uniplate a) => Uniplate' (K1 i a) a where
91  children' (K1 a) = [a]
92  descend' f (K1 a) = K1 (f a)
93  descendM' f (K1 a) = liftM K1 (f a)
94  transform' f (K1 a) = K1 (transform f a)
95  transformM' f (K1 a) = liftM K1 (transformM f a)
96
97instance
98#if __GLASGOW_HASKELL__ >= 709
99    {-# OVERLAPPABLE #-}
100#endif
101    Uniplate' (K1 i a) b where
102  children' (K1 _) = []
103  descend' _ (K1 a) = K1 a
104  descendM' _ (K1 a) = return (K1 a)
105  transform' _ (K1 a) = K1 a
106  transformM' _ (K1 a) = return (K1 a)
107
108instance (Uniplate' f b) => Uniplate' (M1 i c f) b where
109  children' (M1 a) = children' a
110  descend' f (M1 a) = M1 (descend' f a)
111  descendM' f (M1 a) = liftM M1 (descendM' f a)
112  transform' f (M1 a) = M1 (transform' f a)
113  transformM' f (M1 a) = liftM M1 (transformM' f a)
114
115instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where
116  children' (L1 a) = children' a
117  children' (R1 a) = children' a
118  descend' f (L1 a) = L1 (descend' f a)
119  descend' f (R1 a) = R1 (descend' f a)
120  descendM' f (L1 a) = liftM L1 (descendM' f a)
121  descendM' f (R1 a) = liftM R1 (descendM' f a)
122  transform' f (L1 a) = L1 (transform' f a)
123  transform' f (R1 a) = R1 (transform' f a)
124  transformM' f (L1 a) = liftM L1 (transformM' f a)
125  transformM' f (R1 a) = liftM R1 (transformM' f a)
126
127instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where
128  children' (a :*: b) = children' a ++ children' b
129  descend' f (a :*: b) = descend' f a :*: descend' f b
130  descendM' f (a :*: b) = liftM2 (:*:) (descendM' f a) (descendM' f b)
131  transform' f (a :*: b) = transform' f a :*: transform' f b
132  transformM' f (a :*: b) = liftM2 (:*:) (transformM' f a) (transformM' f b)
133
134
135-- Context' is a separate class from Uniplate' since it uses special product
136-- instances, but the context function still appears in Uniplate.
137class Context' f b where
138  context' :: f a -> [b] -> f a
139
140instance Context' U1 b where
141  context' U1 _ = U1
142
143instance
144#if __GLASGOW_HASKELL__ >= 709
145    {-# OVERLAPPING #-}
146#endif
147    Context' (K1 i a) a where
148  context' _      []    = error "Generics.Deriving.Uniplate.context: empty list"
149  context' (K1 _) (c:_) = K1 c
150
151instance
152#if __GLASGOW_HASKELL__ >= 709
153    {-# OVERLAPPABLE #-}
154#endif
155    Context' (K1 i a) b where
156  context' (K1 a) _ = K1 a
157
158instance (Context' f b) => Context' (M1 i c f) b where
159  context' (M1 a) cs = M1 (context' a cs)
160
161instance (Context' f b, Context' g b) => Context' (f :+: g) b where
162  context' (L1 a) cs = L1 (context' a cs)
163  context' (R1 a) cs = R1 (context' a cs)
164
165instance
166#if __GLASGOW_HASKELL__ >= 709
167    {-# OVERLAPPING #-}
168#endif
169    (Context' g a) => Context' (M1 i c (K1 j a) :*: g) a where
170  context' _                 []     = error "Generics.Deriving.Uniplate.context: empty list"
171  context' (M1 (K1 _) :*: b) (c:cs) = M1 (K1 c) :*: context' b cs
172
173instance
174#if __GLASGOW_HASKELL__ >= 709
175    {-# OVERLAPPABLE #-}
176#endif
177    (Context' g b) => Context' (f :*: g) b where
178  context' (a :*: b) cs = a :*: context' b cs
179
180
181class Uniplate a where
182  children :: a -> [a]
183#if __GLASGOW_HASKELL__ >= 701
184  default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a]
185  children = childrendefault
186#endif
187
188  context :: a -> [a] -> a
189#if __GLASGOW_HASKELL__ >= 701
190  default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a
191  context = contextdefault
192#endif
193
194  descend :: (a -> a) -> a -> a
195#if __GLASGOW_HASKELL__ >= 701
196  default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a
197  descend = descenddefault
198#endif
199
200  descendM :: Monad m => (a -> m a) -> a -> m a
201#if __GLASGOW_HASKELL__ >= 701
202  default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a
203  descendM = descendMdefault
204#endif
205
206  transform :: (a -> a) -> a -> a
207#if __GLASGOW_HASKELL__ >= 701
208  default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a
209  transform = transformdefault
210#endif
211
212  transformM :: Monad m => (a -> m a) -> a -> m a
213#if __GLASGOW_HASKELL__ >= 701
214  default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a
215  transformM = transformMdefault
216#endif
217
218childrendefault :: (Generic a, Uniplate' (Rep a) a) => a -> [a]
219childrendefault = children' . from
220
221contextdefault :: (Generic a, Context' (Rep a) a) => a -> [a] -> a
222contextdefault x cs = to (context' (from x) cs)
223
224descenddefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a
225descenddefault f = to . descend' f . from
226
227descendMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a
228descendMdefault f = liftM to . descendM' f . from
229
230transformdefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a
231transformdefault f = f . to . transform' f . from
232
233transformMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a
234transformMdefault f = liftM to . transformM' f . from
235
236
237-- Derived functions (mostly copied from Neil Michell's code)
238
239uniplate :: Uniplate a => a -> ([a], [a] -> a)
240uniplate a = (children a, context a)
241
242universe :: Uniplate a => a -> [a]
243universe a = build (go a)
244  where
245    go x cons nil = cons x $ foldr ($) nil $ map (\c -> go c cons) $ children x
246
247rewrite :: Uniplate a => (a -> Maybe a) -> a -> a
248rewrite f = transform g
249  where
250    g x = maybe x (rewrite f) (f x)
251
252rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a
253rewriteM f = transformM g
254  where
255    g x = f x >>= maybe (return x) (rewriteM f)
256
257contexts :: Uniplate a => a -> [(a, a -> a)]
258contexts a = (a, id) : f (holes a)
259  where
260    f xs = [ (ch2, ctx1 . ctx2)
261           | (ch1, ctx1) <- xs
262           , (ch2, ctx2) <- contexts ch1]
263
264holes :: Uniplate a => a -> [(a, a -> a)]
265holes a = uncurry f (uniplate a)
266  where
267    f []     _   = []
268    f (x:xs) gen = (x, gen . (:xs)) : f xs (gen . (x:))
269
270para :: Uniplate a => (a -> [r] -> r) -> a -> r
271para f x = f x $ map (para f) $ children x
272
273
274-- Base types instances
275instance Uniplate Bool where
276  children _ = []
277  context x _ = x
278  descend _ = id
279  descendM _ = return
280  transform = id
281  transformM _ = return
282instance Uniplate Char where
283  children _ = []
284  context x _ = x
285  descend _ = id
286  descendM _ = return
287  transform = id
288  transformM _ = return
289instance Uniplate Double where
290  children _ = []
291  context x _ = x
292  descend _ = id
293  descendM _ = return
294  transform = id
295  transformM _ = return
296instance Uniplate Float where
297  children _ = []
298  context x _ = x
299  descend _ = id
300  descendM _ = return
301  transform = id
302  transformM _ = return
303instance Uniplate Int where
304  children _ = []
305  context x _ = x
306  descend _ = id
307  descendM _ = return
308  transform = id
309  transformM _ = return
310instance Uniplate () where
311  children _ = []
312  context x _ = x
313  descend _ = id
314  descendM _ = return
315  transform = id
316  transformM _ = return
317
318-- Tuple instances
319instance Uniplate (b,c) where
320  children _ = []
321  context x _ = x
322  descend _ = id
323  descendM _ = return
324  transform = id
325  transformM _ = return
326instance Uniplate (b,c,d) where
327  children _ = []
328  context x _ = x
329  descend _ = id
330  descendM _ = return
331  transform = id
332  transformM _ = return
333instance Uniplate (b,c,d,e) where
334  children _ = []
335  context x _ = x
336  descend _ = id
337  descendM _ = return
338  transform = id
339  transformM _ = return
340instance Uniplate (b,c,d,e,f) where
341  children _ = []
342  context x _ = x
343  descend _ = id
344  descendM _ = return
345  transform = id
346  transformM _ = return
347instance Uniplate (b,c,d,e,f,g) where
348  children _ = []
349  context x _ = x
350  descend _ = id
351  descendM _ = return
352  transform = id
353  transformM _ = return
354instance Uniplate (b,c,d,e,f,g,h) where
355  children _ = []
356  context x _ = x
357  descend _ = id
358  descendM _ = return
359  transform = id
360  transformM _ = return
361
362-- Parameterized type instances
363instance Uniplate (Maybe a) where
364  children _ = []
365  context x _ = x
366  descend _ = id
367  descendM _ = return
368  transform = id
369  transformM _ = return
370instance Uniplate (Either a b) where
371  children _ = []
372  context x _ = x
373  descend _ = id
374  descendM _ = return
375  transform = id
376  transformM _ = return
377
378instance Uniplate [a] where
379  children []    = []
380  children (_:t) = [t]
381  context _     []    = error "Generics.Deriving.Uniplate.context: empty list"
382  context []    _     = []
383  context (h:_) (t:_) = h:t
384  descend _ []    = []
385  descend f (h:t) = h:f t
386  descendM _ []    = return []
387  descendM f (h:t) = f t >>= \t' -> return (h:t')
388  transform f []    = f []
389  transform f (h:t) = f (h:transform f t)
390  transformM f []    = f []
391  transformM f (h:t) = transformM f t >>= \t' -> f (h:t')
392
393