> {-# OPTIONS -fglasgow-exts #-}
> module GMap (mapList,mapListBTree,mapListBTreeList) where
> import Unsafe.Coerce
> import BinTreeDatatype
> import BinTreeReps
> import Data.Generics
> import Data.Char
> errorNotSupported = error ("SYB1_2.GMap: gmap cannot be implemented in SYB in a type safe way." ++
> " However, look at sources to see unsafe and non composition preserving variants")
======================
Oleg's gmap for SYB1_2
----------------------
Based on:
* Claus' gmap : http://www.haskell.org/pipermail/generics/2008-June/000343.html
http://www.haskell.org/pipermail/generics/2008-July/000351.html
and
* Oleg's initial gmap: http://www.haskell.org/pipermail/generics/2008-July/000349.html
> mapList :: (Data a, Data b) => (a -> b) -> [a] -> [b]
> mapList = gmap
Note the type of gmap2 requires the input datum to have the type (c a)
The general solution could use the following type:
*> newtype Compose f g a = Compose{unComp :: f (g a)} deriving Data
Alas, we need to derive instance Typeable1 (Compose f g) by hand.
Leave this for now.
> mapListBTree :: (Data a, Data b) => (a -> b) -> [BinTree a] -> [BinTree b]
> mapListBTree f = unLB . gmap f . LB
> newtype LB a = LB{unLB :: [BinTree a]} deriving (Data, Typeable)
> mapListBTreeList :: (Data a, Data b) =>
> (a -> b) -> [BinTree [a]] -> [BinTree [b]]
> mapListBTreeList f = unBLB . gmap f . BLB
> newtype BLB a = BLB{unBLB :: [BinTree [a]]} deriving (Data, Typeable)
> example1 = [1,2,7,3,4]
> example2 = [Leaf 1 `Bin` Leaf 7,Leaf 3 `Bin` Leaf 4]
> example3 = [Leaf [1] `Bin` Leaf [2,7],Leaf [3] `Bin` Leaf [4]]
> toChar i = chr (i + ord 'A')
> test1 = mapList toChar example1
> test2 = mapListBTree toChar example2
> test3 = mapListBTreeList toChar example3
example2b = [Leaf True `Bin` Leaf False,Leaf True `Bin` Leaf False]
test2b :: [BinTree Int] = gmap' (\(x::Bool) -> fromEnum x) example2b
=======================================================================
-- I believe the following gmap is composition-preserving
> gmap :: forall a b c . (Data a, Data b,
> Data (c a), Data (c b), Data (c X)) =>
> (a -> b) -> c a -> c b
> gmap f = gmapt f (Dyn (undefined::c X))
> data Tricky a = Tricky a Char deriving (Data,Typeable,Show)
> tricky1 = Tricky 'a' 'b'
> fun1 = chr . (+1) . ord
> fun2 = (=='a')
> mapTricky :: (Data a,Data b) => (a -> b) -> Tricky a -> Tricky b
> mapTricky = gmap
> tr_test3t = (mapTricky (fun2 . fun1) tricky1,
> (mapTricky fun2 . mapTricky fun1) tricky1)
> clausTest = gmap not (True,True) :: (,) Bool Bool
Expected result: (True,False)
-- This code uses the following spot-mark defined in Claus' code
> -- "X marks the spots";-) X should be private
> data X = X deriving (Data,Typeable)
gmapt gets the value x to traverse and the template. The template is a
Dyn whose type has the same basic structure as that of x. The following
equation is supposed to hold:
tt{X:=a} = typeOf x where (Dyn t) = template; tt = typeOf tt
where {X:=a} is a substitution that replaces all occurrences of a singleton
type X with some other suitable type a.
For example,
x has the type [Int]
template has the type [X]
x has the type Tricky Int Int
template has the type Tricky X Int
x has the type Tricky Int Int
template has the type Tricky X X
Although 'x' is the defined value, template is generally an undefined value.
The trick is to build the template `out of nothing', in a shallow way,
to the extent to enable further traversal. The trick is the
observation that x and template should share the same data structure,
or at least the same top-level data constructor.
The following includes an optimization: if typeof template == typeof x,
there is nothing to traverse. Only values that correspond to the mark X
in the template are mapped.
> gmapt :: (Data a, Data b, Data x, Data y) => (a -> b) -> Dyn -> x -> y
> gmapt f trep = maybe (\x -> traverse (trep,x)) ifmarked $ castfn f
> where
> hasmark :: Dyn -> Bool
> hasmark (Dyn x) = typeOf x == typeOf X
> -- ifmarked :: Typeable x => (x->y) -> (x->y)
> ifmarked f x | hasmark trep = f x
> ifmarked f x = traverse (trep,x)
> -- optimization: t has no mark, there is nothing to map under it
> traverse (Dyn t,x) | typeOf t == typeOf x =
> maybe (error "traverse1") id $ cast x
> traverse (Dyn t,x) | (tcon,tkids) <- splitTyConApp (typeOf t),
> (con,kids) <- splitTyConApp (typeOf x),
> not (length tkids == length kids &&
> tcon == con) =
> error $ unwords ["template type", show (typeOf t),
> "inconsistent with value type", show (typeOf x)]
> traverse (Dyn t,x) = rebuild (dynamize t1) xdyn
> where xdyn@(con,kids) = dynamize x
> t1 = fromConstr con `asTypeOf` t
> rebuild (tcon, tkids) (con, kids) =
> case gunfold k (\g -> UnfldStateT g tkids kids) con of
> UnfldStateT a [] [] -> a
> k (UnfldStateT ca (tkid:tkids) ((Dyn kid):kids)) =
> UnfldStateT (ca (gmapt f tkid kid)) tkids kids
> data UnfldStateT a = UnfldStateT a [Dyn] [Dyn]
> data Dyn = forall a. Data a => Dyn a
> data Kids a = Kids{growUp:: [Dyn]}
> dynamize :: Data a => a -> (Constr,[Dyn])
> dynamize x = (toConstr x, growUp $ gfoldl f (const (Kids [])) x)
> where f (Kids l) a = Kids (l ++ [Dyn a])
> tdyn1 = dynamize "abcd"
> castfn :: (Typeable a, Typeable b, Typeable c, Typeable d) =>
> (a -> b) -> Maybe (c -> d)
> castfn f = cast f