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

module Control.Monad.StateT (StateT(..), lift) where

import Control.Applicative (Alternative(..))
import Control.Arrow (first)
import Control.Monad (MonadPlus, (>=>))

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

-- * NEWTYPE STATE T
-- * INSTANCE
--	+ FUNCTOR
--	+ APPLICATIVE AND ALTERNATIVE
--	+ MONAD AND MONAD PLUS

---------------------------------------------------------------------------
-- NEWTYPE STATE T
---------------------------------------------------------------------------

newtype StateT s m a = StateT { StateT s m a -> s -> m (a, s)
runStateT :: s -> m (a, s) }

lift :: Functor m => m a -> StateT s m a
lift :: m a -> StateT s m a
lift m a
m = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT \s
s -> (, s
s) (a -> (a, s)) -> m a -> m (a, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
m

---------------------------------------------------------------------------
-- INSTANCE
---------------------------------------------------------------------------

-- FUNCTOR

instance Functor m => Functor (StateT s m) where
	a -> b
f fmap :: (a -> b) -> StateT s m a -> StateT s m b
`fmap` StateT s -> m (a, s)
k = (s -> m (b, s)) -> StateT s m b
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (b, s)) -> StateT s m b)
-> (s -> m (b, s)) -> StateT s m 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)) -> m (a, s) -> m (b, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m (a, s) -> m (b, s)) -> (s -> m (a, s)) -> s -> m (b, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m (a, s)
k

-- APPLICATIVE AND ALTERNATIVE

instance Monad m => Applicative (StateT s m) where
	pure :: a -> StateT s m a
pure = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (a, s)) -> StateT s m a)
-> (a -> s -> m (a, s)) -> a -> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, s) -> m (a, s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, s) -> m (a, s)) -> (s -> (a, s)) -> s -> m (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((s -> (a, s)) -> s -> m (a, s))
-> (a -> s -> (a, s)) -> a -> s -> m (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,)
	StateT s -> m (a -> b, s)
kf <*> :: StateT s m (a -> b) -> StateT s m a -> StateT s m b
<*> StateT s m a
mx = (s -> m (b, s)) -> StateT s m b
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (b, s)) -> StateT s m b)
-> (s -> m (b, s)) -> StateT s m b
forall a b. (a -> b) -> a -> b
$ s -> m (a -> b, s)
kf (s -> m (a -> b, s)) -> ((a -> b, s) -> m (b, s)) -> s -> m (b, s)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \(a -> b
f, s
s') -> (a -> b
f (a -> b) -> StateT s m a -> StateT s m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT s m a
mx) StateT s m b -> s -> m (b, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
`runStateT` s
s'

instance MonadPlus m => Alternative (StateT s m) where
	empty :: StateT s m a
empty = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ m (a, s) -> s -> m (a, s)
forall a b. a -> b -> a
const m (a, s)
forall (f :: * -> *) a. Alternative f => f a
empty
	StateT s -> m (a, s)
k <|> :: StateT s m a -> StateT s m a -> StateT s m a
<|> StateT s -> m (a, s)
l = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ m (a, s) -> m (a, s) -> m (a, s)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (m (a, s) -> m (a, s) -> m (a, s))
-> (s -> m (a, s)) -> s -> m (a, s) -> m (a, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> m (a, s)
k (s -> m (a, s) -> m (a, s)) -> (s -> m (a, s)) -> s -> m (a, s)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> s -> m (a, s)
l

-- MONAD AND MONAD PLUS

instance Monad m => Monad (StateT s m) where
	StateT s -> m (a, s)
k >>= :: StateT s m a -> (a -> StateT s m b) -> StateT s m b
>>= a -> StateT s m b
f = (s -> m (b, s)) -> StateT s m b
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (b, s)) -> StateT s m b)
-> (s -> m (b, s)) -> StateT s m b
forall a b. (a -> b) -> a -> b
$ s -> m (a, s)
k (s -> m (a, s)) -> ((a, s) -> m (b, s)) -> s -> m (b, s)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \(a
x, s
s') -> a -> StateT s m b
f a
x StateT s m b -> s -> m (b, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
`runStateT` s
s'

instance MonadPlus m => MonadPlus (StateT s m)