{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
-- Parametric and optimal generic map in SYB
-- http://www.haskell.org/pipermail/generics/2008-July/000362.html
-- improving on the ideas proposed in
-- http://www.haskell.org/pipermail/generics/2008-July/000349.html
-- http://www.haskell.org/pipermail/generics/2008-June/000343.html
-- See the discussion threads for more details, examples and discussion
-- Many discussions with Claus Reinke and Alexey Rodriguez-Yakushev
-- are greatly appreciated.
module GMap where
import Data.Data
import Data.Char (ord, chr) -- for tests
-- ------------------------------------------------------------------------
-- The first, naive attempt to write sort of a generic map in SYB,
-- and why it doesn't work
newtype ID a = ID{unID :: a} deriving (Data, Typeable)
gmappish :: (Data a, Data (c a)) => (a -> a) -> c a -> c a
gmappish f x = traverse x
where
traverse :: Data a => a -> a
traverse x = unID $ gfoldl k z x
z = ID
k (ID ca) b | Just fb <- castfn f = ID (ca (fb b))
k (ID ca) b = ID (ca (traverse b))
castfn :: (Typeable a, Typeable b, Typeable c, Typeable d) =>
(a -> b) -> Maybe (c -> d)
castfn f = cast f
test1 = gmappish (+1) [1::Int,2,3]
-- [2,3,4]
newtype Compose f g a = Compose{uncompose :: f (g a)}
deriving Data
instance (Typeable1 f, Typeable1 g) => Typeable1 (Compose f g) where
typeOf1 _ = mkTyConApp tcomp [typeOf1 (undefined:: f ()),
typeOf1 (undefined:: g ())]
where
tcomp = mkTyCon3 "" "GMap" "Compose"
test2 = uncompose . gmappish (+1) . Compose $ [[1::Int,2,3]]
-- [[2,3,4]]
test3 = uncompose . gmappish (+1) . Compose $ Just ('a',1::Int)
-- Just ('a',2)
data Tricky a = Tricky a Int deriving (Typeable, Data, Show)
tricky_mappish :: Data a => (a->a) -> Tricky a -> Tricky a
tricky_mappish = gmappish
trickish1 = tricky_mappish not (Tricky True 1)
-- Tricky False 1
trickish2 = tricky_mappish (+1) (Tricky (0::Int) 1)
-- Tricky 1 2
-- ------------------------------------------------------------------------
-- Real generic map
--
-- Two insights: the type changing mapping function can be accommodated
-- via a serialize-transform-deserialize trick. The serialized
-- value, after the transformation, can be read back at a different
-- type.
-- For more detail, see
-- http://okmij.org/ftp/Haskell/generics.html#gmap
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))
-- This code uses the following spot-mark X defined in Claus' code
-- "X marks the spots";-) X should be private
data X = X deriving (Data,Typeable)
{-
Alexey: ``You are passing around an explicit type representation at
run-time, to ensure that the transforming function applies only to
X-positions.''
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 t
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 (Int, Int)
template has the type (X, Int)
x has the type (Int, Int)
template has the type (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.
The 'error' functions below do consistency checks. If gmapt is invoked
only through gmap as shown above, none of these checks shall fail.
-}
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
-- The gmapped value x has the right type to be transformed by 'f'
-- We do the transformation only if 'x' has the mark
-- 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 f (serialize t1) xdyn
where xdyn@(con,kids) = serialize x
t1 = fromConstr con `asTypeOf` t -- build the ephemeral template
-- The serialization step
-- The serialized value: the data constructor descriptor and the list
-- of its arguments, lazily serialized (that is, wrapped in Dyn)
type Serialized = (Constr,[Dyn])
data Dyn = forall a. Data a => Dyn a
data Kids a = Kids{growUp:: [Dyn]}
serialize :: Data a => a -> Serialized
serialize x = (toConstr x, growUp $ gfoldl k (const (Kids [])) x)
where k (Kids l) a = Kids (l ++ [Dyn a])
tdyn1 = serialize "abcd"
-- The deserialization step (which traverses the template in parallel)
-- It reassembles the value from the possibly transformed subcomponents
data UnfldStateT a = UnfldStateT a [Dyn] [Dyn]
rebuild :: (Data a, Data b, Data t) =>
(a->b) -> Serialized -> Serialized -> t
rebuild f (tcon, tkids) (con, kids) =
case gunfold k (\g -> UnfldStateT g tkids kids) con of
UnfldStateT a [] [] -> a
where k (UnfldStateT ca (tkid:tkids) ((Dyn kid):kids)) =
UnfldStateT (ca (gmapt f tkid kid)) tkids kids
-- ------------------------------------------------------------------------
-- tests
toChar i = chr (i + ord 'A')
mapList :: (Data a, Data b) => (a -> b) -> [a] -> [b]
mapList = gmap
tl = mapList toChar [1,2,7,3,4]
-- "BCHDE"
data BinTree a = Leaf a | Bin (BinTree a) (BinTree a)
deriving (Data, Typeable, Show)
mapListBTree :: (Data a, Data b) => (a -> b) -> [BinTree a] -> [BinTree b]
mapListBTree f = uncompose . gmap f . Compose
tlb = mapListBTree toChar [Leaf 1 `Bin` Leaf 7,Leaf 3 `Bin` Leaf 4]
-- [Bin (Leaf 'B') (Leaf 'H'),Bin (Leaf 'D') (Leaf 'E')]
mapListBTreeList :: (Data a, Data b) =>
(a -> b) -> [BinTree [a]] -> [BinTree [b]]
mapListBTreeList f = uncompose . uncompose . gmap f . Compose . Compose
tlbl = mapListBTreeList toChar
[Leaf [1] `Bin` Leaf [2,7],Leaf [3] `Bin` Leaf [4]]
-- [Bin (Leaf "B") (Leaf "CH"),Bin (Leaf "D") (Leaf "E")]
test2b = mapListBTree (\(x::Bool) -> fromEnum x)
[Leaf True `Bin` Leaf False,Leaf True `Bin` Leaf False]
-- [Bin (Leaf 1) (Leaf 0),Bin (Leaf 1) (Leaf 0)]
-- Tricky tests by Alexey
tricky_map :: (Data a, Data b) => (a->b) -> Tricky a -> Tricky b
tricky_map = gmap
tricky1 = tricky_map not (Tricky True 1)
-- Tricky False 1
tricky2 = tricky_map (+1) (Tricky (0::Int) 1)
-- Tricky 1 1
-- contrast with trickish2 earlier!
tricky3 = tricky_map toChar (Tricky (0::Int) 1)
-- Tricky 'A' 1
tricky4 = tricky_map fromEnum (Tricky False 1)
-- Tricky 0 1
-- A parametricity test
tricky_param = (tricky_map (fun2 . fun1) tricky1,
(tricky_map fun2 . tricky_map fun1) tricky1)
where tricky1 = Tricky (0::Int) 1
fun1 = (+1)
fun2 = (==1)
-- (Tricky True 1,Tricky True 1)
-- Test by Claus Reinke
clausTest = gmap not (True,True) :: (,) Bool Bool
-- (True,False)
{-
Another Claus example
gmap (\True -> 'c') (id::Bool -> Bool) True
is rejected statically with a type error
No instance for (Data (Bool -> X)) arising from a use of `gmap'
rather than with a dynamic gunfold exception.
Yet another example
gmap not (True,True) :: (Bool,Char)
is likewise rejected statically with a type error, rather dynamically
like in some earlier versions.
-}
-- More examples of GMap for other functors
newtype Switch ctx c a b = Switch{unSwitch :: ctx (c b a)}
deriving (Data)
instance (Typeable1 ctx, Typeable2 c) => Typeable2 (Switch ctx c) where
typeOf2 _ = mkTyConApp tcomp [typeOf1 (undefined:: ctx ()),
typeOf2 (undefined:: c () ())]
where
tcomp = mkTyCon3 "" "GMap" "Switch"
mapl :: (Data w, Data b, Data a) =>
(a->b) -> Either a w -> Either b w
mapl f = unID . unSwitch . gmap f . Switch . ID
tml = (mapl toChar (Left 1 :: Either Int ()), mapl chr (Right ()))
-- (Left 'B',Right ())
mapx :: (Data b, Data a) =>
(a->b) -> BinTree (Maybe (a,Int)) -> BinTree (Maybe (b,Int))
mapx f = uncompose . unSwitch . gmap f . Switch . Compose
tmx = mapx toChar (Leaf (Just ((1::Int,2))) `Bin` Leaf Nothing)
-- Bin (Leaf (Just ('B',2))) (Leaf Nothing)