--------------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.State.Persistent
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--------------------------------------------------------------------------------
module Control.Monad.State.Persistent( PersistentStateT
                                     , PersistentState
                                     , store
                                     , runPersistentStateT
                                     , runPersistentState
                                     ) where

import Control.Monad.State
import Control.Monad.Identity(Identity(..))
import Data.List.NonEmpty(NonEmpty(..),(<|),toList)

--------------------------------------------------------------------------------

-- | A State monad that can store earlier versions of the state.
newtype PersistentStateT s m a =
  PersistentStateT (StateT (NonEmpty s) m a)
  deriving (a -> PersistentStateT s m b -> PersistentStateT s m a
(a -> b) -> PersistentStateT s m a -> PersistentStateT s m b
(forall a b.
 (a -> b) -> PersistentStateT s m a -> PersistentStateT s m b)
-> (forall a b.
    a -> PersistentStateT s m b -> PersistentStateT s m a)
-> Functor (PersistentStateT s m)
forall a b. a -> PersistentStateT s m b -> PersistentStateT s m a
forall a b.
(a -> b) -> PersistentStateT s m a -> PersistentStateT s m b
forall s (m :: * -> *) a b.
Functor m =>
a -> PersistentStateT s m b -> PersistentStateT s m a
forall s (m :: * -> *) a b.
Functor m =>
(a -> b) -> PersistentStateT s m a -> PersistentStateT s m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PersistentStateT s m b -> PersistentStateT s m a
$c<$ :: forall s (m :: * -> *) a b.
Functor m =>
a -> PersistentStateT s m b -> PersistentStateT s m a
fmap :: (a -> b) -> PersistentStateT s m a -> PersistentStateT s m b
$cfmap :: forall s (m :: * -> *) a b.
Functor m =>
(a -> b) -> PersistentStateT s m a -> PersistentStateT s m b
Functor,Functor (PersistentStateT s m)
a -> PersistentStateT s m a
Functor (PersistentStateT s m)
-> (forall a. a -> PersistentStateT s m a)
-> (forall a b.
    PersistentStateT s m (a -> b)
    -> PersistentStateT s m a -> PersistentStateT s m b)
-> (forall a b c.
    (a -> b -> c)
    -> PersistentStateT s m a
    -> PersistentStateT s m b
    -> PersistentStateT s m c)
-> (forall a b.
    PersistentStateT s m a
    -> PersistentStateT s m b -> PersistentStateT s m b)
-> (forall a b.
    PersistentStateT s m a
    -> PersistentStateT s m b -> PersistentStateT s m a)
-> Applicative (PersistentStateT s m)
PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m b
PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m a
PersistentStateT s m (a -> b)
-> PersistentStateT s m a -> PersistentStateT s m b
(a -> b -> c)
-> PersistentStateT s m a
-> PersistentStateT s m b
-> PersistentStateT s m c
forall a. a -> PersistentStateT s m a
forall a b.
PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m a
forall a b.
PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m b
forall a b.
PersistentStateT s m (a -> b)
-> PersistentStateT s m a -> PersistentStateT s m b
forall a b c.
(a -> b -> c)
-> PersistentStateT s m a
-> PersistentStateT s m b
-> PersistentStateT s m c
forall s (m :: * -> *). Monad m => Functor (PersistentStateT s m)
forall s (m :: * -> *) a. Monad m => a -> PersistentStateT s m a
forall s (m :: * -> *) a b.
Monad m =>
PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m a
forall s (m :: * -> *) a b.
Monad m =>
PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m b
forall s (m :: * -> *) a b.
Monad m =>
PersistentStateT s m (a -> b)
-> PersistentStateT s m a -> PersistentStateT s m b
forall s (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> PersistentStateT s m a
-> PersistentStateT s m b
-> PersistentStateT s m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m a
$c<* :: forall s (m :: * -> *) a b.
Monad m =>
PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m a
*> :: PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m b
$c*> :: forall s (m :: * -> *) a b.
Monad m =>
PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m b
liftA2 :: (a -> b -> c)
-> PersistentStateT s m a
-> PersistentStateT s m b
-> PersistentStateT s m c
$cliftA2 :: forall s (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> PersistentStateT s m a
-> PersistentStateT s m b
-> PersistentStateT s m c
<*> :: PersistentStateT s m (a -> b)
-> PersistentStateT s m a -> PersistentStateT s m b
$c<*> :: forall s (m :: * -> *) a b.
Monad m =>
PersistentStateT s m (a -> b)
-> PersistentStateT s m a -> PersistentStateT s m b
pure :: a -> PersistentStateT s m a
$cpure :: forall s (m :: * -> *) a. Monad m => a -> PersistentStateT s m a
$cp1Applicative :: forall s (m :: * -> *). Monad m => Functor (PersistentStateT s m)
Applicative,Applicative (PersistentStateT s m)
a -> PersistentStateT s m a
Applicative (PersistentStateT s m)
-> (forall a b.
    PersistentStateT s m a
    -> (a -> PersistentStateT s m b) -> PersistentStateT s m b)
-> (forall a b.
    PersistentStateT s m a
    -> PersistentStateT s m b -> PersistentStateT s m b)
-> (forall a. a -> PersistentStateT s m a)
-> Monad (PersistentStateT s m)
PersistentStateT s m a
-> (a -> PersistentStateT s m b) -> PersistentStateT s m b
PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m b
forall a. a -> PersistentStateT s m a
forall a b.
PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m b
forall a b.
PersistentStateT s m a
-> (a -> PersistentStateT s m b) -> PersistentStateT s m b
forall s (m :: * -> *).
Monad m =>
Applicative (PersistentStateT s m)
forall s (m :: * -> *) a. Monad m => a -> PersistentStateT s m a
forall s (m :: * -> *) a b.
Monad m =>
PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m b
forall s (m :: * -> *) a b.
Monad m =>
PersistentStateT s m a
-> (a -> PersistentStateT s m b) -> PersistentStateT s m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> PersistentStateT s m a
$creturn :: forall s (m :: * -> *) a. Monad m => a -> PersistentStateT s m a
>> :: PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m b
$c>> :: forall s (m :: * -> *) a b.
Monad m =>
PersistentStateT s m a
-> PersistentStateT s m b -> PersistentStateT s m b
>>= :: PersistentStateT s m a
-> (a -> PersistentStateT s m b) -> PersistentStateT s m b
$c>>= :: forall s (m :: * -> *) a b.
Monad m =>
PersistentStateT s m a
-> (a -> PersistentStateT s m b) -> PersistentStateT s m b
$cp1Monad :: forall s (m :: * -> *).
Monad m =>
Applicative (PersistentStateT s m)
Monad)
           -- We store all the versions in reverse order

-- | Create a snapshot of the current state and add it to the list of states
-- that we store.
store :: Monad m => PersistentStateT s m ()
store :: PersistentStateT s m ()
store = StateT (NonEmpty s) m () -> PersistentStateT s m ()
forall s (m :: * -> *) a.
StateT (NonEmpty s) m a -> PersistentStateT s m a
PersistentStateT (StateT (NonEmpty s) m () -> PersistentStateT s m ())
-> StateT (NonEmpty s) m () -> PersistentStateT s m ()
forall a b. (a -> b) -> a -> b
$ do
  ss :: NonEmpty s
ss@(s
s :| [s]
_) <- StateT (NonEmpty s) m (NonEmpty s)
forall s (m :: * -> *). MonadState s m => m s
get
  NonEmpty s -> StateT (NonEmpty s) m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (s
s s -> NonEmpty s -> NonEmpty s
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty s
ss)


instance Monad m => MonadState s (PersistentStateT s m) where
  state :: (s -> (a, s)) -> PersistentStateT s m a
state s -> (a, s)
f = StateT (NonEmpty s) m a -> PersistentStateT s m a
forall s (m :: * -> *) a.
StateT (NonEmpty s) m a -> PersistentStateT s m a
PersistentStateT (StateT (NonEmpty s) m a -> PersistentStateT s m a)
-> StateT (NonEmpty s) m a -> PersistentStateT s m a
forall a b. (a -> b) -> a -> b
$ do
              (s
s :| [s]
os) <- StateT (NonEmpty s) m (NonEmpty s)
forall s (m :: * -> *). MonadState s m => m s
get
              let (a
x,s
s') = s -> (a, s)
f s
s
              NonEmpty s -> StateT (NonEmpty s) m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (s
s' s -> [s] -> NonEmpty s
forall a. a -> [a] -> NonEmpty a
:| [s]
os)
              a -> StateT (NonEmpty s) m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | Run a persistentStateT, returns a triplet with the value, the last state
-- and a list of all states (including the last one) in chronological order
runPersistentStateT :: Functor m => PersistentStateT s m a -> s -> m (a,s,[s])
runPersistentStateT :: PersistentStateT s m a -> s -> m (a, s, [s])
runPersistentStateT (PersistentStateT StateT (NonEmpty s) m a
act) s
initS = (a, NonEmpty s) -> (a, s, [s])
forall a a. (a, NonEmpty a) -> (a, a, [a])
f ((a, NonEmpty s) -> (a, s, [s]))
-> m (a, NonEmpty s) -> m (a, s, [s])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (NonEmpty s) m a -> NonEmpty s -> m (a, NonEmpty s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (NonEmpty s) m a
act (s
initS s -> [s] -> NonEmpty s
forall a. a -> [a] -> NonEmpty a
:| [])
  where
    f :: (a, NonEmpty a) -> (a, a, [a])
f (a
x,ss :: NonEmpty a
ss@(a
s :| [a]
_)) = (a
x, a
s, [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
toList NonEmpty a
ss)


--------------------------------------------------------------------------------

-- | A State monad that can store earlier versions of the state.
type PersistentState s = PersistentStateT s Identity

-- | Run a persistentStateT, returns a triplet with the value, the last state
-- and a list of all states (including the last one) in chronological order
runPersistentState     :: PersistentState s a -> s -> (a,s,[s])
runPersistentState :: PersistentState s a -> s -> (a, s, [s])
runPersistentState PersistentState s a
act = Identity (a, s, [s]) -> (a, s, [s])
forall a. Identity a -> a
runIdentity (Identity (a, s, [s]) -> (a, s, [s]))
-> (s -> Identity (a, s, [s])) -> s -> (a, s, [s])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistentState s a -> s -> Identity (a, s, [s])
forall (m :: * -> *) s a.
Functor m =>
PersistentStateT s m a -> s -> m (a, s, [s])
runPersistentStateT PersistentState s a
act