{-# OPTIONS 
 -fglasgow-exts
 -fallow-overlapping-instances
  #-}
module DerivingError where

--import Data.Generics hiding ((:+:), Inl, Inr)
import Data.Generics (Data, Typeable, Typeable1, Typeable2, mkTyCon, mkTyConApp, typeOf, typeOf1)

--------------------------------
-- Expressions 
--------------------------------

infixr 6 :+:
data (f :+: g) e = Inl (f e) | Inr (g e) deriving (Data, Eq)

instance (Functor f, Functor g) => Functor (f :+: g) where
    fmap f (Inl e1) = Inl (fmap f e1)
    fmap f (Inr e2) = Inr (fmap f e2)

instance (Typeable1 f, Typeable1 g) => Typeable1 (f :+: g) where
    typeOf1 l = mkTyConApp (mkTyCon "Planning.Wouter.:+:") [typeOf1 x, typeOf1 y] where
        Inl x = (Inl undefined) `asTypeOf` l
        Inr y = (Inr undefined) `asTypeOf` l


class (Functor sub, Functor sup) => sub :<: sup where
    inj :: sub a -> sup a

instance Functor f => (:<:) f f where
    inj = id

instance (Functor f, Functor g) => (:<:) f (f :+: g) where
    inj = Inl

instance (Functor f, Functor g, Functor h, (:<:) f g) => (:<:) f (h :+: g) where
    inj = Inr . inj

newtype Expr f = In (f (Expr f))
instance Typeable1 f => Typeable (Expr f) where
    typeOf e = mkTyConApp (mkTyCon "Planning.Wouter.Expr") [typeOf1 x]
        where In x = (In undefined) `asTypeOf` e

inject :: (g :<: f) => g (Expr f) -> Expr f
inject = In . inj

--------------------------------
-- Utilities
--------------------------------
foldExpr :: Functor f => (f a -> a) -> Expr f -> a
foldExpr f (In t) = f (fmap (foldExpr f) t)

class Functor f => FuncEq f where
    funcEq :: FuncEq g => f (Expr g) -> f (Expr g) -> Bool

instance (FuncEq f, FuncEq g) => FuncEq (f :+: g) where
    funcEq (Inl x) (Inl y) = funcEq x y
    funcEq (Inr x) (Inr y) = funcEq x y
    funcEq _ _ = False

instance (FuncEq f) => Eq (Expr f) where
    (In x) == (In y) = funcEq x y

data Const e = Const String deriving (Data, Eq)
deriving instance Typeable1 Const
instance Functor Const where
    fmap f (Const x) = Const x
instance FuncEq Const where
    funcEq (Const x) (Const y) = x == y
eConst x = inject (Const x)

data Var e = Var String deriving (Data, Eq)
deriving instance Typeable1 Var
instance Functor Var where
    fmap f (Var x) = Var x
instance FuncEq Var where
    funcEq (Var x) (Var y) = x == y
eVar x = inject (Var x)

----------------------------------
-- Data instance derivations
----------------------------------
deriving instance Data (Expr Const)
deriving instance Data (Expr Var)