{-# LANGUAGE BlockArguments #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Control.Monad.State (StateL(..), StateR(..)) where

import Control.Arrow (first, second)

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

-- * STATE LEFT
-- * STATE RIGHT

---------------------------------------------------------------------------
-- STATE LEFT
---------------------------------------------------------------------------

newtype StateL s a = StateL { StateL s a -> s -> (a, s)
runStateL :: s -> (a, s) }

instance Functor (StateL s) where a -> b
f fmap :: (a -> b) -> StateL s a -> StateL s b
`fmap` StateL s -> (a, s)
k = (s -> (b, s)) -> StateL s b
forall s a. (s -> (a, s)) -> StateL s a
StateL ((s -> (b, s)) -> StateL s b) -> (s -> (b, s)) -> StateL s b
forall a b. (a -> b) -> a -> b
$ (a -> b
f (a -> b) -> (a, s) -> (b, s)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
`first`) ((a, s) -> (b, s)) -> (s -> (a, s)) -> s -> (b, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> (a, s)
k

instance Applicative (StateL s) where
	pure :: a -> StateL s a
pure = (s -> (a, s)) -> StateL s a
forall s a. (s -> (a, s)) -> StateL s a
StateL ((s -> (a, s)) -> StateL s a)
-> (a -> s -> (a, s)) -> a -> StateL s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,)
	StateL s -> (a -> b, s)
kf <*> :: StateL s (a -> b) -> StateL s a -> StateL s b
<*> StateL s a
mx =
		(s -> (b, s)) -> StateL s b
forall s a. (s -> (a, s)) -> StateL s a
StateL \s
s -> let (a -> b
f, s
s') = s -> (a -> b, s)
kf s
s in (a -> b
f (a -> b) -> StateL s a -> StateL s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateL s a
mx) StateL s b -> s -> (b, s)
forall s a. StateL s a -> s -> (a, s)
`runStateL` s
s'

instance Monad (StateL s) where
	StateL s -> (a, s)
k >>= :: StateL s a -> (a -> StateL s b) -> StateL s b
>>= a -> StateL s b
f = (s -> (b, s)) -> StateL s b
forall s a. (s -> (a, s)) -> StateL s a
StateL \s
s -> let (a
x, s
s') = s -> (a, s)
k s
s in a -> StateL s b
f a
x StateL s b -> s -> (b, s)
forall s a. StateL s a -> s -> (a, s)
`runStateL` s
s'

---------------------------------------------------------------------------
-- STATE RIGHT
---------------------------------------------------------------------------

newtype StateR s a = StateR { StateR s a -> s -> (s, a)
runStateR :: s -> (s, a) }

instance Functor (StateR s) where a -> b
f fmap :: (a -> b) -> StateR s a -> StateR s b
`fmap` StateR s -> (s, a)
k = (s -> (s, b)) -> StateR s b
forall s a. (s -> (s, a)) -> StateR s a
StateR ((s -> (s, b)) -> StateR s b) -> (s -> (s, b)) -> StateR s b
forall a b. (a -> b) -> a -> b
$ (a -> b
f (a -> b) -> (s, a) -> (s, b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
`second`) ((s, a) -> (s, b)) -> (s -> (s, a)) -> s -> (s, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> (s, a)
k

instance Applicative (StateR s) where
	pure :: a -> StateR s a
pure = (s -> (s, a)) -> StateR s a
forall s a. (s -> (s, a)) -> StateR s a
StateR ((s -> (s, a)) -> StateR s a)
-> (a -> s -> (s, a)) -> a -> StateR s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> a -> (s, a)) -> a -> s -> (s, a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,)
	StateR s -> (s, a -> b)
kf <*> :: StateR s (a -> b) -> StateR s a -> StateR s b
<*> StateR s a
mx =
		(s -> (s, b)) -> StateR s b
forall s a. (s -> (s, a)) -> StateR s a
StateR \s
s -> let (s
s', a -> b
f) = s -> (s, a -> b)
kf s
s in (a -> b
f (a -> b) -> StateR s a -> StateR s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateR s a
mx) StateR s b -> s -> (s, b)
forall s a. StateR s a -> s -> (s, a)
`runStateR` s
s'

instance Monad (StateR s) where
	StateR s -> (s, a)
k >>= :: StateR s a -> (a -> StateR s b) -> StateR s b
>>= a -> StateR s b
f = (s -> (s, b)) -> StateR s b
forall s a. (s -> (s, a)) -> StateR s a
StateR \s
s -> let (s
s', a
x) = s -> (s, a)
k s
s in a -> StateR s b
f a
x StateR s b -> s -> (s, b)
forall s a. StateR s a -> s -> (s, a)
`runStateR` s
s'