{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}

module Control.Monad.Objective.Class where
import Control.Object

#if MIN_VERSION_transformers(0,4,0)
import Control.Monad.Trans.Except
#else
import Control.Monad.Trans.Error
#endif
import Control.Monad.Trans.Identity
import Control.Monad.Trans.List
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State.Lazy as Lazy
import Control.Monad.Trans.State.Strict as Strict
import Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Trans.Writer.Strict as Strict
import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS
import qualified Control.Monad.Trans.RWS.Strict as StrictRWS
import Data.Monoid
import Control.Monad

infix 3 .-
infix 3 .&

class Monad m => MonadObjective m where

  data Address (e :: * -> *) (m :: * -> *)
  type Residence (m :: * -> *) :: * -> *
  -- Control e f = Control e (Base f)
  -- | Send a message to the pointed one.
  (.-) :: Address e m -> e a -> m a
  -- | Add an object to the environment.
  invoke :: Object e (Residence m) -> m (Address e m)

(.&) :: (MonadObjective m, Stateful s e) => Address e m -> Strict.StateT s m a -> m a
c .& m = do
  s <- c .- get_
  (a, s') <- Strict.runStateT m s
  c .- put_ s'
  return a

instance MonadObjective m => MonadObjective (ReaderT r m) where
  data Address e (ReaderT r m) = WrapReaderT (Address e m)
  type Residence (ReaderT r m) = Residence m
  WrapReaderT c .- e = lift (c .- e)
  invoke = liftM WrapReaderT . lift . invoke

instance (Monoid w, MonadObjective m) => MonadObjective (LazyRWS.RWST r w s m) where
  data Address e (LazyRWS.RWST r w s m) = WrapLazyRWST (Address e m)
  type Residence (LazyRWS.RWST r w s m) = Residence m
  WrapLazyRWST c .- e = lift (c .- e)
  invoke = liftM WrapLazyRWST . lift . invoke

instance (Monoid w, MonadObjective m) => MonadObjective (StrictRWS.RWST r w s m) where
  data Address e (StrictRWS.RWST r w s m) = WrapStrictRWST (Address e m)
  type Residence (StrictRWS.RWST r w s m) = Residence m
  WrapStrictRWST c .- e = lift (c .- e)
  invoke = liftM WrapStrictRWST . lift . invoke

instance MonadObjective m => MonadObjective (ContT r m) where
  data Address e (ContT r m) = WrapContT (Address e m)
  type Residence (ContT r m) = Residence m
  WrapContT c .- e = lift (c .- e)
  invoke = liftM WrapContT . lift . invoke

#if MIN_VERSION_transformers(0,4,0)
instance MonadObjective m => MonadObjective (ExceptT er m) where
  data Address e (ExceptT er m) = WrapExceptT (Address e m)
  type Residence (ExceptT er m) = Residence m
  WrapExceptT c .- e = lift (c .- e)
  invoke = liftM WrapExceptT . lift . invoke
#else
instance (Error er, MonadObjective m) => MonadObjective (ErrorT er m) where
  data Address e (ErrorT er m) = WrapErrorT (Address e m)
  type Residence (ErrorT er m) = Residence m
  WrapErrorT c .- e = lift (c .- e)
  invoke = liftM WrapErrorT . lift . invoke
#endif

instance MonadObjective m => MonadObjective (IdentityT m) where
  data Address e (IdentityT m) = WrapIdentityT (Address e m)
  type Residence (IdentityT m) = Residence m
  WrapIdentityT c .- e = lift (c .- e)
  invoke = liftM WrapIdentityT . lift . invoke

instance MonadObjective m => MonadObjective (ListT m) where
  data Address e (ListT m) = WrapListT (Address e m)
  type Residence (ListT m) = Residence m
  WrapListT c .- e = lift (c .- e)
  invoke = liftM WrapListT . lift . invoke

instance MonadObjective m => MonadObjective (MaybeT m) where
  data Address e (MaybeT m) = WrapMaybeT (Address e m)
  type Residence (MaybeT m) = Residence m
  WrapMaybeT c .- e = lift (c .- e)
  invoke = liftM WrapMaybeT . lift . invoke

instance MonadObjective m => MonadObjective (Lazy.StateT s m) where
  data Address e (Lazy.StateT s m) = WrapLazyStateT (Address e m)
  type Residence (Lazy.StateT s m) = Residence m
  WrapLazyStateT c .- e = lift (c .- e)
  invoke = liftM WrapLazyStateT . lift . invoke

instance MonadObjective m => MonadObjective (Strict.StateT s m) where
  data Address e (Strict.StateT s m) = WrapStrictStateT (Address e m)
  type Residence (Strict.StateT s m) = Residence m
  WrapStrictStateT c .- e = lift (c .- e)
  invoke = liftM WrapStrictStateT . lift . invoke

instance (Monoid w, MonadObjective m) => MonadObjective (Lazy.WriterT w m) where
  data Address e (Lazy.WriterT w m) = WrapLazyWriterT (Address e m)
  type Residence (Lazy.WriterT w m) = Residence m
  WrapLazyWriterT c .- e = lift (c .- e)
  invoke = liftM WrapLazyWriterT . lift . invoke

instance (Monoid w, MonadObjective m) => MonadObjective (Strict.WriterT w m) where
  data Address e (Strict.WriterT w m) = WrapStrictWriterT (Address e m)
  type Residence (Strict.WriterT w m) = Residence m
  WrapStrictWriterT c .- e = lift (c .- e)
  invoke = liftM WrapStrictWriterT . lift . invoke