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