Add IORef-based State carrier.

ChangeLog.md

@@ -7,7 +7,9 @@
   - Defines `Algebra` instances for the two mentioned carriers,
     and for `Control.Monad.Trans.Accum` from `transformers`
 
-- Defines, `Algebra`, `Alternative`, `Applicative`, `Foldable`, `Functor`, `Monad`, `MonadFail`, `MonadFix`, `MonadIO`, `MonadPlus`, `MonadTrans`, `MonadUnliftIO`, `MonadZip`, and `Traversable` instances for `Control.Effect.Choose.Choosing`. ([#419](https://github.com/fused-effects/fused-effects/pull/419))
+- Defines `Algebra`, `Alternative`, `Applicative`, `Foldable`, `Functor`, `Monad`, `MonadFail`, `MonadFix`, `MonadIO`, `MonadPlus`, `MonadTrans`, `MonadUnliftIO`, `MonadZip`, and `Traversable` instances for `Control.Effect.Choose.Choosing`. ([#419](https://github.com/fused-effects/fused-effects/pull/419))
+
+- Adds an `IORef`-based carrier in `Control.Carrier.State.IORef`. ([#422](https://github.com/fused-effects/fused-effects/pull/422))
 
 
 # v1.1.1.2

fused-effects.cabal

@@ -72,6 +72,7 @@ library
     Control.Carrier.NonDet.Church
     Control.Carrier.Reader
     Control.Carrier.State.Church
+    Control.Carrier.State.IORef
     Control.Carrier.State.Lazy
     Control.Carrier.State.Strict
     Control.Carrier.Throw.Either

src/Control/Carrier/State/IORef.hs

@@ -0,0 +1,107 @@
+{-# 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 s x = do
+  ref <- liftIO $ newIORef s
+  result <- runReader ref . runStateC $ x
+  final <- liftIO . readIORef $ ref
+  pure (final, 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 ref x = do
+  result <- runReader ref . runStateC $ x
+  final <- liftIO . readIORef $ ref
+  pure (final, 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 s x = do
+  ref <- liftIO $ newIORef s
+  runReader ref . runStateC $ 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 s = fmap fst . runState s
+{-# INLINE[3] execState #-}
+
+-- | @since 1.1.2.0
+newtype StateC s m a = StateC { runStateC :: ReaderC (IORef s) m a }
+  deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans, MonadUnliftIO)
+
+instance (MonadIO m, Algebra sig m) => Algebra (State s :+: sig) (StateC s m) where
+  alg hdl sig ctx = case sig of
+    L act -> do
+      ref <- StateC (ask @(IORef s))
+      (<$ ctx) <$> case act of
+        Put s -> liftIO (writeIORef ref s)
+        Get   -> liftIO (readIORef ref)
+    R other -> StateC (alg (runStateC . hdl) (R other) ctx)
+  {-# INLINE alg #-}

src/Control/Effect/State.hs

@@ -4,9 +4,10 @@ Not all computations require a full-fledged state effect: read-only state is bet
 
 Predefined carriers:
 
-* "Control.Carrier.State.Church"
 * "Control.Carrier.State.Strict", which is strict in its updates; a good default choice.
 * "Control.Carrier.State.Lazy", which is lazy in its updates. This enables more programs to terminate, such as cyclic computations expressed with @MonadFix@ or @-XRecursiveDo@, at the cost of efficiency.
+* "Control.Carrier.State.Church", which uses continuation-passing style rather than tuple-passing; this may increase performance in some circumstances.
+* "Control.Carrier.State.IORef", which performs its updates impurely via an 'Data.IORef.IORef', which admits a 'Control.Monad.IO.Unlift.MonadUnliftIO' instance but precludes rollback during backtracking.
 * "Control.Monad.Trans.RWS.CPS"
 * "Control.Monad.Trans.RWS.Lazy"
 * "Control.Monad.Trans.RWS.Strict"