diff --git a/Data/Generics/Biplate.hs b/Data/Generics/Biplate.hs --- a/Data/Generics/Biplate.hs +++ b/Data/Generics/Biplate.hs @@ -3,7 +3,7 @@ {- | Requires multi-parameter type classes, so is no longer Haskell 98. These operations - are easier to use and construct than the equivalent @Data.Generics.UniplateOn@ methods, + are easier to use and construct than the equivalent "Data.Generics.UniplateStrOn" methods, but perform the same operation. It is recommended that instead of importing this module, you import one of the following @@ -19,11 +19,12 @@ -} module Data.Generics.Biplate( - module Data.Generics.UniplateOn, + module Data.Generics.UniplateStrOn, module Data.Generics.Biplate ) where -import Data.Generics.UniplateOn +import Data.Generics.UniplateStrOn +import Data.Generics.Str -- * The Class @@ -34,6 +35,15 @@ biplate :: BiplateType from to +-- | Compatibility method, for direct users of the 'biplate' function +biplateList :: Biplate from to => from -> ([to], [to] -> from) +biplateList x = (c, b . d) + where + (a,b) = biplate x + (c,d) = strStructure a + + + -- * The Operations -- ** Queries @@ -76,3 +86,7 @@ contextsBi:: Biplate from to => from -> [(to, to -> from)] contextsBi = contextsOn biplate + + +holesBi:: Biplate from to => from -> [(to, to -> from)] +holesBi = holesOn biplate diff --git a/Data/Generics/Compos.hs b/Data/Generics/Compos.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/Compos.hs @@ -0,0 +1,54 @@ +{-| + Compos compatibility layer. This module serves as a drop-in + replacement in some situations for some of the Compos operations. + Only the single-type traversals are supported, on normal + algebraic data types. Must be used in conjunction with + "Data.Generics.UniplateStr". + + From the paper: \"A Pattern for Almost Compositional Functions\" + by Bjorn Bringert and Aarne Ranta. + + * + + * +-} + +module Data.Generics.Compos where + +import Control.Monad +import Data.Monoid +import Data.Generics.UniplateStr + + +-- | If you want to keep an existing type class +class Uniplate a => Compos a where + + +-- | @composOp == 'descend'@ +composOp :: Uniplate a => (a -> a) -> a -> a +composOp = descend + + +-- | @composOpM == 'descendM'@ +composOpM :: (Uniplate a, Monad m) => (a -> m a) -> a -> m a +composOpM = descendM + + +-- | @composOpM_ == 'composOpFold' (return ()) (>>)@ +composOpM_ :: (Uniplate a, Monad m) => (a -> m ()) -> a -> m () +composOpM_ = composOpFold (return ()) (>>) + + +-- | @composOpMonoid = 'composOpFold' mempty mappend@ +composOpMonoid :: (Uniplate a, Monoid m) => (a -> m) -> a -> m +composOpMonoid = composOpFold mempty mappend + + +-- | @composOpMPlus = 'composOpFold' mzero mplus@ +composOpMPlus :: (Uniplate a, MonadPlus m) => (a -> m b) -> a -> m b +composOpMPlus = composOpFold mzero mplus + + +-- | Probably replace with 'universe', perhaps 'para' +composOpFold :: Uniplate a => b -> (b -> b -> b) -> (a -> b) -> a -> b +composOpFold zero combine f = foldr combine zero . map f . children diff --git a/Data/Generics/PlateData.hs b/Data/Generics/PlateData.hs --- a/Data/Generics/PlateData.hs +++ b/Data/Generics/PlateData.hs @@ -14,6 +14,7 @@ import Data.Generics.Biplate import Data.Generics.PlateInternal +import Data.Generics.Str import Data.Generics import Data.Maybe import Data.List @@ -38,7 +39,7 @@ start -> find -> Box find -#if __GLASGOW_HASKELL_COMPILER__ < 606 +#if __GLASGOW_HASKELL__ < 606 -- GHC 6.4.2 does not export typeRepKey, so we can't do the trick -- as efficiently, so we just give up and revert to always following @@ -93,14 +94,14 @@ instance (Data a, Typeable a) => Uniplate a where - uniplate = \x -> fromCC (collect_generate (fromBox answer) x) + uniplate = collect_generate (fromBox answer) where answer :: Box a answer = containsMatch (undefined :: a) (undefined :: a) instance (Data a, Data b, Uniplate b, Typeable a, Typeable b) => Biplate a b where - biplate = \x -> fromCC (collect_generate_self (fromBox answer) x) + biplate = collect_generate_self (fromBox answer) where answer :: Box b answer = containsMatch (undefined :: a) (undefined :: b) @@ -108,11 +109,7 @@ newtype C x a = C {fromC :: CC x a} -type CC x a = ([x] -> [x], [x] -> (a, [x])) - - -fromCC :: CC x a -> ([x], [x] -> a) -fromCC (a, b) = (a [], \i -> fst (b i)) +type CC x a = (Str x, Str x -> a) collect_generate_self :: (Data on, Data with, Typeable on, Typeable with) => @@ -120,9 +117,9 @@ collect_generate_self oracle x = res where res = case oracle x of - Hit y -> ((y:), \(x:xs) -> (unsafeCast x, xs)) + Hit y -> (One y, \(One x) -> unsafeCast x) Follow -> collect_generate oracle x - Miss -> (id, \res -> (x,res)) + Miss -> (Zero, \_ -> x) collect_generate :: (Data on, Data with, Typeable on, Typeable with) => @@ -131,34 +128,7 @@ where -- forall a b . Data a => C with (a -> b) -> a -> C with b combine (C (c,g)) x = case collect_generate_self oracle x of - (c2, g2) -> C (c . c2, regen g2) - where - regen g2 i = case g i of - (x2,i2) -> case g2 i2 of - (y2,i3) -> (x2 y2, i3) - - -- forall g . g -> C with g - create x = C (id, \res -> (x, res)) - - - - - -{- -OLD VERSION USING TWO SEPARATE TRAVERSALS - -collect_generate :: (Data on, Uniplate with, Typeable on, Typeable with) => on -> ([with],[with] -> on) -collect_generate item = (collect, generate) - where - collect = concat $ gmapQ getChildrenEx item + (c2, g2) -> C (Two c c2, \(Two c' c2') -> g c' (g2 c2')) - generate xs = evalState (gmapM f item) xs - where - f x = do - ys <- get - let (as,bs) = splitAt (length col) ys - put bs - return $ gen as - where - (col,gen) = replaceChildrenEx x --} + -- forall g . g -> C with g + create x = C (Zero, \_ -> x) diff --git a/Data/Generics/PlateDirect.hs b/Data/Generics/PlateDirect.hs --- a/Data/Generics/PlateDirect.hs +++ b/Data/Generics/PlateDirect.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {- | This module supplies a method for writing 'Biplate' instances more easily. @@ -10,34 +10,32 @@ > data Expr = Var Int | Pos Expr String | Neg Expr | Add Expr Expr > data Stmt = Seq [Stmt] | Sel [Expr] | Let String Expr > - > instance PlateOne Expr where - > plateOne (Var x ) = plate Var |- x - > plateOne (Pos x y) = plate Pos |* x |- y - > plateOne (Neg x ) = plate Neg |* x - > plateOne (Add x y) = plate Add |* x |* y + > instance Uniplate Expr where + > uniplate (Var x ) = plate Var |- x + > uniplate (Pos x y) = plate Pos |* x |- y + > uniplate (Neg x ) = plate Neg |* x + > uniplate (Add x y) = plate Add |* x |* y > - > instance PlateAll Expr Expr where - > plateAll = plateSelf + > instance Biplate Expr Expr where + > biplate = plateSelf > - > instance PlateOne Stmt where - > plateOne (Seq x ) = plate Seq ||* x - > plateOne (Sel x ) = plate Sel ||+ x - > plateOne (Let x y) = plate Let |- x |- y + > instance Uniplate Stmt where + > uniplate (Seq x ) = plate Seq ||* x + > uniplate (Sel x ) = plate Sel ||+ x + > uniplate (Let x y) = plate Let |- x |- y > - > instance PlateAll Stmt Stmt where - > plateAll = plateSelf + > instance Biplate Stmt Stmt where + > biplate = plateSelf > - > instance PlateAll Stmt Expr where - > plateAll (Seq x ) = plate Seq ||+ x - > plateAll (Sel x ) = plate Sel ||* x - > plateAll (Let x y) = plate Let |- x |* y + > instance Biplate Stmt Expr where + > biplate (Seq x ) = plate Seq ||+ x + > biplate (Sel x ) = plate Sel ||* x + > biplate (Let x y) = plate Let |- x |* y -} module Data.Generics.PlateDirect( module Data.Generics.Biplate, - -- * The Classes - PlateAll(..), PlateOne(..), -- * The Combinators plate, plateSelf, (|+), (|-), (|*), (||+), (||*) @@ -45,34 +43,11 @@ import Data.Generics.Biplate import Data.Generics.PlateInternal +import Data.Generics.Str import Data.Maybe -instance (Uniplate b, PlateAll a b) => Biplate a b where - biplate x = liftType $ plateAll x - -instance PlateOne a => Uniplate a where - uniplate x = liftType $ plateOne x - - -type Type from to = ([to] -> [to], [to] -> (from,[to])) - - -liftType :: Type from to -> ([to], [to] -> from) -liftType (a,b) = (a [], fst . b) - - --- | This class represents going from the container type to the target. --- --- If @from == to@ then use 'plateSelf', otherwise use 'plate' and the --- other combinators. -class PlateAll from to where - plateAll :: from -> Type from to - --- | This class is for when the target and container are the same type. -class PlateOne to where - plateOne :: to -> Type to to - +type Type from to = (Str to, Str to -> from) -- | The main combinator used to start the chain. -- @@ -80,62 +55,40 @@ -- -- > plate Ctor |- x == plate (Ctor x) plate :: from -> Type from to -plate f = (id, \xs -> (f,xs)) +plate f = (Zero, \_ -> f) -- | The field to the right is the target. (|*) :: Type (to -> from) to -> to -> Type from to -(|*) f item = (collect2,generate2) - where - (collectL,generateL) = f - collect2 = collectL . (item:) - generate2 xs = case generateL xs of - (a,(b:xs)) -> (a b, xs) +(|*) (xs,x_) y = (Two xs (One y),\(Two xs (One y)) -> x_ xs y) + -- | The field to the right may contain the target. -(|+) :: PlateAll item to => Type (item -> from) to -> item -> Type from to -(|+) f item = (collect2,generate2) - where - (collectL,generateL) = f - (collectR,generateR) = plateAll item - collect2 = collectL . collectR - generate2 xs = case generateL xs of - (a,xs) -> case generateR xs of - (b,xs) -> (a b, xs) +(|+) :: Biplate item to => Type (item -> from) to -> item -> Type from to +(|+) (xs,x_) y = case biplate y of + (ys,y_) -> (Two xs ys, \(Two xs ys) -> x_ xs (y_ ys)) -- | The field to the right /does not/ contain the target. (|-) :: Type (item -> from) to -> item -> Type from to -(|-) (collect,generate) item = (collect,\xs -> case generate xs of (r,xs) -> (r item, xs)) +(|-) (xs,x_) y = (xs,\xs -> x_ xs y) -- | The field to the right is a list of the type of the target (||*) :: Type ([to] -> from) to -> [to] -> Type from to -(||*) f item = (collect2,generate2) - where - (collectL,generateL) = f - collect2 = collectL . (item++) - generate2 xs = case generateL xs of - (a,xs) -> let (x1,x2) = splitAt (length item) xs - in (a x1,x2) +(||*) (xs,x_) y = (Two xs (listStr y), \(Two xs ys) -> x_ xs (strList ys)) -- | The field to the right is a list of types which may contain the target -(||+) :: PlateAll item to => Type ([item] -> from) to -> [item] -> Type from to -(||+) f item = (collect2,generate2) +(||+) :: Biplate item to => Type ([item] -> from) to -> [item] -> Type from to +(||+) (xs,x_) y = case plateListDiff y of + (ys,y_) -> (Two xs ys, \(Two xs ys) -> x_ xs (y_ ys)) where - (collectL,generateL) = f - (collectR,generateR) = plateListDiff item - collect2 = collectL . collectR - generate2 xs = case generateL xs of - (a,xs) -> case generateR xs of - (b,xs) -> (a b, xs) - plateListDiff [] = plate [] plateListDiff (x:xs) = plate (:) |+ x ||+ xs -- | Used for 'PlayAll' definitions where both types are the same. plateSelf :: to -> Type to to -plateSelf x = ((x:), \(x:xs) -> (x,xs)) +plateSelf x = (One x, \(One x) -> x) diff --git a/Data/Generics/PlateTypeable.hs b/Data/Generics/PlateTypeable.hs --- a/Data/Generics/PlateTypeable.hs +++ b/Data/Generics/PlateTypeable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} {- | This module supplies a method for writing 'Biplate' instances more easily. @@ -29,33 +29,29 @@ import Data.Generics.Biplate import Data.Generics.PlateInternal +import Data.Generics.Str import Data.Typeable import Data.Maybe instance (Typeable a, Typeable b, Uniplate b, PlateAll a b) => Biplate a b where - biplate x = liftType $ plateMore x + biplate = plateMore -- | This function is used to write a 'Uniplate' instance from a 'PlateAll' one -uniplateAll :: PlateAll a b => a -> ([b],[b] -> a) -uniplateAll a = liftType $ plateAll a - - - -type Type from to = ([to] -> [to], [to] -> (from,[to])) +uniplateAll :: PlateAll a b => a -> (Str b, Str b -> a) +uniplateAll = plateAll -liftType :: Type from to -> ([to], [to] -> from) -liftType (a,b) = (a [], fst . b) +type Type from to = (Str to, Str to -> from) plateMore :: (Typeable from, Typeable to, PlateAll from to) => from -> Type from to plateMore x = res where - res = case asTypeOf (cast x) (Just $ head $ fst res []) of + res = case asTypeOf (cast x) (Just $ strType $ fst res) of Nothing -> plateAll x - Just y -> ((y:), \(y:ys) -> (unsafeCast y, ys)) + Just y -> (One y, \(One y) -> unsafeCast y) -- | This class represents going from the container type to the target. @@ -71,25 +67,19 @@ -- -- > plate Ctor |- x == plate (Ctor x) plate :: from -> Type from to -plate f = (id, \xs -> (f,xs)) +plate x = (Zero, \_ -> x) -- | the field to the right may contain the target. (|+) :: (Typeable item, Typeable to, PlateAll item to) => Type (item -> from) to -> item -> Type from to -(|+) f item = (collect2,generate2) - where - (collectL,generateL) = f - (collectR,generateR) = plateMore item - collect2 = collectL . collectR - generate2 xs = case generateL xs of - (a,xs) -> case generateR xs of - (b,xs) -> (a b, xs) +(|+) (xs,x_) y = case plateMore y of + (ys,y_) -> (Two xs ys,\(Two xs ys) -> x_ xs (y_ ys)) -- | The field to the right /does not/ contain the target. -- This can be used as either an optimisation, or more commonly for excluding -- primitives such as Int. (|-) :: Type (item -> from) to -> item -> Type from to -(|-) (collect,generate) item = (collect,\xs -> case generate xs of (r,xs) -> (r item, xs)) +(|-) (xs,x_) y = (xs,\xs -> x_ xs y) -- * Instances diff --git a/Data/Generics/SYB.hs b/Data/Generics/SYB.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/SYB.hs @@ -0,0 +1,83 @@ +{-| + SYB compatibility layer. This module serves as a drop-in + replacement in some situations for some of the SYB operations. + Must be used in conjunction with "Data.Generics.Biplate". + + From the paper: \"Scrap your boilerplate: a practical design + pattern for generic programming\" by Ralf Lammel and Simon + Peyton Jones. + + * + + * + + * +-} + +module Data.Generics.SYB where + +import Data.Generics.Biplate + +-- | @gmapT == 'descend'@ +gmapT :: Uniplate a => (a -> a) -> a -> a +gmapT = descend + + +-- | Use 'children' and 'foldl' +gmapQl :: Uniplate a => (r -> r' -> r) -> r -> (a -> r') -> a -> r +gmapQl combine zero op = foldl combine zero . map op . children + + +-- | Use 'children' and 'foldr' +gmapQr :: Uniplate a => (r' -> r -> r) -> r -> (a -> r') -> a -> r +gmapQr combine zero op = foldr combine zero . map op . children + + +-- | Use 'children' +gmapQ :: Uniplate a => (a -> u) -> a -> [u] +gmapQ f = map f . children + + +-- | Use 'children' and '!!' +gmapQi :: Uniplate a => Int -> (a -> u) -> a -> u +gmapQi i f x = gmapQ f x !! i + + +-- | @gmapM == 'descendM'@ +gmapM :: (Uniplate a, Monad m) => (a -> m a) -> a -> m a +gmapM = descendM + + + +-- | @mkT == 'id'@ +mkT :: (a -> a) -> (a -> a) +mkT = id + + +-- | @everywhere == 'transformBi'@ +everywhere :: Biplate b a => (a -> a) -> b -> b +everywhere = transformBi + + +-- | @mkM == id@ +mkM :: Monad m => (a -> m a) -> a -> m a +mkM = id + + +-- | @everywhereM == 'transformBiM'@ +everywhereM :: (Biplate b a, Monad m) => (a -> m a) -> b -> m b +everywhereM = transformBiM + + + +-- | Only for use with 'everything' +mkQ :: r -> (a -> r) -> (r, a -> r) +mkQ = (,) + + +-- | Use 'universe' or 'universeBi', perhaps followed by a fold. +-- +-- Not an exact equivalent to the SYB @everything@, as the +-- operators may be applied in different orders. +everything :: Biplate b a => (r -> r -> r) -> (r, a -> r) -> b -> r +everything combine (nil, op) = foldl combine nil . map op . universeBi diff --git a/Data/Generics/Str.hs b/Data/Generics/Str.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/Str.hs @@ -0,0 +1,77 @@ +{- | + This module provides the 'Str' data type, which is used by the + underlying 'uniplate' and 'biplate' methods. It should not + be used directly under ordinary circumstances. +-} + +module Data.Generics.Str where + +import Data.Generics.PlateInternal + +import Data.Traversable +import Data.Foldable +import Control.Applicative +import Data.Monoid + +-- * The Data Type + +data Str a = Zero | One a | Two (Str a) (Str a) + deriving Show + + +instance Functor Str where + fmap f Zero = Zero + fmap f (One x) = One (f x) + fmap f (Two x y) = Two (fmap f x) (fmap f y) + + +instance Foldable Str where + foldMap m Zero = mempty + foldMap m (One x) = m x + foldMap m (Two l r) = foldMap m l `mappend` foldMap m r + + +instance Traversable Str where + traverse f Zero = pure Zero + traverse f (One x) = One <$> f x + traverse f (Two x y) = Two <$> traverse f x <*> traverse f y + + +-- | Take the type of the method, will crash if called +strType :: Str a -> a +strType = error "Data.Generics.Str.strType: Cannot be called" + + +-- | Convert a 'Str' to a list, assumes the value was created +-- with 'listStr' +strList :: Str a -> [a] +strList x = builder (f x) + where + f (Two (One x) xs) cons nil = x `cons` f xs cons nil + f Zero cons nil = nil + + +-- | Convert a list to a 'Str' +listStr :: [a] -> Str a +listStr (x:xs) = Two (One x) (listStr xs) +listStr [] = Zero + + +-- | Transform a 'Str' to a list, and back again, in a structure +-- preserving way. The output and input lists must be equal in +-- length. +strStructure :: Str a -> ([a], [a] -> Str a) +strStructure x = (g x [], fst . f x) + where + g :: Str a -> [a] -> [a] + g Zero xs = xs + g (One x) xs = x:xs + g (Two a b) xs = g a (g b xs) + + f :: Str a -> [a] -> (Str a, [a]) + f Zero rs = (Zero, rs) + f (One _) (r:rs) = (One r, rs) + f (Two a b) rs1 = (Two a2 b2, rs3) + where + (a2,rs2) = f a rs1 + (b2,rs3) = f b rs2 diff --git a/Data/Generics/Uniplate.hs b/Data/Generics/Uniplate.hs --- a/Data/Generics/Uniplate.hs +++ b/Data/Generics/Uniplate.hs @@ -1,4 +1,6 @@ {- | +/DEPRECATED/ Use "Data.Generics.UniplateStr" instead. + This is the main Uniplate module, which defines all the essential operations in a Haskell 98 compatible manner. @@ -11,7 +13,9 @@ -} -module Data.Generics.Uniplate where +module Data.Generics.Uniplate + {- DEPRECATED "Use Data.Generics.UniplateStr instead" -} + where import Control.Monad import Data.List(inits,tails) @@ -68,7 +72,7 @@ -- -- For example, replacing negative literals with literals: -- --- > negLits = trasform f +-- > negLits = transform f -- > where f (Neg (Lit i)) = Lit (negate i) -- > f x = x transform :: Uniplate on => (on -> on) -> on -> on @@ -118,17 +122,28 @@ -- ** Others --- | Return all the contexts and holes. This operation is only occasionally useful. +-- | 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 current +contexts x = (x,id) : f (holes x) where - (current, generate) = uniplate x - f xs = [ (y, \i -> generate (pre ++ [context i] ++ post)) - | (pre,b:post) <- zip (inits xs) (tails xs) - , (y, context) <- contexts b] + 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 [] _ = [] + f (x:xs) gen = (x, gen . (:xs)) : + f xs (gen . (x:)) + -- | Perform a fold-like computation on each value, -- technically a paramorphism diff --git a/Data/Generics/UniplateOn.hs b/Data/Generics/UniplateOn.hs --- a/Data/Generics/UniplateOn.hs +++ b/Data/Generics/UniplateOn.hs @@ -1,4 +1,7 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} {- | +/DEPRECATED/ Use "Data.Generics.UniplateStrOn" instead. + This module retained Haskell 98 compatability, but users who are happy with multi-parameter type classes should look towards "Data.Generics.Biplate". @@ -9,7 +12,9 @@ counterparts. -} -module Data.Generics.UniplateOn( +module Data.Generics.UniplateOn + {- DEPRECATED "Use Data.Generics.UniplateStrOn instead" -} + ( module Data.Generics.Uniplate, module Data.Generics.UniplateOn ) where @@ -36,7 +41,7 @@ -- | Return the children of a type. If @to == from@ then it returns the --- original element (in constract to 'children' +-- original element (in contrast to 'children') childrenOn :: Uniplate to => BiplateType from to -> from -> [to] childrenOn biplate x = fst $ biplate x @@ -64,25 +69,31 @@ descendOn :: Uniplate to => BiplateType from to -> (to -> to) -> from -> from -descendOn biplate f x = generate $ map (descend f) current +descendOn biplate f x = generate $ map f current where (current, generate) = biplate x descendOnM :: (Monad m, Uniplate to) => BiplateType from to -> (to -> m to) -> from -> m from -descendOnM biplate f x = liftM generate $ mapM (descendM f) current +descendOnM biplate f x = liftM generate $ mapM f current where (current, generate) = biplate x -- ** Other + +holesOn :: Uniplate to => BiplateType from to -> from -> [(to, to -> from)] +holesOn biplate x = uncurry f (biplate x) + where f [] _ = [] + f (x:xs) gen = (x, gen . (:xs)) : + f xs (gen . (x:)) + + contextsOn :: Uniplate to => BiplateType from to -> from -> [(to, to -> from)] -contextsOn biplate x = - concat [f pre b post | (pre,b:post) <- zip (inits current) (tails current)] +contextsOn biplate x = f (holesOn biplate x) where - (current, generate) = biplate x - - f pre x post = [(cur, \new -> generate (pre ++ [new] ++ post)) - | (cur,gen) <- contexts x] + f xs = [ (y, ctx . context) + | (child, ctx) <- xs + , (y, context) <- contexts child] -- * Helper for writing instances diff --git a/Data/Generics/UniplateStr.hs b/Data/Generics/UniplateStr.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/UniplateStr.hs @@ -0,0 +1,167 @@ +{- | +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 where + +import Control.Monad hiding (mapM) +import Data.List(inits,tails) +import Control.Monad.State hiding (mapM) +import Data.Traversable +import Prelude hiding (mapM) + +import Data.Generics.PlateInternal +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. +-- Must define one of 'uniplate' or 'uniplateStr', 'uniplateStr' is recommended +class Uniplate on where + -- | The underlying method in the class + -- + -- > uniplateStr (Add (Val 1) (Neg (Val 2))) + -- > = (Two (One (Val 1)) (One (Neg (Val 2)))], \(Two (One a) (One b)) -> Add a b) + -- > uniplateStr (Val 1) + -- > = (Zero , \Zero -> Val 1 ) + uniplate :: UniplateType on + + +-- | Compatibility method, for direct users of the '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 = [Val i | 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 = trasform 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 diff --git a/Data/Generics/UniplateStrOn.hs b/Data/Generics/UniplateStrOn.hs new file mode 100644 --- /dev/null +++ b/Data/Generics/UniplateStrOn.hs @@ -0,0 +1,116 @@ +{- | +This module retained Haskell 98 compatability, but users who are happy with +multi-parameter type classes should look towards "Data.Generics.Biplate". + +The only function missing from "Data.Generics.Uniplate" is 'fold', as it can be +constructed from 'children' and has little meaning in a multi-typed setting. + +All operations, apart from 'childrenOn', 'descendOn' and 'holesOn' should perform +identically to their non @On@ counterparts. +-} + +module Data.Generics.UniplateStrOn( + module Data.Generics.UniplateStr, + module Data.Generics.UniplateStrOn + ) where + +import Control.Monad(liftM) +import Data.List(inits,tails) +import Data.Traversable +import Prelude hiding (mapM) + +import Data.Generics.PlateInternal +import Data.Generics.Str +import Data.Generics.UniplateStr + +-- * Types + +-- | Return all the top most children of type @to@ within @from@. +-- +-- If @from == to@ then this function should return the root as the single +-- child. +type BiplateType from to = from -> (Str to, Str to -> from) + + +-- * Operations + +-- ** Queries + +universeOn :: Uniplate to => BiplateType from to -> from -> [to] +universeOn biplate x = builder f + where + f cons nil = g cons nil (fst $ biplate 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) + + +-- | Return the children of a type. If @to == from@ then it returns the +-- original element (in contrast to 'children') +childrenOn :: Uniplate to => BiplateType from to -> from -> [to] +childrenOn biplate x = builder f + where + f cons nil = g cons nil (fst $ biplate 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 + +transformOn :: Uniplate to => BiplateType from to -> (to -> to) -> from -> from +transformOn biplate f x = generate $ fmap (transform f) current + where (current, generate) = biplate x + + +transformOnM :: (Monad m, Uniplate to) => BiplateType from to -> (to -> m to) -> from -> m from +transformOnM biplate f x = liftM generate $ mapM (transformM f) current + where (current, generate) = biplate x + + +rewriteOn :: Uniplate to => BiplateType from to -> (to -> Maybe to) -> from -> from +rewriteOn biplate f x = generate $ fmap (rewrite f) current + where (current, generate) = biplate x + + +rewriteOnM :: (Monad m, Uniplate to) => BiplateType from to -> (to -> m (Maybe to)) -> from -> m from +rewriteOnM biplate f x = liftM generate $ mapM (rewriteM f) current + where (current, generate) = biplate x + + +descendOn :: Uniplate to => BiplateType from to -> (to -> to) -> from -> from +descendOn biplate f x = generate $ fmap f current + where (current, generate) = biplate x + + +descendOnM :: (Monad m, Uniplate to) => BiplateType from to -> (to -> m to) -> from -> m from +descendOnM biplate f x = liftM generate $ mapM f current + where (current, generate) = biplate x + + +-- ** Other +holesOn :: Uniplate to => BiplateType from to -> from -> [(to, to -> from)] +holesOn biplate x = uncurry f (biplate 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)) + +contextsOn :: Uniplate to => BiplateType from to -> from -> [(to, to -> from)] +contextsOn biplate x = f (holesOn biplate x) + where + f xs = [ (y, ctx . context) + | (child, ctx) <- xs + , (y, context) <- contexts child] + +-- * Helper for writing instances + +-- | Used for defining instances @UniplateFoo a => UniplateFoo [a]@ +uniplateOnList :: BiplateType a b -> BiplateType [a] b +uniplateOnList f [] = (Zero, \_ -> []) +uniplateOnList f (x:xs) = + (Two a as, + \(Two n ns) -> b n : bs ns) + where + (a , b ) = f x + (as, bs) = uniplateOnList f xs diff --git a/uniplate.cabal b/uniplate.cabal --- a/uniplate.cabal +++ b/uniplate.cabal @@ -1,7 +1,8 @@ Cabal-Version: >= 1.2 +Build-Type: Simple Name: uniplate -Version: 1.0.1 -Copyright: 2006-7, Neil Mitchell +Version: 1.2 +Copyright: 2006-8, Neil Mitchell Maintainer: ndmitchell@gmail.com Homepage: http://www-users.cs.york.ac.uk/~ndm/uniplate/ License: BSD3 @@ -28,10 +29,15 @@ Exposed-modules: Data.Generics.Uniplate Data.Generics.UniplateOn + Data.Generics.UniplateStr + Data.Generics.UniplateStrOn Data.Generics.Biplate Data.Generics.PlateDirect Data.Generics.PlateTypeable Data.Generics.PlateData Data.Generics.PlateInternal + Data.Generics.Str + Data.Generics.Compos + Data.Generics.SYB Extensions: CPP, FlexibleInstances diff --git a/uniplate.htm b/uniplate.htm --- a/uniplate.htm +++ b/uniplate.htm @@ -56,7 +56,7 @@

- Generic transformations and queries are often referred to as boilerplate code - they remain relatively similar as the action performed by the code changes, and can often outnumber the actual intent of the code in terms of lines. While other generic traversal schemes have shown how powerful new features can be added to compilers, and how the type system can be manipulated into accepting these operations, this document focuses on a conceptually simpler generic concept. The Uniplate class is introduced, which abstracts over common traversals and queries in a simple manner. A more complete document on the Uniplate class was published at the Haskell Workshop 2007, and is available from the project website, along with a video presentation. + Generic transformations and queries are often referred to as boilerplate code - they remain relatively similar as the action performed by the code changes, and can often outnumber the actual intent of the code in terms of lines. While other generic traversal schemes have shown how powerful new features can be added to compilers, and how the type system can be manipulated into accepting these operations, this document focuses on a conceptually simpler generic concept. The Uniplate class is introduced, which abstracts over common traversals and queries in a simple manner. A more complete document on the Uniplate class was published at the Haskell Workshop 2007, and is available from the project website, along with a video presentation, and the associated thesis chapter.

There have been several attempts at generic traversal/query methods in Haskell. One initial paper was "Scrap your boilerplate: a practical design pattern for generic programming" (free copy) - which I will refer to as SYB. Another mechanism is "A Pattern for Almost Compositional Functions" (free copy) - which I refer to as Compos (after the name of their class). A detailed comparison is given in the Uniplate paper. @@ -69,8 +69,8 @@

  1. The motivation and use cases for Uniplate
    2. -
  2. How to use the Uniplate class
  3. Extensions to Biplate
    4. +
  4. Uniplate and Biplate instances

The libraries is available through Hackage or darcs: @@ -245,81 +245,32 @@ Exercise: Replace one multiplication with addition, if there are no multiplications return the original expression.

-

Reverse notation

-
-uniplate :: Uniplate on => on -> ([on], [on] -> on)
-
-

- In general, universe and transform are used most of the time, and transformM is used occasionally. The Uniplate class is built upon the operation uniplate, which takes an expression, and returns a pair with the children of that expression, and a function to generate that expression with a new set of children in place. This operation can be directly exploited if required, although should be handled with caution. -

-

- Let us make a function that reverses the order of all the inputs, say if the user is working in Right-to-Left mode on their computer: -

-
-reverseExpr :: Expr -> Expr
-reverseExpr = transform f
-    where
-        f x = generate $ reverse collect
-            where (collect,generate) = uniplate x
-
-

- This expression does a standard transform, but at each iteration calls uniplate, then reverses the children set before regenerating the original expression. This shows the underlying mechanism on which the library is based, and isn't recommended for average users. -

- - -

Defining a Uniplate instance

+

Using the operations from Biplate

- As shown in the reversal example (just above), the only method in the Uniplate class is uniplate. The Uniplate class is defined as: + To see various operations being used from the Biplate class, see the Uniplate paper. Typically the operations are just the same as Uniplate, with Bi on the end. 

-class Uniplate on where
-    uniplate :: on -> ([on], [on] -> on)
-
-

- The idea is that given an item, you want to return all the children, and a function that will replace all the children. An invariant is that the list given to the second function will be the same length as that returned in the first element of the pair. Let's start by constructing the Uniplate instance for the expression type. -

-
-instance Uniplate Expr of
-    uniplate x =
-        case x of
-            Add a b -> ([a,b], \[a,b] -> Add a b)
-            ...
-            Neg a -> ([a], \[a] -> Neg a)
-            Val i -> ([], \[] -> Val i)
+universeBi:: Biplate on with => on -> [with]
+transformBi :: Biplate on with => (with -> with) -> on -> on
+transformBiM :: (Monad m, Biplate on with) => (with -> m with) -> on -> m on
-

- A short study of the code should show how this works. The other constructors such as Mul follow the same pattern as Add. To define a Uniplate instance a user should make use of the Data.Derive tool. -

-

Using Biplate

+

Uniplate and Biplate instances

- The Biplate class is not standard Haskell, requiring multi-parameter type classes. Where possible try and use the standard Uniplate class. The Biplate class is necessary when working with a data structure that has multiple types within it. -

-
-class Uniplate with => Biplate on with where
-    biplate :: on -> ([with], [with] -> on)
-
-

- The biplate method operates much like uniplate, except for the different types. When the types of on and with are different, biplate returns the closest children of the requested type. When the types are the same, this function returns the root element, not it's children. -

-

- There are several mechanisms for writing Biplate instances, discussed in the Uniplate paper. + To define Uniplate and Biplate instances it is sufficient to:

- -

Using the operations from Biplate

- +
    +
  • Use GHC.
    • +
  • Import the module Data.Generics.PlateData.
    • +
  • Add deriving (Data,Typeable) to all data type definitions.
    • +

- To see various operations being used from the Biplate class, see the Uniplate paper. Typically the operations are just the same as Uniplate, with Bi on the end. + Alternative ways of implementing Uniplate and Biplate instances are presented in the associated thesis chapter.

-
-universeBi:: Biplate on with => on -> [with]
-transformBi :: Biplate on with => (with -> with) -> on -> on
-transformBiM :: (Monad m, Biplate on with) => (with -> m with) -> on -> m on
-