-- <pre><BIG><B>

import IOExts

-- Example datatypes
-- [], Either, Maybe, Bool
data Tree a b = Tip a | Node (Tree a b) b (Tree a b)

-- Example generic functions

equal :: Rep a -> a -> a -> Bool
display :: Rep a -> a -> String
marshall :: Rep a -> a -> [ Int ]
unmarshall :: Rep a -> [Int] -> a
----------------------------------------------------

data Rep t = Univ Name (t -> Val) (Val -> t)
           | Iso (Shape Iso t)
           | Leibniz (Shape Leibniz t)

data Name = App String [Name] deriving Eq

class Named t where
  name :: t -> Name

class Generic t where
  univ :: Rep t
  iso :: Rep t
  leib :: Rep t
  gmapT :: (forall b . Generic b => b -> b) -> t -> t
  gmapQ :: (forall b . Generic b => b -> r) -> t -> [r]
  gmapM :: Monad m => (forall b . Generic b => b -> m b) -> t -> m t
  gfoldl :: (forall a b . Generic a => w (a -> b) -> a -> w b) ->
            (forall g . g -> w g) ->
            t -> w t

class Generic1 t where
  univ1 :: Rep a -> Rep(t a)
  iso1 :: Rep a -> Rep(t a)
  leib1 :: Rep a -> Rep(t a)
  gmapT1 :: Generic a => (forall b . Generic b => b -> b) -> t a -> t a
  gmapQ1 :: Generic a => (forall b . Generic b => b -> r) -> t a -> [r]
  gmapM1 :: (Generic a,Monad m) => (forall b . Generic b => b -> m b) -> t a -> m (t a)
  gfoldl1 :: (Generic c) => (forall a b . Generic a => w (a -> b) -> a -> w b) ->
                            (forall g . g -> w g) ->
                            t c -> w (t c)

class Generic2 t where
  univ2 :: Rep a -> Rep b -> Rep (t a b)
  iso2 :: Rep a -> Rep b -> Rep (t a b)
  leib2 :: Rep a -> Rep b -> Rep (t a b)
  gmapT2 ::(Generic a,Generic c) => (forall b . Generic b => b -> b) -> t a c -> t a c
  gmapQ2 :: (Generic a,Generic c) => (forall b . Generic b => b -> r) -> t a c -> [r]
  gmapM2 :: (Generic a,Generic c,Monad m) => (forall b . Generic b => b -> m b) -> t a c -> m (t a c)
  gfoldl2 :: (Generic c,Generic d) =>
             (forall a b . Generic a => w (a -> b) -> a -> w b) ->
             (forall g . g -> w g) ->
             t c d -> w (t c d)

-----------------------------------------------------------------
-- Example use of Name

intN = App "Int" []
charN = App "Char" []
unitN = App "()" []

instance Named (Rep a) where
  name (Univ nm f g) = nm
  name (Iso s) = name s
  name (Leibniz s) = name s


-----------------------------------------------------------------
-- The Univ approach

into (Univ nm f g) = f
out  (Univ nm f g) = g

data Val
  = Vint Int
  | Vchar Char
  | Vunit
  | Vfun (Val  -> Val )
  | Vdata String [Val]
  | Vtuple [Val ]
  | Vpar Int Val

mapVal :: (Val -> Val) -> Val -> Val
mapVal f (Vpar n a) = Vpar n(f a)
mapVal f (Vint n) = Vint n
mapVal f (Vchar c) = Vchar c
mapVal f Vunit = Vunit
mapVal f (Vfun h) = error "can't mapVal Vfun"
mapVal f (Vdata s xs) = Vdata s (map (mapVal f) xs)
mapVal f (Vtuple xs) = Vtuple(map (mapVal f) xs)

instance Num Val where
  fromInt x = Vint x
  (+) (Vint x) (Vint y) = Vint (x+y)
  (*) (Vint x) (Vint y) = Vint (x*y)
  (-) (Vint x) (Vint y) = Vint (x - y)

instance Generic Val where
  univ = Univ (App "Val" []) id id

instance Show (Val ) where
   show (Vint n) = show n
   show (Vchar c) = show c
   show Vunit = "()"
   show (Vfun f) = "fn"
   show (Vdata s []) = s
   show (Vdata s xs) = "("++s++plist " " xs " " ")"
   show (Vtuple xs) = plist "(" xs "," ")"
   show (Vpar n x) = show x


plist :: Show a => String -> [a] -> String -> String -> String
plist open xs sep close = open ++ help xs ++ close
  where help [] = ""
        help [x] = show x
        help (x:xs) = show x ++ sep ++ help xs

instance Eq Val where
  x == y = test x y
    where test (Vint n) (Vint m) = n==m
          test (Vchar n) (Vchar m) = n==m
          test Vunit Vunit = True
          test (Vdata s xs) (Vdata t ys) = s==t && tests xs ys
          test (Vtuple xs) (Vtuple ys) = tests xs ys
          test (Vpar n x) (Vpar m y) = test x y
          test _ _ = False
          tests [] [] = True
          tests (x:xs) (y:ys) = test x y && tests xs ys
          tests _ _ = False

-----------------------------------------------------------------
-- Examples of Universal Representations

intU =  Univ intN Vint (\ (Vint n) -> n)
charU = Univ charN Vchar (\ (Vchar c) -> c)
unitU = Univ unitN (const Vunit) (const ())

pairU :: (Rep a) -> (Rep b) -> Rep (a,b)
pairU (Univ a to1 from1) (Univ b to2 from2)  = Univ (App "(,)" [a,b]) f g
   where f (x,y) = Vtuple[to1 x,to2 y]
         g (Vtuple[x,y])= (from1 x,from2 y)
         g y = error ("In g "++(show y))

arrowU :: Rep a -> Rep b -> Rep (a -> b)
arrowU (r1 @ (Univ a _ _)) (r2 @ (Univ b _ _)) =  Univ (App "->" [a,b]) f g
  where f h = Vfun(into r2 . h . out r1)
        g (Vfun h) = out r2 . h . into r1

listU :: Rep a -> Rep [a]
listU (Univ a to from) = Univ (App "[]" [a]) h k
  where h [] = Vdata "[]" []
        h (x:xs) = Vdata ":" [ Vpar 1 (to x),h xs]
        k (Vdata "[]" []) = []
        k (Vdata ":" [Vpar 1 x,xs]) = (from x) : k xs

plusU :: Rep a -> Rep b -> Rep (Either a b)
plusU (Univ a to1 from1) (Univ b to2 from2) = Univ (App "Either" [a,b]) h k
  where
   h (Left x) = Vdata "Left" [Vpar 1 (to1 x)]
   h (Right x) = Vdata "Right" [Vpar 2 (to2 x)]
   k (Vdata "Left" [Vpar 1 x]) = Left (from1 x)
   k (Vdata "Right" [Vpar 2 x]) = Right (from2 x)

boolU :: Rep Bool
boolU = Univ (App "Bool" []) f g
  where f True = Vdata "True" []
        f False = Vdata "False" []
        g (Vdata "True" []) = True
        g (Vdata "False" []) = False

maybeU :: Rep a -> Rep (Maybe a)
maybeU (Univ a to1 from1) = Univ (App "Maybe" [a]) h k
  where
   h Nothing = Vdata "Nothing" []
   h (Just x) = Vdata "Just" [Vpar 1 (to1 x)]
   k (Vdata "Nothing" []) = Nothing
   k (Vdata "Just" [Vpar 1 x]) = Just (from1 x)

-----------------------------------------------------------
-- Generic instances

instance Generic Int where
  univ = intU
  iso =  intI
  leib = intL
  gmapT f x = x
  gmapQ f x = []
  gmapM f x = return x
  gfoldl k z x = z x

instance Generic Char where
  univ = charU
  iso = charI
  leib = charL
  gmapT f x = x
  gmapQ f x = []
  gmapM f x = return x
  gfoldl k z x = z x

instance Generic () where
  univ = unitU
  iso = unitI
  leib = unitL
  gmapT f x = x
  gmapQ f x = []
  gmapM f x = return x
  gfoldl k z x = z x

instance (Generic1 t,Generic a) => Generic(t a) where
  univ = univ1 univ
  iso = univ1 iso
  leib = leib1 leib
  gmapT f = gmapT1 f
  gmapQ f = gmapQ1 f
  gmapM f = gmapM1 f
  gfoldl k z x = gfoldl1 k z x

instance Generic a => Generic1 ((,) a) where
  univ1 = pairU univ
  iso1 = pairI iso
  leib1 = pairL leib
  gmapT1 f (x,y) = (f x,f y)
  gmapQ1 f (x,y) = [f x,f y]
  gmapM1 f (x,y) = do { a <- f x; b <- f y; return(x,y) }
  gfoldl1 k z (x,y) = (z g `k` x) `k` y where g a b = (a,b)

instance Generic a => Generic1 ((->) a) where
  univ1 = arrow univ
  iso1 = funI iso
  leib1 = funL leib
  gmapT1 f x = error "No Strafunski gmapT on function types"
  gmapQ1 f x = error "No Strafunski gmapQ on function types"
  gmapM1 f x = error "No Strafunski gmapM on function types"
  gfoldl1 f x = error "No Strafunski gfoldl on function types"

instance Generic Bool where
  univ = boolU
  iso = Iso boolP
  leib = Leibniz boolP
  gmapT f True = True
  gmapT f False = False
  gmapQ f True = []
  gmapQ f False = []
  gmapM f True = return True
  gmapM f False = return False
  gfoldl k z True = z True
  gfoldl k z False = z False

instance Generic a => Generic1 (Either a) where
  univ1 = plusU univ
  iso1 = plusI iso
  leib1 = plusL leib
  gmapT1 f (Left x) = Left(f x)
  gmapT1 f (Right x) = Right(f x)
  gmapQ1 f (Left x) = [f x]
  gmapQ1 f (Right x) = [f x]
  gmapM1 f (Left x) = do { a <- f x; return(Left a)}
  gmapM1 f (Right x) = do { a <- f x; return(Right a)}
  gfoldl1 k z (Left x) = z Left `k` x
  gfoldl1 k z (Right x) = (z Right `k` x)

instance Generic1 [] where
  univ1 = list
  iso1 (Iso s) = Iso(listP s)
  leib1 (Leibniz s) = Leibniz(listP s)
  gmapT1 f [] = []
  gmapT1 f (x:xs) = (f x) : (f xs)
  gmapQ1 f [] = []
  gmapQ1 f (x:xs) = [f x,f xs]
  gmapM1 f [] = return []
  gmapM1 f (x:xs) = do { a <- f x; b <- f xs; return(a:b)}
  gfoldl1 k z [] = z []
  gfoldl1 k z (x:xs) = k (k (z (:)) x) xs

instance Generic1 Maybe where
  univ1 = maybeU
  iso1 (Iso s) = Iso(maybeP s)
  leib1 (Leibniz s) = Leibniz(maybeP s)
  gmapT1 f Nothing = Nothing
  gmapT1 f (Just x) = Just(f x)
  gmapQ1 f Nothing = []
  gmapQ1 f (Just x)= [f x]
  gmapM1 f Nothing = return Nothing
  gmapM1 f (Just x) = do { a <- f x; return(Just a) }
  gfoldl1 k z Nothing = z Nothing
  gfoldl1 k z (Just x) = k (z Just) x

lift x = into univ x

x,y,z::Int
x=0
y=1
z=2

----------------------------------------------------------
-- Generic functions using the universal approach
----------------------------------------------------------

gmap :: Rep b -> Rep c -> (forall a . Rep a -> Rep(t a)) -> (b->c) -> t b -> t c
gmap repB repC t f x = out repLC (help (into repLB x))
  where repLB = t repB
        repLC = t repC
        help xs = mapVal trans xs
        trans x = into repC (f(out repB x))

hmap :: (Generic a, Generic b, Generic1 c) => (a -> b) -> c a -> c b
hmap f x = gmap univ univ univ1 f x

disp :: Generic a => a -> [Char]
disp x = display univ x

eq :: Generic a => a -> a -> Bool
eq x y = equal univ x y

marsh :: Generic a => a -> [Int]
marsh x = marshall univ x

unmarsh :: Generic a => [Int] -> a
unmarsh x = unmarshall univ x


----------------------------------------------------------

equal (Univ nm to from) x y  =  (to x) == (to y)
equal (Iso sh) x y = rEqual sh x y
equal (Leibniz sh) x y = rEqual sh x y


display (Univ nm to from) x = show (to x)
display (Iso shp) x = rShow shp x
display (Leibniz shp) x = rShow shp x

marshall (Univ nm to from) x = reverse (flat (to x) [])

unmarshall (Univ nm to from) xs = from j
  where (j,ks) = (unflat xs)

flat :: Val -> [Int] -> [Int]
flat (Vint n) xs = n : 1 : xs
flat (Vchar c) xs = ord c : 2 : xs
flat Vunit xs = 3: xs
flat (Vfun f) xs = error "no Vfun in marshall"
flat (Vdata s zs) xs = flatList zs (length zs : (flatString s (5: xs)))
flat (Vtuple zs) xs = flatList zs (length zs : 6 : xs)
flat (Vpar n x) xs = flat x (n : 7 : xs)

flatList [] xs = xs
flatList (z:zs) xs = flatList zs (flat z xs)

unflat :: [Int] -> (Val,[Int])
unflat (1: x : xs) = (Vint x,xs)
unflat (2: x : xs) = (Vchar (chr x),xs)
unflat (3: xs) = (Vunit,xs)
unflat (5: xs) = (Vdata s ws,zs)
    where (s,n : ys) = unflatString xs
          (ws,zs) = unflatList n ys
unflat (6: n : xs) = (Vtuple ws,zs) where (ws,zs) = unflatList n xs
unflat (7: n: xs) = (Vpar n x,ys) where (x,ys) = unflat xs
unflat zs = error ("Bad Case in unflat of unmarshall"++ show zs)

unflatList 0 xs = ([],xs)
unflatList n xs = (v:vs,zs)
  where (v,ys)= unflat xs
        (vs,zs) = unflatList (n-1) ys

flatString s xs = (reverse (map ord s)) ++ ((length s) : xs)
unflatString (n:xs) = (map chr (take n xs),drop n xs)

------------------------------------------------
-- The Shape approach

--data Rep t = Univ Name (t -> Val) (Val -> t)
--           | Iso (Shape Iso t)
--           | Leibniz (Shape Leibniz t)

data Shape eq t
  = Sint (eq t Int)
  | Schar (eq t Char)
  | Sunit (eq t ())
  | forall a b . Sfun (Shape eq a) (Shape eq b) (eq t (a->b))
  | forall a b . Spair (Shape eq a) (Shape eq b) (eq t (a,b))
  | forall a b . Splus (Shape eq a) (Shape eq b) (eq t (Either a b))
  | forall a   . Sdata Name (Shape eq t -> Shape eq a) (Iso t a)
  |              Scon String (Shape eq t)
  | Sptr Name (Ptr t)

instance Named (Shape p t) where
	--name :: Shape p t -> Name
	name (Sint p) = App "Int" []
	name (Schar p) = App "Char" []
	name (Sunit p) = App "()" []
	name (Sfun x y p) = App "->" [name x, name y]
	name (Spair x y p) = App "(,)" [name x, name y]
	name (Splus x y p) = App "Either" [name x, name y]
	name (Sdata t x y) = t
	name (Scon s t) = name t
	name (Sptr nm p) = nm

instance Show Name where
  show (App "->" [x @ (App "->" _),y]) =   "("++(show x) ++") -> "++(show y)
  show (App "->" [x,y]) =   (show x) ++" -> "++(show y)
  show (App "(,)" [x,y]) = "("++show x++","++show y++")"
  show (App s []) = s
  show (App s ts) = s ++ " " ++ f ts
    where f [t] = show t
          f (t : ts) = show t ++ " " ++ f ts

----------------------------------------------------------
-- Proofs of equality

class EqProof proof where
  from :: proof a b -> (a -> b)
  to   :: proof a b -> (b -> a)
  self :: proof a a
  inv  :: proof a b -> proof b a
  assoc:: proof a b -> proof b c -> proof a c
  (.+.) :: proof a b -> proof c d -> proof (Either a c) (Either b d)
  (.*.) :: proof a b -> proof c d -> proof (a,c) (b,d)
  (.->.) :: proof a b -> proof c d -> proof (a -> c) (b -> d)
  testEq :: Rep a -> Rep b -> Maybe(proof a b)

f <> g = assoc f g

intP :: EqProof p => Shape p Int
intP = (Sint self)

charP :: EqProof p => Shape p Char
charP = (Schar self)

unitP :: EqProof p => Shape p ()
unitP = (Sunit self)

pairP :: EqProof p => Shape p a -> Shape p b -> Shape p (a,b)
pairP x y = (Spair x y self)

plusP :: EqProof p => Shape p a -> Shape p b -> Shape p (Either a b)
plusP x y = (Splus x y self)

funP :: EqProof p => Shape p a -> Shape p b -> Shape p (a -> b)
funP  x y = (Sfun x y self)

listP :: EqProof p => Shape p a -> Shape p [a]
listP x = Sdata (App "[]" [name x]) intershape (Ep f g)
  where intershape a = plusP unitP (pairP x a)
        f [] = Left ()
        f (x:xs) = Right(x,xs)
        g (Left ()) = []
        g (Right(x,xs)) = x:xs

boolP :: EqProof p => Shape p Bool
boolP = Sdata (App "Bool" [])  struct proof
     where proof = Ep g f
           f (Left _) = True
           f (Right _) = False
           g True = Left ()
           g False = Right ()
           struct x = (plusP unitP unitP)

maybeP :: EqProof p => Shape p a -> Shape p (Maybe a)
maybeP x = Sdata (App "Maybe" [name x])  intershape (Ep f g)
   where intershape rec = plusP unitP x
         f Nothing = Left ()
         f (Just x) = Right x
         g (Left ()) = Nothing
         g (Right x) = Just x

-------------------------------------
-- Iso proofs

data Iso a b = Ep (a->b) (b->a)

instance EqProof Iso where
  from (Ep f g) = f
  to   (Ep f g) = g
  self = Ep id id
  inv f = Ep (to f) (from f)
  assoc f g = Ep (from g . from f) (to f . to g)
  (.+.) = isoE
  (.*.) = isoPair
  (.->.) = isoArrow
  testEq (Iso x) (Iso y) = unify x y


isoE :: (Iso a b) -> (Iso c d) -> Iso (Either a c) (Either b d)
isoE pab pcd = Ep (from pab + from pcd) (to pab + to pcd)
  where (+) f g (Left x)  = Left (f x)
        (+) f g (Right x) = Right(g x)

isoPair :: (Iso a b) -> (Iso c d) -> Iso (a,c) (b,d)
isoPair pab pcd = Ep (from pab * from pcd) (to pab * to pcd)
  where (*) f g (x,y)  = (f x,g y)

isoArrow :: (Iso a b) -> (Iso c d) -> Iso (a -> c) (b -> d)
isoArrow pab pcd = Ep (to pab $-> from pcd) (from pab $-> to pcd)
   where (f $-> g) h =  g . h . f

liftI f (Iso x) (Iso y) = Iso(f x y)

intI :: Rep Int
intI = Iso intP

charI :: Rep Char
charI = Iso charP

unitI :: Rep ()
unitI = Iso unitP

pairI :: Rep a -> Rep b -> Rep (a,b)
pairI = liftI pairP

plusI :: Rep a -> Rep b -> Rep (Either a b)
plusI = liftI plusP

funI :: Rep a -> Rep b -> Rep (a -> b)
funI  = liftI funP

boolI = Iso boolP

{-
f :: Rep a -> Rep b -> (forall x . Rep x -> Rep (t x)) -> (a -> b) -> t a -> t b
f ra rb t g x = walk shta shtb x
  where (Iso shta) = t ra
        (Iso shtb) = t rb
        walk :: (Shape Iso (t a)) -> (Shape Iso (t b)) -> t a -> t b
        walk (Sint p1) (Sint p2) x = to p2 (from p1 x)
        walk (Schar p1) (Schar p2) x = to p2 (from p1 x)
        walk (Sunit p1) (Sunit p2) x = to p2 (from p1 x)
        walk (Spair a b p1) (Spair m n p2) x =
          case from p1 x of
            (i,j) -> to p2 (walk a m i,walk b n j)
-}

-----------------------------------------------------
-- Leibniz proofs

data Leibniz a b = Eq { eq1 :: forall f. f a -> f b }

instance EqProof Leibniz where
  to e = unId . eq1 (inv e) . Id
  from e = unId . eq1 e . Id
  self = Eq id
  inv = flip eq2 self
  assoc = flip eq1
  (.+.) = congruence2
  (.*.) = congruence2
  (.->.) = congruence2
  testEq (Leibniz x) (Leibniz y) = unify x y

newtype Id a = Id { unId :: a}
newtype Flip f a b = Flip { unFlip :: f b a }
eq2 :: Leibniz a b -> f a c -> f b c
eq2 e = unFlip . eq1 e . Flip


liftL f (Leibniz x) (Leibniz y) = Leibniz(f x y)

intL :: Rep Int
charL :: Rep Char
unitL :: Rep ()

intL = Leibniz intP
charL = Leibniz charP
unitL = Leibniz unitP

pairL :: Rep a -> Rep b -> Rep (a,b)
plusL :: Rep a -> Rep b -> Rep (Either a b)
funL :: Rep a -> Rep b -> Rep (a -> b)

pairL = liftL pairP
plusL = liftL plusP
funL  = liftL funP

boolL = Leibniz boolP

-----------------------------------------------------------------
-- Putting it all together

pair x y =
  case (x,y) of
    (Leibniz _ ,Leibniz _ ) -> pairL x y
    (Iso _,Iso _) -> pairI x y
    (Univ _ _ _,Univ _ _ _) -> pairU x y

arrow x y =
  case (x,y) of
   (Leibniz _ ,Leibniz _ ) -> funL x y
   (Iso _,Iso _) -> funI x y
   (Univ _ _ _,Univ _ _ _) -> arrowU x y

plus x y =
  case (x,y) of
    (Leibniz _ ,Leibniz _ ) -> plusL x y
    (Iso _,Iso _) -> plusI x y
    (Univ _ _ _,Univ _ _ _) -> plusU x y

list (x @ (Univ _ _ _)) = listU x
list (x @ (Iso s))      = Iso(listP s)
list (x @ (Leibniz s))  = Leibniz(listP s)

maybeR (x @ (Univ _ _ _)) = maybeU x
maybeR (x @ (Iso s))      = Iso(maybeP s)
maybeR (x @ (Leibniz s))  = Leibniz(maybeP s)



-----------------------------------------------------------------

rEqual :: EqProof p => Shape p a -> a -> a -> Bool
rEqual (Sint ep) x y  =  from ep x == from ep y
rEqual (Schar ep) x y = from ep x == from ep y
rEqual (Sunit ep) x y  = from ep x == from ep y
rEqual (Spair a b ep) x y =
   case (from ep x,from ep y) of
      ((m1,n1),(m2,n2)) -> rEqual a m1 m2 && rEqual b n1 n2
rEqual (Splus a b ep) x y =
   case (from ep x,from ep y) of
      (Left m,Left n) -> rEqual a m n
      (Right m,Right n) -> rEqual b m n
      (_,_) -> False
rEqual (r @ (Sdata trm inter p)) x y = rEqual (inter r) (from p x) (from p y)
rEqual (Scon c s) x y = rEqual s x y
rEqual (Sptr nm p) x y = error "XXX"

rShow :: EqProof p => Shape p a -> a -> String
rShow (Sint p) x = show (from p x)
rShow (Schar p) c = show (from p c)
rShow (Sunit p) x = "()"
rShow (Spair a b p) x = "("++rShow a m++","++rShow b n++")"
   where (m,n) = from p x
rShow (Splus a b p) x =
   case (from p x) of
     Left x -> "(Left "++rShow a x++")"
     Right x -> "(Right "++rShow b x++")"
rShow (r @ (Sdata trm inter p)) x = rShow (inter r) (from p x)
rShow (Scon s (Sunit p)) x = s -- Nullary constructor
rShow (Scon s shp) x = "("++s++" "++(rShow shp x)++")"
rShow (Sptr nm p) x = error "YYYY"

--------------------------------------------------------------------------
-- Strufunski style generic approach
{-
class Generic a where
  . . .
  gmapT :: (forall b . Generic b => b -> b) -> t -> t
  gmapQ :: (forall b . Generic b => b -> r) -> t -> [r]
  gmapM :: Monad m => (forall b . Generic b => b -> m b) -> t -> m t
-}

everywhere :: Generic a => (forall b . Generic b => b -> b) -> a -> a
everywhere f x = f (gmapT (everywhere f) x)

everything :: Generic a => (r -> r -> r) -> (forall b . Generic b => b -> r) -> a -> r
everything plus f x = foldl plus (f x) (gmapQ (everything plus f) x)

cast :: Rep a -> Rep b -> a -> Maybe b
cast (Leibniz r1) (Leibniz r2) a =
  case unify r1 r2 of
    Just p -> Just(from p a)
    Nothing -> Nothing
cast (Iso r1) (Iso r2) a =
  case unify r1 r2 of
    Just p -> Just(from p a)
    Nothing -> Nothing
cast (Univ n1 f1 g1) (Univ n2 f2 g2) a =
  if n1 == n2
     then Just(unsafeCoerce a)
     else Nothing

makeTrans :: Rep a -> Rep b -> (a -> a) -> (b -> b)
makeTrans r1 r2 f =
  case cast (arrow r1 r1) (arrow r2 r2) f of
    Just g -> g
    Nothing -> id

p1 :: Int -> Int
p1 x = x+1

f1 :: Generic a => (a -> a)
f1 = makeTrans leib leib p1

addTrans :: Rep a -> Rep b -> (a -> a) -> (b -> b) -> (b -> b)
addTrans r1 r2 f h =
  case cast (arrow r1 r1) (arrow r2 r2) f of
    Just g -> g
    Nothing -> h

f # g = addTrans leib leib f (makeTrans leib leib g)

mkT f = makeTrans leib leib f

-------------------------------------------
-- Some examples

test1 :: Generic a => a -> a
test1 xs = everywhere (mkT f325) xs

w:: Int
w= 3

f325 :: Int -> Int
f325 3 = 5
f325 x = x


mapg :: (Generic a,Generic1 t) => (a -> b) -> t a -> t b
mapg f x = error "XX"  --gfoldl k z x
  --where k c x = c ((f # mapg f) x)
  --      z x = x

--kk c x = c ((p1 # mapg p1) x)

-------------------------------------------------------------
type Equal a b = Leibniz a b

newtype H f a x = H (Equal (f a) (f x))

congruence1 :: Equal a b -> Equal (f a) (f b)
congruence1 (Eq ab) = case ab (H self) of
	H x -> x

newtype F f a c x            = F (Equal (f a c) (f x c))
newtype G f a c b x          = G (Equal (f a c) (f b x))

congruence2 :: Equal a b -> Equal c d -> Equal (f a c) (f b d)
congruence2 (Eq ab) (Eq cd) =
       case ab (F self) of
         F x -> case cd (G x)   of
                  G y -> y

unify :: EqProof p => Shape p c -> Shape p d -> Maybe (p c d)
unify (Sint p1) (Sint p2) = return(p1 <> inv p2)
unify (Schar p1)(Schar p2) = return(p1 <> inv p2)
unify (Sunit p1)(Sunit p2) = return(p1 <> inv p2)
unify (Sfun d1 c1 p1) (Sfun d2 c2 p2) =
    do deq <- unify d1 d2
       ceq <- unify c1 c2
       return(p1 <> (deq .->. ceq) <> inv p2)
unify (Spair a1 b1 p1) (Spair a2 b2 p2) =
	do aeq <- unify a1 a2
	   beq <- unify b1 b2
           return(p1 <> (aeq .*. beq) <> inv p2)
unify (Splus a1 b1 p1) (Splus a2 b2 p2) =
	do aeq <- unify a1 a2
	   beq <- unify b1 b2
	   return(p1 <> (aeq .+. beq) <> inv p2)
unify (Sdata t1 i1 p1) (Sdata t2 i2 p2) =
  let ptr = newPtr undefined
  in if t1 == t2
        then do { p4 <- unify (i1 (Sptr t1 ptr)) (i2 (Sptr t2 ptr))
                ; unify (Sptr t1 ptr) (Sptr t2 ptr) }
        else Nothing
unify (Sptr _ p1) (Sptr _ p2) = testPtr3 (X self) p1 p2
unify _ _ = Nothing


ex2 = testEq (leib :: Rep[Int]) (leib :: Rep[Int]) :: Maybe (Leibniz [Int] [Int])

------------------------------------------------------------
-- Pointers allow the creation of Proofs of equality
-- Since if x::Ptr a  and y::Ptr b and the pointers are equal,
-- then the things they point to must be the same, so the types of those
-- things I.e. "a" and "b", must also be equal. This is a way to create
-- proofs without looking at the things pointed to. Crucial for
-- creating recursive representations.

newtype Ptr a = Ptr (IORef a)
instance Eq (Ptr a) where
  (Ptr x) == (Ptr y) = x==y
instance Show (Ptr a) where
  show (Ptr x) = "Ptr ?"

newPtr :: a -> Ptr a
newPtr x = Ptr(unsafePerformIO(newIORef x))

data Self p a = X (p a a)

testPtr3 :: Self p a -> Ptr a -> Ptr b -> Maybe (p a b)
testPtr3 (X self) x y =
  if x == unsafeCoerce y
     then Just (unsafeCoerce self)
     else Nothing

primitive unsafeCoerce "primUnsafeCoerce" :: a -> b

----------------------------------------------------------
-- data type definitions for the example

data Company = C [Dept]
data Dept = D Nam Manager [SubUnit]
data SubUnit = PU Employee | DU Dept
data Employee = E Person Salary
data Person = P Nam Address
data Salary = S Int
type Manager = Employee
type Nam = String
type Address = String

genCom :: Company
genCom = C [D "Research" ralf [PU joost, PU marlow],
            D "Strategy" blair []]

ralf,joost,marlow,blair :: Employee

ralf = E (P "Ralf" "Amsterdam") (S 8000)
joost = E (P "Joost" "Amsterdam") (S 1000)
marlow = E (P "Marlow" "Cambridge") (S 2000)
blair = E (P "Blair" "London") (S 15000)

incS k (S s) = (S (s+k))

ex3 = everywhere (mkT (incS 5)) genCom

{-

ex3 =
C [D "Research" (E (P "Ralf" "Amsterdam") (S 8005))
     [PU (E (P "Joost" "Amsterdam") (S 1005)),
      PU (E (P "Marlow" "Cambridge") (S 2005))]
  ,D "Strategy" (E (P "Blair" "London") (S 15005))
     []]

-}

----------------------------------------------------------
-- Generic instances for the example data type definitions

instance Generic Company where
  leib = company
  gmapT f (C x) = C(f x)
  gmapQ f (C x) = [f x]
  gmapM f (C x) = do { a <- f x; return(C a) }

instance Generic Dept where
  leib = dept
  gmapT f (D x y z) = D (f x) (f y) (f z)
  gmapQ f (D x y z) = [f x,f y,f z]
  gmapM f (D x y z) = do { a <- f x; b <- f y; c <- f z; return(D a b c) }


instance Generic SubUnit where
  leib = subUnit
  gmapT f (PU x) = PU(f x)
  gmapT f (DU x) = DU(f x)
  gmapQ f (PU x) = [f x]
  gmapQ f (DU x) = [f x]
  gmapM f (PU x) = do { a <- f x; return(PU a) }
  gmapM f (DU x) = do { a <- f x; return(DU a) }

instance Generic Employee where
  leib = employee
  gmapT f (E x y) = E (f x) (f y)
  gmapQ f (E x y) = [f x,f y]
  gmapM f (E x y) = do { a <- f x; b <- f y; return(E a b) }


instance Generic Person where
  leib = person
  gmapT f (P x y) = P (f x) (f y)
  gmapQ f (P x y) = [f x,f y]
  gmapM f (P x y) = do { a <- f x; b <- f y; return(P a b) }


instance Generic Salary where
  leib = salary
  gmapT f (S x) = S(f x)
  gmapQ f (S x) = [f x]
  gmapM f (S x) = do { a <- f x; return(S a) }

companyS ::  EqProof p => Shape p Company
companyS = Sdata (App "Company" []) h (Ep f g)
  where h x = listP deptS
        f (C xs) = xs
        g xs = C xs

deptS ::  EqProof p => Shape p Dept
deptS = Sdata (App "Dept" []) h (Ep f g)
  where h x = pairP namexS (pairP managerS (listP subUnitS))
        f (D nm m ss) = (nm,(m,ss))
        g (nm,(m,ss)) = D nm m ss

subUnitS ::  EqProof p => Shape p SubUnit
subUnitS = Sdata (App "SubUnit" []) h (Ep f g)
  where h x = plusP employeeS deptS
        f (PU e) = Left e
        f (DU d) = Right d
        g (Left e) = PU e
        g (Right d) = DU d

employeeS ::  EqProof p => Shape p Employee
employeeS = Sdata (App "Employee" []) h (Ep f g)
  where h x = pairP personS salaryS
        f (E a b) = (a,b)
        g (a,b) = E a b

personS ::  EqProof p => Shape p Person
personS = Sdata (App "Person" []) h (Ep f g)
  where h x = pairP namexS addressS
        f (P n a) = (n,a)
        g (n,a) = P n a

salaryS ::  EqProof p => Shape p Salary
salaryS = Sdata (App "Salary" []) h (Ep f g)
  where h x = intP
        f (S x) = x
        g x = S x

addressS ::  EqProof p => Shape p Address
addressS = listP charP

namexS ::  EqProof p => Shape p Nam
namexS = listP charP

managerS ::  EqProof p => Shape p Manager
managerS = employeeS

company = Leibniz companyS
dept = Leibniz deptS
subUnit = Leibniz subUnitS
employee = Leibniz employeeS
person = Leibniz personS
salary = Leibniz salaryS
manager = person
namex = string
address = string
string = list(charL)