{-# 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 a -> CommanderT state f b -> CommanderT state f a
(a -> b) -> CommanderT state f a -> CommanderT state f b
(forall a b.
(a -> b) -> CommanderT state f a -> CommanderT state f b)
-> (forall a b. a -> CommanderT state f b -> CommanderT state f a)
-> Functor (CommanderT state f)
forall a b. a -> CommanderT state f b -> CommanderT state f a
forall a b.
(a -> b) -> CommanderT state f a -> CommanderT state f b
forall state (f :: * -> *) a b.
Functor f =>
a -> CommanderT state f b -> CommanderT state f a
forall state (f :: * -> *) a b.
Functor f =>
(a -> b) -> CommanderT state f a -> CommanderT state f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CommanderT state f b -> CommanderT state f a
$c<$ :: forall state (f :: * -> *) a b.
Functor f =>
a -> CommanderT state f b -> CommanderT state f a
fmap :: (a -> b) -> CommanderT state f a -> CommanderT state f b
$cfmap :: forall state (f :: * -> *) a b.
Functor f =>
(a -> b) -> CommanderT state f a -> CommanderT state f b
Functor
runCommanderT :: Monad m
=> CommanderT state m a
-> state
-> m (Maybe a)
runCommanderT :: CommanderT state m a -> state -> m (Maybe a)
runCommanderT (Action state -> m (CommanderT state m a, state)
action) state
state = do
(CommanderT state m a
action', state
state') <- state -> m (CommanderT state m a, state)
action state
state
CommanderT state m a -> state -> m (Maybe a)
forall (m :: * -> *) state a.
Monad m =>
CommanderT state m a -> state -> m (Maybe a)
runCommanderT CommanderT state m a
action' state
state'
runCommanderT CommanderT state m a
Defeat state
_ = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
runCommanderT (Victory a
a) state
_ = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
hoistToFunctor :: Functor g => (forall a. f a -> g a) -> CommanderT state f a -> CommanderT state g a
hoistToFunctor :: (forall a. f a -> g a)
-> CommanderT state f a -> CommanderT state g a
hoistToFunctor forall a. f a -> g a
phi (Action state -> f (CommanderT state f a, state)
action) = (state -> g (CommanderT state g a, state)) -> CommanderT state g a
forall state (f :: * -> *) a.
(state -> f (CommanderT state f a, state)) -> CommanderT state f a
Action ((g (CommanderT state f a, state)
-> g (CommanderT state g a, state))
-> (state -> g (CommanderT state f a, state))
-> state
-> g (CommanderT state g a, state)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((CommanderT state f a, state) -> (CommanderT state g a, state))
-> g (CommanderT state f a, state)
-> g (CommanderT state g a, state)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CommanderT state f a -> CommanderT state g a)
-> (CommanderT state f a, state) -> (CommanderT state g a, state)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((forall a. f a -> g a)
-> CommanderT state f a -> CommanderT state g a
forall (g :: * -> *) (f :: * -> *) state a.
Functor g =>
(forall a. f a -> g a)
-> CommanderT state f a -> CommanderT state g a
hoistToFunctor forall a. f a -> g a
phi))) ((state -> g (CommanderT state f a, state))
-> state -> g (CommanderT state g a, state))
-> (state -> g (CommanderT state f a, state))
-> state
-> g (CommanderT state g a, state)
forall a b. (a -> b) -> a -> b
$ (f (CommanderT state f a, state)
-> g (CommanderT state f a, state))
-> (state -> f (CommanderT state f a, state))
-> state
-> g (CommanderT state f a, state)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (CommanderT state f a, state) -> g (CommanderT state f a, state)
forall a. f a -> g a
phi state -> f (CommanderT state f a, state)
action)
hoistToFunctor forall a. f a -> g a
_phi CommanderT state f a
Defeat = CommanderT state g a
forall state (f :: * -> *) a. CommanderT state f a
Defeat
hoistToFunctor forall a. f a -> g a
_phi (Victory a
a) = a -> CommanderT state g a
forall state (f :: * -> *) a. a -> CommanderT state f a
Victory a
a
hoistFromFunctor :: Functor f => (forall a. f a -> g a) -> CommanderT state f a -> CommanderT state g a
hoistFromFunctor :: (forall a. f a -> g a)
-> CommanderT state f a -> CommanderT state g a
hoistFromFunctor forall a. f a -> g a
phi (Action state -> f (CommanderT state f a, state)
action) = (state -> g (CommanderT state g a, state)) -> CommanderT state g a
forall state (f :: * -> *) a.
(state -> f (CommanderT state f a, state)) -> CommanderT state f a
Action ((f (CommanderT state g a, state)
-> g (CommanderT state g a, state))
-> (state -> f (CommanderT state g a, state))
-> state
-> g (CommanderT state g a, state)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (CommanderT state g a, state) -> g (CommanderT state g a, state)
forall a. f a -> g a
phi ((state -> f (CommanderT state g a, state))
-> state -> g (CommanderT state g a, state))
-> (state -> f (CommanderT state g a, state))
-> state
-> g (CommanderT state g a, state)
forall a b. (a -> b) -> a -> b
$ (f (CommanderT state f a, state)
-> f (CommanderT state g a, state))
-> (state -> f (CommanderT state f a, state))
-> state
-> f (CommanderT state g a, state)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((CommanderT state f a, state) -> (CommanderT state g a, state))
-> f (CommanderT state f a, state)
-> f (CommanderT state g a, state)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CommanderT state f a -> CommanderT state g a)
-> (CommanderT state f a, state) -> (CommanderT state g a, state)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((forall a. f a -> g a)
-> CommanderT state f a -> CommanderT state g a
forall (f :: * -> *) (g :: * -> *) state a.
Functor f =>
(forall a. f a -> g a)
-> CommanderT state f a -> CommanderT state g a
hoistFromFunctor forall a. f a -> g a
phi))) state -> f (CommanderT state f a, state)
action)
hoistFromFunctor forall a. f a -> g a
_phi CommanderT state f a
Defeat = CommanderT state g a
forall state (f :: * -> *) a. CommanderT state f a
Defeat
hoistFromFunctor forall a. f a -> g a
_phi (Victory a
a) = a -> CommanderT state g a
forall state (f :: * -> *) a. a -> CommanderT state f a
Victory a
a
instance Functor f => Applicative (CommanderT state f) where
<*> :: CommanderT state f (a -> b)
-> CommanderT state f a -> CommanderT state f b
(<*>) = CommanderT state f (a -> b)
-> CommanderT state f a -> CommanderT state f b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
pure :: a -> CommanderT state f a
pure = a -> CommanderT state f a
forall state (f :: * -> *) a. a -> CommanderT state f a
Victory
instance MonadTrans (CommanderT state) where
lift :: m a -> CommanderT state m a
lift m a
ma = (state -> m (CommanderT state m a, state)) -> CommanderT state m a
forall state (f :: * -> *) a.
(state -> f (CommanderT state f a, state)) -> CommanderT state f a
Action ((state -> m (CommanderT state m a, state))
-> CommanderT state m a)
-> (state -> m (CommanderT state m a, state))
-> CommanderT state m a
forall a b. (a -> b) -> a -> b
$ \state
state -> do
a
a <- m a
ma
(CommanderT state m a, state) -> m (CommanderT state m a, state)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> CommanderT state m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a, state
state)
instance MonadIO m => MonadIO (CommanderT state m) where
liftIO :: IO a -> CommanderT state m a
liftIO IO a
ma = (state -> m (CommanderT state m a, state)) -> CommanderT state m a
forall state (f :: * -> *) a.
(state -> f (CommanderT state f a, state)) -> CommanderT state f a
Action ((state -> m (CommanderT state m a, state))
-> CommanderT state m a)
-> (state -> m (CommanderT state m a, state))
-> CommanderT state m a
forall a b. (a -> b) -> a -> b
$ \state
state -> do
a
a <- IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
ma
(CommanderT state m a, state) -> m (CommanderT state m a, state)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> CommanderT state m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a, state
state)
instance Functor f => Monad (CommanderT state f) where
CommanderT state f a
Defeat >>= :: CommanderT state f a
-> (a -> CommanderT state f b) -> CommanderT state f b
>>= a -> CommanderT state f b
_ = CommanderT state f b
forall state (f :: * -> *) a. CommanderT state f a
Defeat
Victory a
a >>= a -> CommanderT state f b
f = a -> CommanderT state f b
f a
a
Action state -> f (CommanderT state f a, state)
action >>= a -> CommanderT state f b
f = (state -> f (CommanderT state f b, state)) -> CommanderT state f b
forall state (f :: * -> *) a.
(state -> f (CommanderT state f a, state)) -> CommanderT state f a
Action (((CommanderT state f a, state) -> (CommanderT state f b, state))
-> f (CommanderT state f a, state)
-> f (CommanderT state f b, state)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(CommanderT state f a
a, state
s) -> (CommanderT state f a
a CommanderT state f a
-> (a -> CommanderT state f b) -> CommanderT state f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> CommanderT state f b
f, state
s)) (f (CommanderT state f a, state)
-> f (CommanderT state f b, state))
-> (state -> f (CommanderT state f a, state))
-> state
-> f (CommanderT state f b, state)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. state -> f (CommanderT state f a, state)
action)
instance Functor f => Alternative (CommanderT state f) where
empty :: CommanderT state f a
empty = CommanderT state f a
forall state (f :: * -> *) a. CommanderT state f a
Defeat
CommanderT state f a
Defeat <|> :: CommanderT state f a
-> CommanderT state f a -> CommanderT state f a
<|> CommanderT state f a
a = CommanderT state f a
a
v :: CommanderT state f a
v@(Victory a
_) <|> CommanderT state f a
_ = CommanderT state f a
v
Action state -> f (CommanderT state f a, state)
action <|> CommanderT state f a
p = (state -> f (CommanderT state f a, state)) -> CommanderT state f a
forall state (f :: * -> *) a.
(state -> f (CommanderT state f a, state)) -> CommanderT state f a
Action (((CommanderT state f a, state) -> (CommanderT state f a, state))
-> f (CommanderT state f a, state)
-> f (CommanderT state f a, state)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(CommanderT state f a
a, state
s) -> (CommanderT state f a
a CommanderT state f a
-> CommanderT state f a -> CommanderT state f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CommanderT state f a
p, state
s)) (f (CommanderT state f a, state)
-> f (CommanderT state f a, state))
-> (state -> f (CommanderT state f a, state))
-> state
-> f (CommanderT state f a, state)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. state -> f (CommanderT state f a, state)
action)