{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Delegate where
import Control.Monad.Trans.Class
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Except
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
class Monad m => MonadDelegate r m | m -> r where
delegate :: ((a -> m r) -> m r) -> m a
instance Monad m => MonadDelegate r (ContT r m) where
delegate f = ContT $ \k -> evalContT $ f (lift . k)
instance (MonadDelegate r m) => MonadDelegate r (IdentityT m) where
delegate f = IdentityT $ delegate $ \k -> runIdentityT $ f (lift . k)
instance (MonadDelegate r m) => MonadDelegate r (ReaderT env m) where
delegate f = ReaderT $ \r -> delegate $ \k -> (`runReaderT` r) $ f (lift . k)
instance (MonadDelegate r m) => MonadDelegate r (MaybeT m) where
delegate f = MaybeT . delegate $ \k -> do
a <- runMaybeT . f $ lift . k . Just
case a of
Nothing -> k Nothing
Just a' -> pure a'
instance (MonadDelegate r m) => MonadDelegate r (ExceptT e m) where
delegate f = ExceptT . delegate $ \kea -> do
e <- runExceptT . f $ lift . kea . Right
case e of
Left e' -> kea (Left e')
Right r -> pure r
finish :: forall a r m. MonadDelegate r m => m r -> m a
finish = delegate . const
multitask :: MonadDelegate r m => ((a -> m r) -> (b -> m r) -> m r) -> m (Either a b)
multitask g = delegate $ \fab -> g (fab . Left) (fab . Right)
bind2 :: Monad m => m (Either a b) -> (a -> m r) -> (b -> m r) -> m r
bind2 m fa fb = m >>= either fa fb
bindRight :: Monad m => m (Either a b) -> (b -> m c) -> m (Either a c)
bindRight m k = bind2 m (pure . Left) (fmap Right . k)
bindLeft :: Monad m => m (Either a b) -> (a -> m c) -> m (Either c b)
bindLeft m k = bind2 m (fmap Left . k) (pure . Right)
finishLeft :: MonadDelegate r m => m (Either r b) -> m b
finishLeft m = m >>= either (finish . pure) pure
finishRight :: MonadDelegate r m => m (Either a r) -> m a
finishRight m = m >>= either pure (finish . pure)
maybeDelegate :: MonadDelegate r m => r -> m (Maybe a) -> m a
maybeDelegate r m = delegate $ \fire -> do
ma <- m
case ma of
Nothing -> pure r
Just a -> fire a