{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveFunctor #-}
module Control.Monad.Commander (
CommanderT(Action, Defeat, Victory), runCommanderT, hoistToFunctor, hoistFromFunctor,
) where
import Control.Arrow (first)
import Control.Monad (ap, MonadPlus)
import Control.Monad.Trans (MonadTrans, lift, liftIO, MonadIO)
import Control.Applicative (Alternative(empty, (<|>)))
data CommanderT state f a
= Action (state -> f (CommanderT state f a, state))
| Defeat
| Victory a
deriving Functor
runCommanderT :: Monad m
=> CommanderT state m a
-> state
-> m (Maybe a)
runCommanderT (Action action) state = do
(action', state') <- action state
runCommanderT action' state'
runCommanderT Defeat _ = return Nothing
runCommanderT (Victory a) _ = return (Just a)
hoistToFunctor :: Functor g => (forall a. f a -> g a) -> CommanderT state f a -> CommanderT state g a
hoistToFunctor phi (Action action) = Action (fmap (fmap (first (hoistToFunctor phi))) $ fmap phi action)
hoistFromFunctor :: Functor f => (forall a. f a -> g a) -> CommanderT state f a -> CommanderT state g a
hoistFromFunctor phi (Action action) = Action (fmap phi $ fmap (fmap (first (hoistFromFunctor phi))) action)
instance Functor f => Applicative (CommanderT state f) where
(<*>) = ap
pure = Victory
instance MonadTrans (CommanderT state) where
lift ma = Action $ \state -> do
a <- ma
return (pure a, state)
instance MonadIO m => MonadIO (CommanderT state m) where
liftIO ma = Action $ \state -> do
a <- liftIO ma
return (pure a, state)
instance Functor f => Monad (CommanderT state f) where
Defeat >>= _ = Defeat
Victory a >>= f = f a
Action action >>= f = Action (fmap (\(a, s) -> (a >>= f, s)) . action)
instance Functor f => Alternative (CommanderT state f) where
empty = Defeat
Defeat <|> a = a
v@(Victory _) <|> _ = v
Action action <|> p = Action (fmap (\(a, s) -> (a <|> p, s)) . action)