{-# OPTIONS -fglasgow-exts -fallow-overlapping-instances -XGenerics -XDeriveDataTypeable #-}
module WouterTest where

import Control.Monad
import Data.Generics hiding ((:+:), Inl, Inr)
import Data.Maybe
import Text.PrettyPrint

---------------------------------
-- Thank you, Wouter Swierstra
---------------------------------
infixr 6 :+:
data (f :+: g) e = Inl (f e) | Inr (g e) deriving (Eq, Data)
{-
instance (Typeable1 f, Typeable1 g, Typeable e) => Typeable ((f :+: g) e) where
    --typeOf l@(Inl (f e)) = mkTyConApp (mkTyCon "Planning.Wouter.:+:") [typeOf e]
    --typeOf r@(Inr (g e)) = mkTyConApp (mkTyCon "Planning.Wouter.:+:") [typeOf e]
    typeOf l@(Inl x) = mkTyConApp (mkTyCon "Planning.Wouter.:+:") [typeOf x, typeOf y]
        where (Inr y) = undefined `asTypeOf` l
    typeOf r@(Inr y) = mkTyConApp (mkTyCon "Planning.Wouter.:+:") [typeOf x, typeOf y]
        where (Inl x) = undefined `asTypeOf` r
-}
instance (Typeable1 f, Typeable1 g) => Typeable1 (f :+: g) where
    typeOf1 l@(Inl x) = mkTyConApp (mkTyCon "Planning.Wouter.:+:") [typeOf1 x, typeOf1 y]
        where (Inr y) = undefined `asTypeOf` l
    typeOf1 r@(Inr y) = mkTyConApp (mkTyCon "Planning.Wouter.:+:") [typeOf1 x, typeOf1 y]
        where (Inl x) = undefined `asTypeOf` r

--deriving instance (Typeable1 f, Typeable1 g) => Typeable1 (f :+: g)



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))
instance Typeable1 f => Typeable (Expr f) where
    typeOf (In x) = mkTyConApp (mkTyCon "Planning.Wouter.Expr") [typeOf1 x]
inject :: (:<:) g  f => g (Expr f) -> Expr f
inject = In . inj


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

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

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

data Atomic t e = Atomic String [t] deriving (Eq, Data)
deriving instance Typeable2 Atomic
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, Data)
deriving instance Typeable1 And
instance Functor And where
    fmap f (And el) = And $ map f el
eAnd el = inject (And el)

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

class Functor f => Printable f where
    exprDoc :: Printable t => f (Expr t) -> 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) = parens $ sep (map (\ (In e) -> exprDoc e) el)


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

test2 :: Expr (And :+: (Atomic (Expr (Const :+: Var))))
test2 = eAnd [
    (atomic "p" [ eConst "c" :: Expr (Const :+: Var), eVar "v1", eVar "v2" ]),
    (atomic "p" [ eConst "c" :: Expr (Const :+: Var), eVar "v2", eVar "v3" ])]


-- Thank you, s.clover

greplace :: (Data a, Typeable b) => a -> b -> Maybe a
greplace x y = once (const Nothing `extM` (const (Just y))) x

once :: MonadPlus m => GenericM m -> GenericM m
once f x = f x `mplus` gmapMo (once f) x

gfind :: (Data a, Typeable b) => a -> Maybe b
gfind = something (const Nothing `extQ` Just)


newtype Name = Name String deriving (Show, Data, Typeable)
unName (Name a) = a
class Data a => HasName a where
    getName :: a -> String
    getName = unName . fromJust . gfind
    setName :: a -> String -> a
    setName = (fromJust .) . (. Name) . greplace


data Effect f = Effect (Maybe f) deriving (Show, Data, Typeable)
unEffect (Effect a) = a
class (Data a, Typeable f) => HasEffect f a where
    getEffect :: a -> Maybe f
    getEffect = unEffect . fromJust . gfind
    setEffect :: a -> Maybe f -> a
    setEffect = (fromJust .) . (. Effect) . greplace


data NamedEffect a = NamedEffect Name (Effect a) deriving (Data, Typeable)

instance (Data a, Typeable a) => HasName (NamedEffect a)
instance (Data a, Typeable a) => HasEffect a (NamedEffect a)

deriving instance Data (Expr (And :+: Atomic (Expr (Const :+: Var))))
deriving instance Data (Expr (Const :+: Var))
--deriving instance Typeable (Expr (And :+: Atomic (Expr (Const :+: Var))))

 
testNamed :: NamedEffect (Expr (And :+: Atomic (Expr (Const :+: Var))))
testNamed = NamedEffect (Name "test") (Effect $ Just test2)


{-
*WouterTest> getName testNamed
??
*WouterTest> getEffect testNamed
-}