module Data.Monoid.State where

import qualified Data.Monoid.Transformer as MonoidTrans
import Data.Monoid (Monoid, mempty, )
import Data.Semigroup (Semigroup, (<>), )
import Data.Functor (Functor, fmap, )
import Data.Function (const, ($), (.), )
import Data.Tuple (fst, snd, )

import Prelude ()

{- |
This resembles the pure State monad.
However, State in transformers is a StateT
and mtl is not Haskell 98.

I hope I have the more natural parameter order for 'evaluate'
in contrast to @mtl@ and @transformers@.
However, it is different from the parameter order of 'run'.

Could also be written as @Monoid.Applicative (Monad.Trans.State s) a@.
-}
newtype T s a = Cons {forall s a. T s a -> s -> (a, s)
run :: s -> (a,s)}

pure :: a -> T s a
pure :: forall a s. a -> T s a
pure a
a = (s -> (a, s)) -> T s a
forall s a. (s -> (a, s)) -> T s a
Cons ((s -> (a, s)) -> T s a) -> (s -> (a, s)) -> T s a
forall a b. (a -> b) -> a -> b
$ \s
s -> (a
a,s
s)


evaluate :: s -> T s a -> a
evaluate :: forall s a. s -> T s a -> a
evaluate s
s T s a
m = (a, s) -> a
forall a b. (a, b) -> a
fst ((a, s) -> a) -> (a, s) -> a
forall a b. (a -> b) -> a -> b
$ T s a -> s -> (a, s)
forall s a. T s a -> s -> (a, s)
run T s a
m s
s

execute :: s -> T s a -> s
execute :: forall s a. s -> T s a -> s
execute s
s T s a
m = (a, s) -> s
forall a b. (a, b) -> b
snd ((a, s) -> s) -> (a, s) -> s
forall a b. (a -> b) -> a -> b
$ T s a -> s -> (a, s)
forall s a. T s a -> s -> (a, s)
run T s a
m s
s


put :: Monoid a => s -> T s a
put :: forall a s. Monoid a => s -> T s a
put s
s = (s -> (a, s)) -> T s a
forall s a. (s -> (a, s)) -> T s a
Cons ((s -> (a, s)) -> T s a) -> (s -> (a, s)) -> T s a
forall a b. (a -> b) -> a -> b
$ (a, s) -> s -> (a, s)
forall a b. a -> b -> a
const (a
forall a. Monoid a => a
mempty, s
s)

modify :: Monoid a => (s -> s) -> T s a
modify :: forall a s. Monoid a => (s -> s) -> T s a
modify s -> s
f = (s -> (a, s)) -> T s a
forall s a. (s -> (a, s)) -> T s a
Cons ((s -> (a, s)) -> T s a) -> (s -> (a, s)) -> T s a
forall a b. (a -> b) -> a -> b
$ \s
s -> (a
forall a. Monoid a => a
mempty, s -> s
f s
s)


instance Semigroup a => Semigroup (T s a) where
   Cons s -> (a, s)
x <> :: T s a -> T s a -> T s a
<> Cons s -> (a, s)
y =
      (s -> (a, s)) -> T s a
forall s a. (s -> (a, s)) -> T s a
Cons ((s -> (a, s)) -> T s a) -> (s -> (a, s)) -> T s a
forall a b. (a -> b) -> a -> b
$ \s
s0 ->
         let (a
xr,s
s1) = s -> (a, s)
x s
s0
             (a
yr,s
s2) = s -> (a, s)
y s
s1
         in  (a
xra -> a -> a
forall a. Semigroup a => a -> a -> a
<>a
yr, s
s2)

instance Monoid a => Monoid (T s a) where
   mempty :: T s a
mempty = a -> T s a
forall m. Monoid m => m -> T s m
forall (t :: * -> *) m. (C t, Monoid m) => m -> t m
MonoidTrans.lift a
forall a. Monoid a => a
mempty

instance MonoidTrans.C (T s) where
   lift :: forall m. Monoid m => m -> T s m
lift m
x = (s -> (m, s)) -> T s m
forall s a. (s -> (a, s)) -> T s a
Cons ((s -> (m, s)) -> T s m) -> (s -> (m, s)) -> T s m
forall a b. (a -> b) -> a -> b
$ (,) m
x

instance Functor (T s) where
   fmap :: forall a b. (a -> b) -> T s a -> T s b
fmap a -> b
f (Cons s -> (a, s)
g) = (s -> (b, s)) -> T s b
forall s a. (s -> (a, s)) -> T s a
Cons ((a -> b) -> (a, s) -> (b, s)
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst a -> b
f ((a, s) -> (b, s)) -> (s -> (a, s)) -> s -> (b, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> (a, s)
g)

-- from utility-ht
{-# INLINE mapFst #-}
mapFst :: (a -> c) -> (a,b) -> (c,b)
mapFst :: forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst a -> c
f ~(a
a,b
b) = (a -> c
f a
a, b
b)