{-# OPTIONS -fglasgow-exts #-}

module Polymatch () where


import Data.Typeable
import Data.Generics


-- Representation of kids
kids x = gmapQ Kid x -- get all kids
type Kids = [Kid]
data Kid  = forall k. Typeable k => Kid k


-- Build term from a list of kids and the constructor 
fromConstrL :: Data a => Kids -> Constr -> Maybe a
fromConstrL l = unIDL . gunfold k z
 where
  z c = IDL (Just c) l
  k (IDL Nothing _) = IDL Nothing undefined
  k (IDL (Just f) (Kid x:l)) = IDL f' l
   where
    f' = case cast x of
          (Just x') -> Just (f x')
          _         -> Nothing


-- Helper datatype
data IDL x = IDL (Maybe x) Kids
unIDL (IDL mx _) = mx


-- Two sample datatypes
data A = A String deriving (Read, Show, Eq, Data, Typeable)
data B = B String deriving (Read, Show, Eq, Data, Typeable)


-- Mediate between two "left-equal" Either types
f :: (Data a, Data b, Show a, Read b)
  => (a->b) -> Either String a -> Either String b

f g (Right a)    = Right $ g a       -- conversion really needed
-- f g (Left  s) = Left s            -- unappreciated conversion
-- f g s         = s                 -- doesn't typecheck 
-- f g s         = deep_rebuild s    -- too expensive
f g s            = just (shallow_rebuild s) -- perhaps this is Ok?


-- Get rid of maybies
just = maybe (error "tried, but failed.") id


-- Just mentioned for completeness' sake
deep_rebuild :: (Show a, Read b) => a -> b
deep_rebuild = read . show


-- For the record: it's possible.
shallow_rebuild :: (Data a, Data b) => a -> Maybe b
shallow_rebuild a = b 
 where
  b      = fromConstrL (kids a) constr
  constr = indexConstr (dataTypeOf b) (constrIndex (toConstr a))


-- Test cases
a2b (A s) = B s            -- silly conversion
t1 = f a2b (Left "x")      -- prints Left "x"
t2 = f a2b (Right (A "y")) -- prints Right (B "y")