{-# 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)