{-# OPTIONS_GHC -fglasgow-exts #-}
{-# OPTIONS_GHC -fallow-undecidable-instances #-}

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

data HNil = HNil           deriving (Eq,Show,Read)
data HCons e l = HCons e l deriving (Eq,Read)

instance (Show e, Show l) => Show (HCons e l) where
    show (HCons e l) = show e ++ " .*. " ++ show l

type e :*: l = HCons e l

class HList l
instance HList HNil
instance HList l => HList (e :*: l)

infixr 2 .*.
(.*.) :: HList l => e -> l -> HCons e l
(.*.) = HCons

test1 = 5 .*. True .*. "foo" .*. (Just 2) .*. HNil

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

-- A heterogeneous apply operator
class Apply f a r | f a -> r where
  apply :: f -> a -> r
  apply = undefined			-- In case we use Apply for
                                        -- type-level computations only

-- Normal function application
instance Apply (x -> y) x y where
  apply f x = f x

-- Identity
data Id = Id

instance Apply Id x x where
  apply _ x = x

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

class HMap f l l' | f l -> l' where
    hMap :: f -> l -> l'

instance HMap f HNil HNil where
    hMap f HNil = HNil

instance (Apply f x y, HMap f xs ys) => 
    HMap f (HCons x xs) (HCons y ys) 
  where
    hMap f (HCons x xs) = HCons (apply f x) (hMap f xs)

------------------------------------------------------------------------------
data FShow = FShow
instance Show a => Apply FShow a String where
    apply _ x = show x


------------------------------------------------------------------------------
data T
class Foo ns a b c | ns -> a, ns -> b, ns -> c where
    mkFoo :: ns
    defaultA :: a
    defaultB :: c -> IO b
    defaultC :: [T] -> c
    f :: c -> b -> a -> (b, Int)

data X;  data XA = XA;  data XB = XB;  data XC = XC
instance Foo X XA XB XC where
    mkFoo = undefined
    defaultA    = XA
    defaultB XC = return XB
    defaultC _  = XC
    f _ b _ = (b,0)
mkX = mkFoo :: X

data Y;  data YA = YA;  data YB = YB;  data YC = YC
instance Foo Y YA YB YC where
    mkFoo = undefined
    defaultA    = YA
    defaultB YC = return YB
    defaultC _  = YC
    f _ b _ = (b,1)
mkY = mkFoo :: Y

config = mkX .*. mkY .*. HNil
                  
data DefaultA
instance Foo ns a b c => Apply DefaultA ns a where
    apply _ _ = defaultA