{-# OPTIONS_GHC 
  -XOverlappingInstances -XTypeOperators 
  -XMultiParamTypeClasses -XFlexibleInstances #-}

module WouterTest where

import Prelude hiding (and, const)
import Text.PrettyPrint

---------------------------------
-- Thank you, Wouter Swierstra
---------------------------------
data (f :+: g) e = Inl (f e) | Inr (g e) deriving 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)


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

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


---------------------------------
-- Expression Definitions
---------------------------------

data Const e = Const String deriving Eq
instance Functor Const where
    fmap f (Const x) = Const x
const x = inject (Const x)

data Var e = Var String deriving Eq
instance Functor Var where
    fmap f (Var x) = Var x
var x = inject (Var x)

data Atomic t e = Atomic String [t] deriving Eq
instance Functor (Atomic a) where
    fmap f (Atomic p tl) = Atomic p tl
atomic p tl = inject (Atomic p tl)

data And e = And [e] deriving Eq
instance Functor And where
    fmap f (And el) = And $ map f el
and el = inject (And el)

---------------------------------
-- An application (pretty printing)
---------------------------------

class Functor f => Printable f where
    exprDoc :: Printable g => f (Expr g) -> Doc

instance Printable f => Show (Expr f) where
    show (In f) = render $ exprDoc f

instance (Printable f, Printable g) => Printable (f :+: g) where
    exprDoc (Inr x) = exprDoc x
    exprDoc (Inl y) = exprDoc y

instance Printable Var where
   exprDoc (Var name) = text ('?':name)


instance Printable Const where
   exprDoc (Const name) = text name

instance Printable f => Printable (Atomic (Expr f)) where
   exprDoc (Atomic p tl) = parens $ hsep $
       (text p) : (map (\ (In t) -> exprDoc t) tl)

instance Printable And where
    exprDoc (And el) = sep (map showDoc el)

showDoc :: Printable f => Expr f -> Doc
showDoc (In t) = exprDoc t

test1 :: Expr (Atomic (Expr (Const :+: Var)))
test1 = (atomic "p" [ const "c" :: Expr (Const :+: Var), var "v1", var "v2" ])

test2 :: Expr (And :+: (Atomic (Expr (Const :+: Var))))
test2 = and [
    (atomic "p" [ const "c" :: Expr (Const :+: Var), var "v1", var "v2" ]),
    (atomic "p" [ const "c" :: Expr (Const :+: Var), var "v2", var "v3" ])]