IMSOS.hs

{-# LANGUAGE UndecidableInstances
  , FlexibleInstances
  , FlexibleContexts
  , MultiParamTypeClasses
#-}

module Control.Monad.IMSOS 
  (MonadIMSOS(..), runIMSOS, yieldIMSOS
  ,tell
  ,local, reader
  ,get, put, state
  ,fail, throwError, catchError
  ) where

import Control.Applicative (Alternative(..))
import Control.Monad.Error.Class
import Control.Monad.Reader (MonadReader(..))
import Control.Monad.State  (MonadState(..))
import Control.Monad.Writer (MonadWriter(..))
import Control.Monad (ap)

newtype MonadIMSOS r s w me e a = MonadIMSOS (r -> s -> me e (a, s, w))

instance Functor (me e) => Functor (MonadIMSOS r s w me e) where
  fmap f (MonadIMSOS m) = MonadIMSOS m'
    where m' r s = modify <$> m r s
           where modify (a, s', w) = (f a, s', w)

instance (MonadError e (me e), Monad (me e), Monoid w)
    => Monad (MonadIMSOS r s w me e) where
  (MonadIMSOS p) >>= m = MonadIMSOS $ \r1 s1  -> do
     (a, s2, w2) <- p r1 s1
     let MonadIMSOS q = m a
     (b, s3, w3) <- q r1 s2
     return (b, s3, w2 <> w3)

instance (MonadError e (me e), Monad (me e), Monoid w)
    => Applicative (MonadIMSOS r s w me e) where
  pure a = MonadIMSOS m
    where m _ s = pure (a, s, mempty)
  (<*>) = ap

instance (MonadError e (me e), Monad (me e), Alternative (me e), Monoid w)
    => Alternative (MonadIMSOS r s w me e) where
  empty = MonadIMSOS (\_ _ -> empty)
  (MonadIMSOS p) <|> (MonadIMSOS q) = MonadIMSOS m
    where m r s = p r s `catchError` \_ -> q r s
 
--instance (MonadError e (me e), Monad (me e), Monoid w)
--    => MonadPlus (MonadIMSOS r s w me e)

instance (MonadError String (me String), Monad (me String), Monoid w)
    => MonadFail (MonadIMSOS r s w me String) where
  fail = throwError

instance (MonadError e (me e), Monad (me e), Monoid w)
    => MonadReader r (MonadIMSOS r s w me e) where
  ask = MonadIMSOS m 
    where m r s = pure (r, s, mempty)
  local f (MonadIMSOS p) = MonadIMSOS m
    where m r s = p (f r) s

instance (MonadError e (me e), Monad (me e), Monoid w)
    => MonadState s (MonadIMSOS r s w me e) where
  state act = MonadIMSOS m
    where m _ s = pure (a, s', mempty)
           where (a, s') = act s

instance (MonadError e (me e), Monad (me e), Monoid w)
    => MonadWriter w (MonadIMSOS r s w me e) where
  tell w = MonadIMSOS m
    where m _ s = pure ((), s, w)
  listen (MonadIMSOS p) = MonadIMSOS m
    where m r s = p r s >>= \(a, s', w) -> pure ((a,w), s', w)
  pass (MonadIMSOS p) = MonadIMSOS m
    where m r s = p r s >>= \((a,f), s', w) -> pure (a, s', f w)

instance (MonadError e (me e), Monad (me e), Monoid w)
    => MonadError e (MonadIMSOS r s w me e) where
  throwError e = MonadIMSOS m
    where m _ _ = throwError e
  catchError (MonadIMSOS p) h = MonadIMSOS m
    where m r s = p r s `catchError` \e -> 
                  let MonadIMSOS q = h e
                  in q r s -- continues with a state as if p not executed

runIMSOS :: r -> s -> MonadIMSOS r s w me e a -> me e (a, s, w)
runIMSOS r s (MonadIMSOS f) = f r s

yieldIMSOS :: Functor (me e) => 
  r -> s -> ((a, s, w) -> y) -> MonadIMSOS r s w me e a -> me e y
yieldIMSOS r s toyield m = toyield <$> runIMSOS r s m