Commit b65564b4 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Eta expansion and scoped type variables in generic code

The new story on higher-rank types requires a few functions to be
eta-expanded.  And the new scoped-type-variable story also forces
a few changes.
parent a05e2f74
......@@ -45,23 +45,21 @@ parseConstr ty = D (\s ->
n = length (showConstr con)
readM :: Data a => DecM a
readM :: forall a. Data a => DecM a
readM = read
where
read = do { let val = argOf read
; let ty = dataTypeOf val
; constr <- parseConstr ty
; let con::a = fromConstr constr
; gmapM (\_ -> readM) con }
where
read :: DecM a
read = do { let val = argOf read
; let ty = dataTypeOf val
; constr <- parseConstr ty
; let con::a = fromConstr constr
; gmapM (\_ -> readM) con }
argOf :: c a -> a
argOf = undefined
yareadM :: Data a => DecM a
yareadM = readM'
where
readM' :: DecM a
= do { let ty = dataTypeOf (undefined::a)
yareadM :: forall a. Data a => DecM a
yareadM = do { let ty = dataTypeOf (undefined::a)
; constr <- parseConstr ty
; let con::a = fromConstr constr
; gmapM (\_ -> yareadM) con }
......
......@@ -27,6 +27,8 @@ main = print $ gzip (mkTT maxS) genCom1 genCom2
maxS (S x) (S y) = S (max x y)
-- Make a two-arguments, generic function transformer
mkTT :: (Typeable a, Typeable b, Typeable c)
=> (a -> a -> a) -> b -> c -> Maybe c
mkTT (f::a -> a -> a) x y =
case (cast x,cast y) of
(Just (x'::a),Just (y'::a)) -> cast (f x' y')
......
......@@ -35,10 +35,8 @@ unwrap y = case gmapQ (Nothing `mkQ` Just) y of
-- Eliminate a constructor if feasible; 2nd try
elim :: (Data y, Data x) => (x -> y) -> y -> Maybe x
elim c y = x
where
x::Maybe x = elim' (toConstr (c (undefined::x))) y
elim :: forall x y. (Data y, Data x) => (x -> y) -> y -> Maybe x
elim c y = elim' (toConstr (c (undefined::x))) y
-- Visit a data structure
......
......@@ -95,7 +95,7 @@ type GTypeFun r = forall a. Data a => TypeFun a r
-- | Extend a type function
extType :: (Data a, Typeable r) => GTypeFun r -> TypeFun a r -> GTypeFun r
extType f = maybe f id . cast
extType f x = maybe f id (cast x)
......@@ -324,21 +324,24 @@ depthOfConstr p (t::TypeVal a) c
------------------------------------------------------------------------------
shallowTerm :: (forall a. Data a => Maybe a) -> (forall b. Data b => b)
shallowTerm cust
shallowTerm cust :: b
=
maybe gdefault id cust
where
-- The worker, also used for type disambiguation
gdefault :: b
gdefault = case con of
Just (con, Just _) -> fromConstrB (shallowTerm cust) con
_ -> error "no shallow term!"
-- The type to be constructed
typeVal :: TypeVal b
typeVal = val2type gdefault
-- The most shallow constructor if any
con :: Maybe (Constr, Maybe Int)
con = depthOfType (const True) typeVal
......
......@@ -32,6 +32,7 @@ gzipWithQ f t1 t2
gApplyQ :: Data a => [GQ r] -> a -> [r]
gApplyQ qs t = reverse (snd (gfoldlQ k z t))
where
k :: ([GQ r], [r]) -> GenericQ ([GQ r], [r])
k (GQ q : qs, rs) child = (qs, q child : rs)
z = (qs, [])
......@@ -69,6 +70,7 @@ gApplyQ' :: Data a => [XQ r] -> a -> [r]
gApplyQ' qs t = reverse (snd (gfoldlQ k z t))
where
z = (qs, [])
k :: ([XQ r], [r]) -> GenericQ ([XQ r], [r])
k (XQ q : qs, rs) child = (qs, q' child : rs)
where
q' = error "Twin mismatch" `extQ` q
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment