{-# LANGUAGE RankNTypes #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveFunctor #-} {- | Module: Control.Monad.Commander Description: A monad for stateful, backtracking computations Copyright: (c) Samuel Schlesinger 2020 License: MIT Maintainer: sgschlesinger@gmail.com Stability: experimental Portability: POSIX, Windows -} module Control.Monad.Commander ( -- ** The CommanderT Monad {- | The 'CommanderT' monad is stateful and has the ability to backtrack. -} 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, (<|>))) -- | A 'CommanderT' action is a metaphor for a military commander. At each -- step, we have a new 'Action' to take, or we could have experienced -- 'Defeat', or we can see 'Victory'. While a real life commander -- worries about moving his troops around in order to achieve a victory in -- battle, a 'CommanderT' worries about iteratively transforming a state -- to find some value. -- -- In more practical terms, a term of type 'CommanderT' can be thought of -- as a backtracking, stateful computation which can either result in -- a result being produced, or nothing being produced. It is a -- 'Monad' for any base 'Functor' you want to use as the effect inside of -- the stateful computation, similarly to the free monad. 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 -- | We can run a 'CommanderT' on some state and see if it has -- a successful campaign. 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) -- | We can go from a non-'Functor' to a 'Functor' inside of a 'CommanderT' -- action. This does the transformation "top to bottom", as opposed to -- 'hoistFromFunctor', which does it "bottom to top". If your natural -- transformation is lessening, i.e. it trims branching structure, then you -- probably want to use this function. 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 -- | We can go from a 'Functor' to a non-'Functor' inside of a 'CommanderT' -- action. This does the transformation "bottom to top", as opposed to -- 'hoistToFunctor', which does it "top to bottom". If your natural -- transformation is increasing, i.e. it adds branching structure, then you -- probably want to use this function. 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)