{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- | A carrier for the 'State' effect. It uses an 'IORef' internally to handle its state, and thus admits a 'MonadUnliftIO' instance. Because the state operations are performed impurely, this carrier will not lose state effects even with nefarious uses of 'Control.Effect.Lift.liftWith'.

Unlike the other carriers for 'State', this carrier's effects will not backtrack when run in conjuction with 'Control.Effect.NonDet' effects.

@since 1.1.2.0
-}
module Control.Carrier.State.IORef
( -- * Impure state carrier
  runState
, runStateRef
, evalState
, execState
, StateC(..)
-- * State effect
, module Control.Effect.State
) where

import           Control.Algebra
import           Control.Applicative (Alternative(..))
import           Control.Carrier.Reader
import           Control.Effect.State
import           Control.Monad (MonadPlus(..))
import qualified Control.Monad.Fail as Fail
import           Control.Monad.Fix
import           Control.Monad.IO.Class
import           Control.Monad.IO.Unlift
import           Control.Monad.Trans.Class
import           Data.IORef

-- | Run a 'State' effect starting from the passed value.
--
-- @
-- 'runState' s ('pure' a) = 'pure' (s, a)
-- @
-- @
-- 'runState' s 'get' = 'pure' (s, s)
-- @
-- @
-- 'runState' s ('put' t) = 'pure' (t, ())
-- @
--
-- @since 1.1.2.0
runState :: MonadIO m => s -> StateC s m a -> m (s, a)
runState :: forall (m :: * -> *) s a.
MonadIO m =>
s -> StateC s m a -> m (s, a)
runState s
s StateC s m a
x = do
  IORef s
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef s
s
  a
result <- forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader IORef s
ref forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. StateC s m a -> ReaderC (IORef s) m a
runStateC forall a b. (a -> b) -> a -> b
$ StateC s m a
x
  s
final <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ IORef s
ref
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
final, a
result)
{-# INLINE[3] runState #-}

-- | Run a 'State' effect starting from the passed 'IORef'. This function is lawless, given that the underlying IORef can be modified by another thread.
--
-- @since 1.1.2.0
runStateRef :: MonadIO m => IORef s -> StateC s m a -> m (s, a)
runStateRef :: forall (m :: * -> *) s a.
MonadIO m =>
IORef s -> StateC s m a -> m (s, a)
runStateRef IORef s
ref StateC s m a
x = do
  a
result <- forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader IORef s
ref forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. StateC s m a -> ReaderC (IORef s) m a
runStateC forall a b. (a -> b) -> a -> b
$ StateC s m a
x
  s
final <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ IORef s
ref
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
final, a
result)
{-# INLINE[3] runStateRef #-}

-- | Run a 'State' effect, yielding the result value and discarding the final state.
--
-- @
-- 'evalState' s m = 'fmap' 'snd' ('runState' s m)
-- @
--
-- @since 1.1.2.0
evalState :: forall s m a . MonadIO m => s -> StateC s m a -> m a
evalState :: forall s (m :: * -> *) a. MonadIO m => s -> StateC s m a -> m a
evalState s
s StateC s m a
x = do
  IORef s
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef s
s
  forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader IORef s
ref forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. StateC s m a -> ReaderC (IORef s) m a
runStateC forall a b. (a -> b) -> a -> b
$ StateC s m a
x
{-# INLINE[3] evalState #-}

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

-- | @since 1.1.2.0
newtype StateC s m a = StateC { forall s (m :: * -> *) a. StateC s m a -> ReaderC (IORef s) m a
runStateC :: ReaderC (IORef s) m a }
  deriving (forall a. StateC s m a
forall a. StateC s m a -> StateC s m [a]
forall a. StateC s m a -> StateC s m a -> StateC s m a
forall {s} {m :: * -> *}. Alternative m => Applicative (StateC s m)
forall s (m :: * -> *) a. Alternative m => StateC s m a
forall s (m :: * -> *) a.
Alternative m =>
StateC s m a -> StateC s m [a]
forall s (m :: * -> *) a.
Alternative m =>
StateC s m a -> StateC s m a -> StateC s m a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: forall a. StateC s m a -> StateC s m [a]
$cmany :: forall s (m :: * -> *) a.
Alternative m =>
StateC s m a -> StateC s m [a]
some :: forall a. StateC s m a -> StateC s m [a]
$csome :: forall s (m :: * -> *) a.
Alternative m =>
StateC s m a -> StateC s m [a]
<|> :: forall a. StateC s m a -> StateC s m a -> StateC s m a
$c<|> :: forall s (m :: * -> *) a.
Alternative m =>
StateC s m a -> StateC s m a -> StateC s m a
empty :: forall a. StateC s m a
$cempty :: forall s (m :: * -> *) a. Alternative m => StateC s m a
Alternative, forall a. a -> StateC s m a
forall a b. StateC s m a -> StateC s m b -> StateC s m a
forall a b. StateC s m a -> StateC s m b -> StateC s m b
forall a b. StateC s m (a -> b) -> StateC s m a -> StateC s m b
forall a b c.
(a -> b -> c) -> StateC s m a -> StateC s m b -> StateC s m c
forall {s} {m :: * -> *}. Applicative m => Functor (StateC s m)
forall s (m :: * -> *) a. Applicative m => a -> StateC s m a
forall s (m :: * -> *) a b.
Applicative m =>
StateC s m a -> StateC s m b -> StateC s m a
forall s (m :: * -> *) a b.
Applicative m =>
StateC s m a -> StateC s m b -> StateC s m b
forall s (m :: * -> *) a b.
Applicative m =>
StateC s m (a -> b) -> StateC s m a -> StateC s m b
forall s (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> StateC s m a -> StateC s m b -> StateC s m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. StateC s m a -> StateC s m b -> StateC s m a
$c<* :: forall s (m :: * -> *) a b.
Applicative m =>
StateC s m a -> StateC s m b -> StateC s m a
*> :: forall a b. StateC s m a -> StateC s m b -> StateC s m b
$c*> :: forall s (m :: * -> *) a b.
Applicative m =>
StateC s m a -> StateC s m b -> StateC s m b
liftA2 :: forall a b c.
(a -> b -> c) -> StateC s m a -> StateC s m b -> StateC s m c
$cliftA2 :: forall s (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> StateC s m a -> StateC s m b -> StateC s m c
<*> :: forall a b. StateC s m (a -> b) -> StateC s m a -> StateC s m b
$c<*> :: forall s (m :: * -> *) a b.
Applicative m =>
StateC s m (a -> b) -> StateC s m a -> StateC s m b
pure :: forall a. a -> StateC s m a
$cpure :: forall s (m :: * -> *) a. Applicative m => a -> StateC s m a
Applicative, 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
<$ :: forall a b. 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 :: forall a b. (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, forall a. a -> StateC s m a
forall a b. StateC s m a -> StateC s m b -> StateC s m b
forall a b. StateC s m a -> (a -> StateC s m b) -> StateC s m b
forall {s} {m :: * -> *}. Monad m => Applicative (StateC s m)
forall s (m :: * -> *) a. Monad m => a -> StateC s m a
forall s (m :: * -> *) a b.
Monad m =>
StateC s m a -> StateC s m b -> StateC s m b
forall s (m :: * -> *) a b.
Monad m =>
StateC s m a -> (a -> StateC s m b) -> StateC s m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> StateC s m a
$creturn :: forall s (m :: * -> *) a. Monad m => a -> StateC s m a
>> :: forall a b. StateC s m a -> StateC s m b -> StateC s m b
$c>> :: forall s (m :: * -> *) a b.
Monad m =>
StateC s m a -> StateC s m b -> StateC s m b
>>= :: forall a b. StateC s m a -> (a -> StateC s m b) -> StateC s m b
$c>>= :: forall s (m :: * -> *) a b.
Monad m =>
StateC s m a -> (a -> StateC s m b) -> StateC s m b
Monad, forall a. String -> StateC s m a
forall {s} {m :: * -> *}. MonadFail m => Monad (StateC s m)
forall s (m :: * -> *) a. MonadFail m => String -> StateC s m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> StateC s m a
$cfail :: forall s (m :: * -> *) a. MonadFail m => String -> StateC s m a
Fail.MonadFail, forall a. (a -> StateC s m a) -> StateC s m a
forall {s} {m :: * -> *}. MonadFix m => Monad (StateC s m)
forall s (m :: * -> *) a.
MonadFix m =>
(a -> StateC s m a) -> StateC s m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: forall a. (a -> StateC s m a) -> StateC s m a
$cmfix :: forall s (m :: * -> *) a.
MonadFix m =>
(a -> StateC s m a) -> StateC s m a
MonadFix, forall a. IO a -> StateC s m a
forall {s} {m :: * -> *}. MonadIO m => Monad (StateC s m)
forall s (m :: * -> *) a. MonadIO m => IO a -> StateC s m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> StateC s m a
$cliftIO :: forall s (m :: * -> *) a. MonadIO m => IO a -> StateC s m a
MonadIO, forall a. StateC s m a
forall a. StateC s m a -> StateC s m a -> StateC s m a
forall {s} {m :: * -> *}.
(Alternative m, Monad m) =>
Monad (StateC s m)
forall {s} {m :: * -> *}.
(Alternative m, Monad m) =>
Alternative (StateC s m)
forall s (m :: * -> *) a. (Alternative m, Monad m) => StateC s m a
forall s (m :: * -> *) a.
(Alternative m, Monad m) =>
StateC s m a -> StateC s m a -> StateC s m a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: forall a. StateC s m a -> StateC s m a -> StateC s m a
$cmplus :: forall s (m :: * -> *) a.
(Alternative m, Monad m) =>
StateC s m a -> StateC s m a -> StateC s m a
mzero :: forall a. StateC s m a
$cmzero :: forall s (m :: * -> *) a. (Alternative m, Monad m) => StateC s m a
MonadPlus, forall s (m :: * -> *) a. Monad m => m a -> StateC s m a
forall (m :: * -> *) a. Monad m => m a -> StateC s m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> StateC s m a
$clift :: forall s (m :: * -> *) a. Monad m => m a -> StateC s m a
MonadTrans, forall b.
((forall a. StateC s m a -> IO a) -> IO b) -> StateC s m b
forall {s} {m :: * -> *}. MonadUnliftIO m => MonadIO (StateC s m)
forall s (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. StateC s m a -> IO a) -> IO b) -> StateC s m b
forall (m :: * -> *).
MonadIO m
-> (forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
withRunInIO :: forall b.
((forall a. StateC s m a -> IO a) -> IO b) -> StateC s m b
$cwithRunInIO :: forall s (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. StateC s m a -> IO a) -> IO b) -> StateC s m b
MonadUnliftIO)

instance (MonadIO m, Algebra sig m) => Algebra (State s :+: sig) (StateC s m) where
  alg :: forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (StateC s m)
-> (:+:) (State s) sig n a -> ctx () -> StateC s m (ctx a)
alg Handler ctx n (StateC s m)
hdl (:+:) (State s) sig n a
sig ctx ()
ctx = case (:+:) (State s) sig n a
sig of
    L State s n a
act -> do
      IORef s
ref <- forall s (m :: * -> *) a. ReaderC (IORef s) m a -> StateC s m a
StateC (forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask @(IORef s))
      (forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case State s n a
act of
        Put s
s -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> a -> IO ()
writeIORef IORef s
ref s
s)
        State s n a
Get   -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef s
ref)
    R sig n a
other -> forall s (m :: * -> *) a. ReaderC (IORef s) m a -> StateC s m a
StateC (forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (ctx :: * -> *)
       (n :: * -> *) a.
(Algebra sig m, Functor ctx) =>
Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
alg (forall s (m :: * -> *) a. StateC s m a -> ReaderC (IORef s) m a
runStateC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handler ctx n (StateC s m)
hdl) (forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *)
       (m :: * -> *) k.
g m k -> (:+:) f g m k
R sig n a
other) ctx ()
ctx)
  {-# INLINE alg #-}