{-# OPTIONS
  -XFlexibleInstances
  -XMultiParamTypeClasses
  -XFunctionalDependencies
  -XUndecidableInstances
  -XOverlappingInstances
#-}

--  -XOverlappingInstances

module Control.Monatron.AutoLift (
 StateM(..), get,put,
 WriterM (..), tell,
 ReaderM(..), ask,local,
 ExcM(..), throw,handle,
 ContM(..), callCC,
 ListM(..), mZero,mPlus,
 module Control.Monatron.Operations
) where

import Control.Monatron.Operations
import Control.Exception (SomeException)


------------------------------------------------------------------
-- State
class Monad m => StateM z m | m -> z where
    stateModel :: AlgModel (StateOp z) m

instance Monad m => StateM z (StateT z m) where
    stateModel = modelStateT

instance (StateM z m, MonadT t) => StateM z (t m) where
    stateModel = liftAlgModel stateModel

get :: StateM z m => m z
get = getX stateModel

put :: StateM z m => z -> m ()
put = putX stateModel

------------------------------------------------------------------
-- Traces
class (Monoid z, Monad m) => WriterM z m | m -> z where
    writerModel :: AlgModel (WriterOp z) m

instance (Monoid z, Monad m) => WriterM z (WriterT z m) where
    writerModel = modelWriterT

instance (Monoid z, WriterM z m, MonadT t) => WriterM z (t m) where
    writerModel = liftAlgModel writerModel

tell :: (Monoid z, WriterM z m) => z -> m ()
tell z = traceX writerModel z

------------------------------------------------------------------
-- Environments
class Monad m => ReaderM z m | m -> z where
    readerModel :: Model (ReaderOp z) m

instance Monad m => ReaderM z (ReaderT z m) where
    readerModel = modelReaderT

instance (ReaderM z m, Functor m, FMonadT t) => ReaderM z (t m) where
    readerModel = liftModel readerModel

ask :: ReaderM z m => m z
ask = askX readerModel

local :: ReaderM z m => (z -> z) -> m a -> m a
local = localX readerModel

------------------------------------------------------------------
-- Throw and Handle
class Monad m => ExcM z m | m -> z where
    throwModel :: AlgModel (ThrowOp z) m
    handleModel :: Model (HandleOp z) m

instance Monad m => ExcM z (ExcT z m) where
    throwModel = modelThrowExcT
    handleModel = modelHandleExcT

instance ExcM SomeException IO where
    throwModel  = modelThrowIO
    handleModel = modelHandleIO

instance (ExcM z m, Functor m, FMonadT t) => ExcM z (t m) where
    throwModel = liftAlgModel throwModel
    handleModel = liftModel handleModel

throw :: ExcM z m => z -> m a
throw = throwX throwModel

handle :: ExcM z m => m a -> (z -> m a) -> m a
handle = handleX handleModel

------------------------------------------------------------------
-- callCC operation

class Monad m => ContM r m | m -> r where
    contModel :: AlgModel (ContOp r) m

instance Monad m => ContM (m r) (ContT r m) where
    contModel = modelContT

instance (ContM r m, MonadT t) => ContM r (t m) where
    contModel = liftAlgModel contModel

callCC :: ContM r m => ((a -> r) -> a) -> m a
callCC = callCCX contModel

------------------------------------------------------------------
-- MPlus operations

class Monad m => ListM m where
    listModel :: AlgModel ListOp m

instance Monad m => ListM (ListT m) where
    listModel = modelListT

instance (ListM m, MonadT t) => ListM (t m) where
    listModel = liftAlgModel listModel

mZero :: (ListM m) => m a
mZero = zeroListX listModel

mPlus :: ListM m => m a -> m a -> m a
mPlus = plusListX listModel