{-# LANGUAGE DeriveFunctor, ExplicitForAll, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
module Control.Effect.State.Strict
( -- * State effect
  module State
  -- * Strict state carrier
, runState
, evalState
, execState
, StateC(..)
  -- * Re-exports
, Carrier
, run
) where

import Control.Applicative (Alternative(..))
import Control.Effect.Carrier
import Control.Effect.State.Internal as State
import Control.Monad (MonadPlus(..))
import qualified Control.Monad.Fail as Fail
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class

-- | Run a 'State' effect starting from the passed value.
--
--   prop> run (runState a (pure b)) === (a, b)
runState :: s -> StateC s m a -> m (s, a)
runState :: s -> StateC s m a -> m (s, a)
runState s :: s
s x :: StateC s m a
x = StateC s m a -> s -> m (s, a)
forall s (m :: * -> *) a. StateC s m a -> s -> m (s, a)
runStateC StateC s m a
x s
s
{-# INLINE[3] runState #-}

-- | Run a 'State' effect, yielding the result value and discarding the final state.
--
--   prop> run (evalState a (pure b)) === b
evalState :: forall s m a . Functor m => s -> StateC s m a -> m a
evalState :: s -> StateC s m a -> m a
evalState s :: s
s = ((s, a) -> a) -> m (s, a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s, a) -> a
forall a b. (a, b) -> b
snd (m (s, a) -> m a)
-> (StateC s m a -> m (s, a)) -> StateC s m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> StateC s m a -> m (s, a)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState s
s
{-# INLINE[3] evalState #-}

-- | Run a 'State' effect, yielding the final state and discarding the return value.
--
--   prop> run (execState a (pure b)) === a
execState :: forall s m a . Functor m => s -> StateC s m a -> m s
execState :: s -> StateC s m a -> m s
execState s :: s
s = ((s, a) -> s) -> m (s, a) -> m s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s, a) -> s
forall a b. (a, b) -> a
fst (m (s, a) -> m s)
-> (StateC s m a -> m (s, a)) -> StateC s m a -> m s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> StateC s m a -> m (s, a)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState s
s
{-# INLINE[3] execState #-}


newtype StateC s m a = StateC { StateC s m a -> s -> m (s, a)
runStateC :: s -> m (s, a) }
  deriving (a -> StateC s m b -> StateC s m a
(a -> b) -> StateC s m a -> StateC s m b
(forall a b. (a -> b) -> StateC s m a -> StateC s m b)
-> (forall a b. a -> StateC s m b -> StateC s m a)
-> Functor (StateC s m)
forall a b. a -> StateC s m b -> StateC s m a
forall a b. (a -> b) -> StateC s m a -> StateC s m b
forall s (m :: * -> *) a b.
Functor m =>
a -> StateC s m b -> StateC s m a
forall s (m :: * -> *) a b.
Functor m =>
(a -> b) -> StateC s m a -> StateC 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 -> StateC s m b -> StateC s m a
$c<$ :: forall s (m :: * -> *) a b.
Functor m =>
a -> StateC s m b -> StateC s m a
fmap :: (a -> b) -> StateC s m a -> StateC s m b
$cfmap :: forall s (m :: * -> *) a b.
Functor m =>
(a -> b) -> StateC s m a -> StateC s m b
Functor)

instance Monad m => Applicative (StateC s m) where
  pure :: a -> StateC s m a
pure a :: a
a = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> (s, a) -> m (s, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
s, a
a))
  {-# INLINE pure #-}
  StateC f :: s -> m (s, a -> b)
f <*> :: StateC s m (a -> b) -> StateC s m a -> StateC s m b
<*> StateC a :: s -> m (s, a)
a = (s -> m (s, b)) -> StateC s m b
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC ((s -> m (s, b)) -> StateC s m b)
-> (s -> m (s, b)) -> StateC s m b
forall a b. (a -> b) -> a -> b
$ \ s :: s
s -> do
    (s' :: s
s', f' :: a -> b
f') <- s -> m (s, a -> b)
f s
s
    (s'' :: s
s'', a' :: a
a') <- s -> m (s, a)
a s
s'
    let fa :: b
fa = a -> b
f' a
a'
    b
fa b -> m (s, b) -> m (s, b)
forall a b. a -> b -> b
`seq` (s, b) -> m (s, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
s'', b
fa)
  {-# INLINE (<*>) #-}
  m :: StateC s m a
m *> :: StateC s m a -> StateC s m b -> StateC s m b
*> k :: StateC s m b
k = StateC s m a
m StateC s m a -> (a -> StateC s m b) -> StateC s m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \_ -> StateC s m b
k
  {-# INLINE (*>) #-}

instance (Alternative m, Monad m) => Alternative (StateC s m) where
  empty :: StateC s m a
empty = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (m (s, a) -> s -> m (s, a)
forall a b. a -> b -> a
const m (s, a)
forall (f :: * -> *) a. Alternative f => f a
empty)
  {-# INLINE empty #-}
  StateC l :: s -> m (s, a)
l <|> :: StateC s m a -> StateC s m a -> StateC s m a
<|> StateC r :: s -> m (s, a)
r = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> s -> m (s, a)
l s
s m (s, a) -> m (s, a) -> m (s, a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> s -> m (s, a)
r s
s)
  {-# INLINE (<|>) #-}

instance Monad m => Monad (StateC s m) where
  StateC m :: s -> m (s, a)
m >>= :: StateC s m a -> (a -> StateC s m b) -> StateC s m b
>>= f :: a -> StateC s m b
f = (s -> m (s, b)) -> StateC s m b
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC ((s -> m (s, b)) -> StateC s m b)
-> (s -> m (s, b)) -> StateC s m b
forall a b. (a -> b) -> a -> b
$ \ s :: s
s -> do
    (s' :: s
s', a :: a
a) <- s -> m (s, a)
m s
s
    let fa :: StateC s m b
fa = a -> StateC s m b
f a
a
    StateC s m b
fa StateC s m b -> m (s, b) -> m (s, b)
forall a b. a -> b -> b
`seq` s -> StateC s m b -> m (s, b)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState s
s' StateC s m b
fa
  {-# INLINE (>>=) #-}

instance Fail.MonadFail m => Fail.MonadFail (StateC s m) where
  fail :: String -> StateC s m a
fail s :: String
s = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (m (s, a) -> s -> m (s, a)
forall a b. a -> b -> a
const (String -> m (s, a)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
s))
  {-# INLINE fail #-}

instance MonadFix m => MonadFix (StateC s m) where
  mfix :: (a -> StateC s m a) -> StateC s m a
mfix f :: a -> StateC s m a
f = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> ((s, a) -> m (s, a)) -> m (s, a)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (s -> StateC s m a -> m (s, a)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState s
s (StateC s m a -> m (s, a))
-> ((s, a) -> StateC s m a) -> (s, a) -> m (s, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StateC s m a
f (a -> StateC s m a) -> ((s, a) -> a) -> (s, a) -> StateC s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s, a) -> a
forall a b. (a, b) -> b
snd))
  {-# INLINE mfix #-}

instance MonadIO m => MonadIO (StateC s m) where
  liftIO :: IO a -> StateC s m a
liftIO io :: IO a
io = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> (,) s
s (a -> (s, a)) -> m a -> m (s, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io)
  {-# INLINE liftIO #-}

instance (Alternative m, Monad m) => MonadPlus (StateC s m)

instance MonadTrans (StateC s) where
  lift :: m a -> StateC s m a
lift m :: m a
m = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> (,) s
s (a -> (s, a)) -> m a -> m (s, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
m)
  {-# INLINE lift #-}

instance (Carrier sig m, Effect sig) => Carrier (State s :+: sig) (StateC s m) where
  eff :: (:+:) (State s) sig (StateC s m) a -> StateC s m a
eff (L (Get   k :: s -> StateC s m a
k)) = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> s -> StateC s m a -> m (s, a)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState s
s (s -> StateC s m a
k s
s))
  eff (L (Put s :: s
s k :: StateC s m a
k)) = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ _ -> s -> StateC s m a -> m (s, a)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState s
s StateC s m a
k)
  eff (R other :: sig (StateC s m) a
other)     = (s -> m (s, a)) -> StateC s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (\ s :: s
s -> sig m (s, a) -> m (s, a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Carrier sig m =>
sig m a -> m a
eff ((s, ())
-> (forall x. (s, StateC s m x) -> m (s, x))
-> sig (StateC s m) a
-> sig m (s, a)
forall (sig :: (* -> *) -> * -> *) (f :: * -> *) (m :: * -> *)
       (n :: * -> *) a.
(Effect sig, Functor f, Monad m) =>
f () -> (forall x. f (m x) -> n (f x)) -> sig m a -> sig n (f a)
handle (s
s, ()) ((s -> StateC s m x -> m (s, x)) -> (s, StateC s m x) -> m (s, x)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> StateC s m x -> m (s, x)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState) sig (StateC s m) a
other))
  {-# INLINE eff #-}


-- $setup
-- >>> :seti -XFlexibleContexts
-- >>> import Test.QuickCheck
-- >>> import Control.Effect.Pure