module Control.Monad.Shade
( MonadShade
, ShadeT()
, Shade
, shade
, hide
, shadow
, transfer
) where
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.RWS.Class
import Control.Monad.Error.Class
import Control.Monad.Zip
import Data.Functor.Identity
data ShadeT m b = forall a . ShadeT (m a) (a -> b)
type Shade = ShadeT Identity
instance Functor (ShadeT m) where
f `fmap` ShadeT m p = ShadeT m (f . p)
instance Applicative m => Applicative (ShadeT m) where
pure x = ShadeT (pure x) id
ShadeT m0 p0 <*> ShadeT m1 p1
= ShadeT ((,) <$> m0 <*> m1)
$ \(a0, a1) -> p0 a0 (p1 a1)
instance Monad m => Monad (ShadeT m) where
ShadeT m0 p0 >>= f = ShadeT (join m) id
where
m = shadow . f . p0 <$> m0
instance (Applicative m, Monoid b) => Monoid (ShadeT m b) where
mempty = pure mempty
mappend a b = mappend <$> a <*> b
shadow :: Functor m => ShadeT m b -> m b
shadow (ShadeT a p) = p <$> a
class MonadShade m where
shade :: c a -> (a -> b) -> m c b
transfer :: MonadShade m => (forall a . c0 a -> c1 a) -> m c0 t -> m c1 t
hide :: MonadShade m => c a -> m c a
hide a = shade a id
instance MonadShade ShadeT where
shade = ShadeT
transfer f (ShadeT m t) = ShadeT (f m) t
instance MonadTrans ShadeT where
lift = hide
instance MonadState s m => MonadState s (ShadeT m) where
state = lift . state
instance MonadReader s m => MonadReader s (ShadeT m) where
reader = lift . reader
local f = lift . local f . shadow
instance MonadWriter s m => MonadWriter s (ShadeT m) where
writer = lift . writer
listen = lift . listen . shadow
pass = lift . pass . shadow
tell = lift . tell
instance MonadIO m => MonadIO (ShadeT m) where
liftIO = lift . liftIO
instance Alternative m => Alternative (ShadeT m) where
empty = hide empty
a <|> b = hide $ shadow a <|> shadow b
instance MonadError e m => MonadError e (ShadeT m) where
throwError = lift . throwError
catchError act f = lift (shadow act `catchError` \e -> shadow (f e))
instance Monad m => MonadZip (ShadeT m) where
mzip = liftM2 (,)