1{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} 2----------------------------------------------------------------------------- 3-- | 4-- Module : Data.Generics.Twins 5-- Copyright : (c) The University of Glasgow, CWI 2001--2004 6-- License : BSD-style (see the LICENSE file) 7-- 8-- Maintainer : generics@haskell.org 9-- Stability : experimental 10-- Portability : non-portable (local universal quantification) 11-- 12-- \"Scrap your boilerplate\" --- Generic programming in Haskell 13-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module 14-- provides support for multi-parameter traversal, which is also 15-- demonstrated with generic operations like equality. 16-- 17----------------------------------------------------------------------------- 18 19module Data.Generics.Twins ( 20 21 -- * Generic folds and maps that also accumulate 22 gfoldlAccum, 23 gmapAccumT, 24 gmapAccumM, 25 gmapAccumQl, 26 gmapAccumQr, 27 gmapAccumQ, 28 gmapAccumA, 29 30 -- * Mapping combinators for twin traversal 31 gzipWithT, 32 gzipWithM, 33 gzipWithQ, 34 35 -- * Typical twin traversals 36 geq, 37 gzip, 38 gcompare 39 40 ) where 41 42 43------------------------------------------------------------------------------ 44 45#ifdef __HADDOCK__ 46import Prelude 47#endif 48import Data.Data 49import Data.Generics.Aliases 50 51#ifdef __GLASGOW_HASKELL__ 52import Prelude hiding ( GT ) 53#endif 54 55#if __GLASGOW_HASKELL__ < 709 56import Control.Applicative (Applicative(..)) 57import Data.Monoid ( mappend, mconcat ) 58#endif 59 60------------------------------------------------------------------------------ 61 62 63------------------------------------------------------------------------------ 64-- 65-- Generic folds and maps that also accumulate 66-- 67------------------------------------------------------------------------------ 68 69{-------------------------------------------------------------- 70 71A list map can be elaborated to perform accumulation. 72In the same sense, we can elaborate generic maps over terms. 73 74We recall the type of map: 75map :: (a -> b) -> [a] -> [b] 76 77We recall the type of an accumulating map (see Data.List): 78mapAccumL :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c]) 79 80Applying the same scheme we obtain an accumulating gfoldl. 81 82--------------------------------------------------------------} 83 84-- | gfoldl with accumulation 85 86gfoldlAccum :: Data d 87 => (forall e r. Data e => a -> c (e -> r) -> e -> (a, c r)) 88 -> (forall g. a -> g -> (a, c g)) 89 -> a -> d -> (a, c d) 90 91gfoldlAccum k z a0 d = unA (gfoldl k' z' d) a0 92 where 93 k' c y = A (\a -> let (a', c') = unA c a in k a' c' y) 94 z' f = A (\a -> z a f) 95 96 97-- | A type constructor for accumulation 98newtype A a c d = A { unA :: a -> (a, c d) } 99 100 101-- | gmapT with accumulation 102gmapAccumT :: Data d 103 => (forall e. Data e => a -> e -> (a,e)) 104 -> a -> d -> (a, d) 105gmapAccumT f a0 d0 = let (a1, d1) = gfoldlAccum k z a0 d0 106 in (a1, unID d1) 107 where 108 k a (ID c) d = let (a',d') = f a d 109 in (a', ID (c d')) 110 z a x = (a, ID x) 111 112 113-- | Applicative version 114gmapAccumA :: forall b d a. (Data d, Applicative a) 115 => (forall e. Data e => b -> e -> (b, a e)) 116 -> b -> d -> (b, a d) 117gmapAccumA f a0 d0 = gfoldlAccum k z a0 d0 118 where 119 k :: forall d' e. (Data d') => 120 b -> a (d' -> e) -> d' -> (b, a e) 121 k a c d = let (a',d') = f a d 122 c' = c <*> d' 123 in (a', c') 124 z :: forall t c a'. (Applicative a') => 125 t -> c -> (t, a' c) 126 z a x = (a, pure x) 127 128 129-- | gmapM with accumulation 130gmapAccumM :: (Data d, Monad m) 131 => (forall e. Data e => a -> e -> (a, m e)) 132 -> a -> d -> (a, m d) 133gmapAccumM f = gfoldlAccum k z 134 where 135 k a c d = let (a',d') = f a d 136 in (a', d' >>= \d'' -> c >>= \c' -> return (c' d'')) 137 z a x = (a, return x) 138 139 140-- | gmapQl with accumulation 141gmapAccumQl :: Data d 142 => (r -> r' -> r) 143 -> r 144 -> (forall e. Data e => a -> e -> (a,r')) 145 -> a -> d -> (a, r) 146gmapAccumQl o r0 f a0 d0 = let (a1, r1) = gfoldlAccum k z a0 d0 147 in (a1, unCONST r1) 148 where 149 k a (CONST c) d = let (a', r) = f a d 150 in (a', CONST (c `o` r)) 151 z a _ = (a, CONST r0) 152 153 154-- | gmapQr with accumulation 155gmapAccumQr :: Data d 156 => (r' -> r -> r) 157 -> r 158 -> (forall e. Data e => a -> e -> (a,r')) 159 -> a -> d -> (a, r) 160gmapAccumQr o r0 f a0 d0 = let (a1, l) = gfoldlAccum k z a0 d0 161 in (a1, unQr l r0) 162 where 163 k a (Qr c) d = let (a',r') = f a d 164 in (a', Qr (\r -> c (r' `o` r))) 165 z a _ = (a, Qr id) 166 167 168-- | gmapQ with accumulation 169gmapAccumQ :: Data d 170 => (forall e. Data e => a -> e -> (a,q)) 171 -> a -> d -> (a, [q]) 172gmapAccumQ f = gmapAccumQr (:) [] f 173 174 175 176------------------------------------------------------------------------------ 177-- 178-- Helper type constructors 179-- 180------------------------------------------------------------------------------ 181 182 183-- | The identity type constructor needed for the definition of gmapAccumT 184newtype ID x = ID { unID :: x } 185 186 187-- | The constant type constructor needed for the definition of gmapAccumQl 188newtype CONST c a = CONST { unCONST :: c } 189 190 191-- | The type constructor needed for the definition of gmapAccumQr 192newtype Qr r a = Qr { unQr :: r -> r } 193 194 195 196------------------------------------------------------------------------------ 197-- 198-- Mapping combinators for twin traversal 199-- 200------------------------------------------------------------------------------ 201 202 203-- | Twin map for transformation 204gzipWithT :: GenericQ (GenericT) -> GenericQ (GenericT) 205gzipWithT f x y = case gmapAccumT perkid funs y of 206 ([], c) -> c 207 _ -> error "gzipWithT" 208 where 209 perkid a d = (tail a, unGT (head a) d) 210 funs = gmapQ (\k -> GT (f k)) x 211 212 213 214-- | Twin map for monadic transformation 215gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m) 216gzipWithM f x y = case gmapAccumM perkid funs y of 217 ([], c) -> c 218 _ -> error "gzipWithM" 219 where 220 perkid a d = (tail a, unGM (head a) d) 221 funs = gmapQ (\k -> GM (f k)) x 222 223 224-- | Twin map for queries 225gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) 226gzipWithQ f x y = case gmapAccumQ perkid funs y of 227 ([], r) -> r 228 _ -> error "gzipWithQ" 229 where 230 perkid a d = (tail a, unGQ (head a) d) 231 funs = gmapQ (\k -> GQ (f k)) x 232 233 234 235------------------------------------------------------------------------------ 236-- 237-- Typical twin traversals 238-- 239------------------------------------------------------------------------------ 240 241-- | Generic equality: an alternative to \"deriving Eq\" 242geq :: Data a => a -> a -> Bool 243 244{- 245 246Testing for equality of two terms goes like this. Firstly, we 247establish the equality of the two top-level datatype 248constructors. Secondly, we use a twin gmap combinator, namely tgmapQ, 249to compare the two lists of immediate subterms. 250 251(Note for the experts: the type of the worker geq' is rather general 252but precision is recovered via the restrictive type of the top-level 253operation geq. The imprecision of geq' is caused by the type system's 254unability to express the type equivalence for the corresponding 255couples of immediate subterms from the two given input terms.) 256 257-} 258 259geq x0 y0 = geq' x0 y0 260 where 261 geq' :: GenericQ (GenericQ Bool) 262 geq' x y = (toConstr x == toConstr y) 263 && and (gzipWithQ geq' x y) 264 265 266-- | Generic zip controlled by a function with type-specific branches 267gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe) 268-- See testsuite/.../Generics/gzip.hs for an illustration 269gzip f = go 270 where 271 go :: GenericQ (GenericM Maybe) 272 go x y = 273 f x y 274 `orElse` 275 if toConstr x == toConstr y 276 then gzipWithM go x y 277 else Nothing 278 279-- | Generic comparison: an alternative to \"deriving Ord\" 280gcompare :: Data a => a -> a -> Ordering 281gcompare = gcompare' 282 where 283 gcompare' :: (Data a, Data b) => a -> b -> Ordering 284 gcompare' x y 285 = let repX = constrRep $ toConstr x 286 repY = constrRep $ toConstr y 287 in 288 case (repX, repY) of 289 (AlgConstr nX, AlgConstr nY) -> 290 nX `compare` nY `mappend` mconcat (gzipWithQ gcompare' x y) 291 (IntConstr iX, IntConstr iY) -> iX `compare` iY 292 (FloatConstr rX, FloatConstr rY) -> rX `compare` rY 293 (CharConstr cX, CharConstr cY) -> cX `compare` cY 294 _ -> error "type incompatibility in gcompare" 295