Commander.hs

{-# 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 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 (Action action) state = do
  (action', state') <- action state
  runCommanderT action' state'
runCommanderT Defeat _ = return Nothing
runCommanderT (Victory a) _ = return (Just 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 phi (Action action) = Action (fmap (fmap (first (hoistToFunctor phi))) $ fmap phi action)

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