{-# LANGUAGE DeriveFunctor,
             MultiParamTypeClasses,
             DerivingStrategies,
             CPP #-}
module Parsley.Internal.Common.State (
    State, StateT,
    runState, evalState, execState,
    runStateT, evalStateT, execStateT,
    module Control.Monad.State.Class
  ) where

import Control.Applicative       (liftA2, Alternative(..))
#if __GLASGOW_HASKELL__ < 808
import Control.Monad.Fail        (MonadFail(..))
#endif
import Control.Monad.Fix         (MonadFix(..))
import Control.Monad.Identity    (Identity, runIdentity)
import Control.Monad.State.Class
import Control.Monad.Trans       (MonadTrans(..), MonadIO(..))

#if __GLASGOW_HASKELL__ < 808
import qualified Control.Monad.Fail as Fail (MonadFail(fail))
#endif

type State s = StateT s Identity
{-# INLINE runState #-}
runState :: State s a -> s -> (a, s)
runState :: State s a -> s -> (a, s)
runState State s a
mx = Identity (a, s) -> (a, s)
forall a. Identity a -> a
runIdentity (Identity (a, s) -> (a, s))
-> (s -> Identity (a, s)) -> s -> (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State s a -> s -> Identity (a, s)
forall (m :: Type -> Type) s a.
Monad m =>
StateT s m a -> s -> m (a, s)
runStateT State s a
mx

{-# INLINE evalState #-}
evalState :: State s a -> s -> a
evalState :: State s a -> s -> a
evalState State s a
mx = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (s -> Identity a) -> s -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State s a -> s -> Identity a
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m a
evalStateT State s a
mx

{-# INLINE execState #-}
execState :: State s a -> s -> s
execState :: State s a -> s -> s
execState State s a
mx = Identity s -> s
forall a. Identity a -> a
runIdentity (Identity s -> s) -> (s -> Identity s) -> s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State s a -> s -> Identity s
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m s
execStateT State s a
mx

newtype StateT s m a = StateT {StateT s m a -> forall (r :: k). s -> (a -> s -> m r) -> m r
unStateT :: forall r. s -> (a -> s -> m r) -> m r} deriving stock a -> StateT s m b -> StateT s m a
(a -> b) -> StateT s m a -> StateT s m b
(forall a b. (a -> b) -> StateT s m a -> StateT s m b)
-> (forall a b. a -> StateT s m b -> StateT s m a)
-> Functor (StateT s m)
forall a b. a -> StateT s m b -> StateT s m a
forall a b. (a -> b) -> StateT s m a -> StateT s m b
forall s k (m :: k -> Type) a b. a -> StateT s m b -> StateT s m a
forall s k (m :: k -> Type) a b.
(a -> b) -> StateT s m a -> StateT s m b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> StateT s m b -> StateT s m a
$c<$ :: forall s k (m :: k -> Type) a b. a -> StateT s m b -> StateT s m a
fmap :: (a -> b) -> StateT s m a -> StateT s m b
$cfmap :: forall s k (m :: k -> Type) a b.
(a -> b) -> StateT s m a -> StateT s m b
Functor

{-# INLINE runStateT #-}
runStateT :: Monad m => StateT s m a -> s -> m (a, s)
runStateT :: StateT s m a -> s -> m (a, s)
runStateT (StateT forall r. s -> (a -> s -> m r) -> m r
f) s
s = s -> (a -> s -> m (a, s)) -> m (a, s)
forall r. s -> (a -> s -> m r) -> m r
f s
s (((a, s) -> m (a, s)) -> a -> s -> m (a, s)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (a, s) -> m (a, s)
forall (m :: Type -> Type) a. Monad m => a -> m a
return)

{-# INLINE evalStateT #-}
evalStateT :: Monad m => StateT s m a -> s -> m a
evalStateT :: StateT s m a -> s -> m a
evalStateT (StateT forall r. s -> (a -> s -> m r) -> m r
f) s
s = s -> (a -> s -> m a) -> m a
forall r. s -> (a -> s -> m r) -> m r
f s
s (m a -> s -> m a
forall a b. a -> b -> a
const (m a -> s -> m a) -> (a -> m a) -> a -> s -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return)

{-# INLINE execStateT #-}
execStateT :: Monad m => StateT s m a -> s -> m s
execStateT :: StateT s m a -> s -> m s
execStateT (StateT forall r. s -> (a -> s -> m r) -> m r
f) s
s = s -> (a -> s -> m s) -> m s
forall r. s -> (a -> s -> m r) -> m r
f s
s ((s -> m s) -> a -> s -> m s
forall a b. a -> b -> a
const s -> m s
forall (m :: Type -> Type) a. Monad m => a -> m a
return)

instance Applicative (StateT s m) where
  {-# INLINE pure #-}
  pure :: a -> StateT s m a
pure a
x = (forall (r :: k). s -> (a -> s -> m r) -> m r) -> StateT s m a
forall k s (m :: k -> Type) a.
(forall (r :: k). s -> (a -> s -> m r) -> m r) -> StateT s m a
StateT (((a -> s -> m r) -> s -> m r) -> s -> (a -> s -> m r) -> m r
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> s -> m r) -> a -> s -> m r
forall a b. (a -> b) -> a -> b
$ a
x))
  {-# INLINE liftA2 #-}
  liftA2 :: (a -> b -> c) -> StateT s m a -> StateT s m b -> StateT s m c
liftA2 a -> b -> c
f (StateT forall (r :: k). s -> (a -> s -> m r) -> m r
mx) (StateT forall (r :: k). s -> (b -> s -> m r) -> m r
my) = (forall (r :: k). s -> (c -> s -> m r) -> m r) -> StateT s m c
forall k s (m :: k -> Type) a.
(forall (r :: k). s -> (a -> s -> m r) -> m r) -> StateT s m a
StateT (\s
s c -> s -> m r
k -> s -> (a -> s -> m r) -> m r
forall (r :: k). s -> (a -> s -> m r) -> m r
mx s
s (\a
x s
s' -> s -> (b -> s -> m r) -> m r
forall (r :: k). s -> (b -> s -> m r) -> m r
my s
s' (c -> s -> m r
k (c -> s -> m r) -> (b -> c) -> b -> s -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c
f a
x)))

instance Monad (StateT s m) where
  {-# INLINE return #-}
  return :: a -> StateT s m a
return = a -> StateT s m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
  {-# INLINE (>>=) #-}
  StateT forall (r :: k). s -> (a -> s -> m r) -> m r
mx >>= :: StateT s m a -> (a -> StateT s m b) -> StateT s m b
>>= a -> StateT s m b
f = (forall (r :: k). s -> (b -> s -> m r) -> m r) -> StateT s m b
forall k s (m :: k -> Type) a.
(forall (r :: k). s -> (a -> s -> m r) -> m r) -> StateT s m a
StateT (\s
s b -> s -> m r
k -> s -> (a -> s -> m r) -> m r
forall (r :: k). s -> (a -> s -> m r) -> m r
mx s
s (\a
x s
s' -> StateT s m b -> s -> (b -> s -> m r) -> m r
forall s k (m :: k -> Type) a.
StateT s m a -> forall (r :: k). s -> (a -> s -> m r) -> m r
unStateT (a -> StateT s m b
f a
x) s
s' b -> s -> m r
k))

instance MonadFix m => MonadFix (StateT s m) where
  {-# INLINE mfix #-}
  mfix :: (a -> StateT s m a) -> StateT s m a
mfix a -> StateT s m a
f = (forall r. s -> (a -> s -> m r) -> m r) -> StateT s m a
forall k s (m :: k -> Type) a.
(forall (r :: k). s -> (a -> s -> m r) -> m r) -> StateT s m a
StateT (\s
s a -> s -> m r
k -> ((a, s) -> m (a, s)) -> m (a, s)
forall (m :: Type -> Type) a. MonadFix m => (a -> m a) -> m a
mfix (\ ~(a
x, s
_) -> StateT s m a -> s -> m (a, s)
forall (m :: Type -> Type) s a.
Monad m =>
StateT s m a -> s -> m (a, s)
runStateT (a -> StateT s m a
f a
x) s
s) m (a, s) -> ((a, s) -> m r) -> m r
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> s -> m r) -> (a, s) -> m r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> s -> m r
k)

instance MonadTrans (StateT s) where
  {-# INLINE lift #-}
  lift :: m a -> StateT s m a
lift m a
m = (forall r. s -> (a -> s -> m r) -> m r) -> StateT s m a
forall k s (m :: k -> Type) a.
(forall (r :: k). s -> (a -> s -> m r) -> m r) -> StateT s m a
StateT (\s
s a -> s -> m r
k -> m a
m m a -> (a -> m r) -> m r
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> s -> m r
`k` s
s))

instance MonadIO m => MonadIO (StateT s m) where liftIO :: IO a -> StateT s m a
liftIO = m a -> StateT s m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateT s m a) -> (IO a -> m a) -> IO a -> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO

instance MonadFail m => MonadFail (StateT s m) where
#if __GLASGOW_HASKELL__ < 808
  fail msg = StateT (\_ _ -> Fail.fail msg)
#else
  fail :: String -> StateT s m a
fail String
msg = (forall r. s -> (a -> s -> m r) -> m r) -> StateT s m a
forall k s (m :: k -> Type) a.
(forall (r :: k). s -> (a -> s -> m r) -> m r) -> StateT s m a
StateT (\s
_ a -> s -> m r
_ -> String -> m r
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
msg)
#endif

instance Alternative m => Alternative (StateT s m) where
  empty :: StateT s m a
empty = (forall r. s -> (a -> s -> m r) -> m r) -> StateT s m a
forall k s (m :: k -> Type) a.
(forall (r :: k). s -> (a -> s -> m r) -> m r) -> StateT s m a
StateT (\s
_ a -> s -> m r
_ -> m r
forall (f :: Type -> Type) a. Alternative f => f a
empty)
  StateT forall r. s -> (a -> s -> m r) -> m r
mx <|> :: StateT s m a -> StateT s m a -> StateT s m a
<|> StateT forall r. s -> (a -> s -> m r) -> m r
my = (forall r. s -> (a -> s -> m r) -> m r) -> StateT s m a
forall k s (m :: k -> Type) a.
(forall (r :: k). s -> (a -> s -> m r) -> m r) -> StateT s m a
StateT (\s
s a -> s -> m r
k -> s -> (a -> s -> m r) -> m r
forall r. s -> (a -> s -> m r) -> m r
mx s
s a -> s -> m r
k m r -> m r -> m r
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> s -> (a -> s -> m r) -> m r
forall r. s -> (a -> s -> m r) -> m r
my s
s a -> s -> m r
k)

instance MonadState s (StateT s m) where
  get :: StateT s m s
get = (forall (r :: k). s -> (s -> s -> m r) -> m r) -> StateT s m s
forall k s (m :: k -> Type) a.
(forall (r :: k). s -> (a -> s -> m r) -> m r) -> StateT s m a
StateT (\s
s s -> s -> m r
k -> s -> s -> m r
k s
s s
s)
  put :: s -> StateT s m ()
put s
s = (forall (r :: k). s -> (() -> s -> m r) -> m r) -> StateT s m ()
forall k s (m :: k -> Type) a.
(forall (r :: k). s -> (a -> s -> m r) -> m r) -> StateT s m a
StateT (\s
_ () -> s -> m r
k -> () -> s -> m r
k () s
s)