Add IORef-based carrier for the Accum effect.

ChangeLog.md

@@ -3,8 +3,9 @@
 - Adds `Accum` ([#391](https://github.com/fused-effects/fused-effects/pull/391)) (by @turion)
   - Adds an `Accum` effect
   - Adds a church-encoded `Control.Carrier.Accum.Church` carrier
-  - Adds a strict `Control.Carrier.Accum.Church` carrier
-  - Defines `Algebra` instances for the two mentioned carriers,
+  - Adds a strict `Control.Carrier.Accum.Strict` carrier
+  - Adds an impure `Control.Carrier.Accum.IORef` carrier ([#430](https://github.com/fused-effects/fused-effects/pull/430))
+  - Defines `Algebra` instances for the three 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))

fused-effects.cabal

@@ -56,6 +56,7 @@ library
     Control.Algebra.Handler
     -- Carriers
     Control.Carrier.Accum.Church
+    Control.Carrier.Accum.IORef
     Control.Carrier.Accum.Strict
     Control.Carrier.Choose.Church
     Control.Carrier.Cull.Church

src/Control/Carrier/Accum/IORef.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{- | A carrier for 'Accum' effects.
+This carrier performs its append operations strictly and thus avoids the space leaks inherent in lazy writer monads.
+These appends are left-associative; as such, @[]@ is a poor choice of monoid for computations that entail many calls to 'add'.
+The [Seq](http://hackage.haskell.org/package/containersdocs/Data-Sequence.html) or [DList](http://hackage.haskell.org/package/dlist) monoids may be a superior choice.
+This carrier also uses an 'IORef' to store its accumulator, which allows it a 'MonadUnliftIO' instance, but precludes backtracking when run in conjunction with 'Control.Effect.NonDet'.
+
+-- | @since 1.1.2.0
+-}
+
+module Control.Carrier.Accum.IORef
+( -- * Accum carrier
+  runAccum
+, execAccum
+, evalAccum
+, AccumC(AccumC)
+  -- * Accum effect
+, module Control.Effect.Accum
+) where
+
+import Control.Algebra
+import Control.Applicative (Alternative(..))
+import Control.Effect.Accum
+import Control.Monad (MonadPlus(..))
+import Control.Monad.Fail as Fail
+import Control.Monad.Fix
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Data.IORef
+import qualified Data.Semigroup as S
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Control.Carrier.Reader
+
+-- | Run an 'Accum' effect with a 'Semigroup'-based log.
+--
+-- @
+-- 'runAccum' w0 ('pure' a) = 'pure' (w0, a)
+-- @
+-- @
+-- 'runAccum' w0 ('add' w) = 'pure' (w0 <> w, ())
+-- @
+-- @
+-- 'runAccum' w0 ('add' w >> 'look') = 'pure' (w0 <> w, w0 <> w)
+-- @
+--
+-- @since 1.1.2.0
+runAccum :: MonadIO m => w -> AccumC w m a -> m (w, a)
+runAccum start go = do
+  ref <- liftIO (newIORef start)
+  result <- runReader ref . runAccumC $ go
+  final <- liftIO (readIORef ref)
+  pure (final, result)
+{-# INLINE runAccum #-}
+
+-- | Run a 'Accum' effect with a 'Semigroup'-based log,
+--   producing the final log and discarding the result value.
+--
+-- @
+-- 'execAccum' w = 'fmap' 'fst' . 'runAccum' w
+-- @
+--
+-- @since 1.1.2.0
+execAccum :: MonadIO m => w -> AccumC w m a -> m w
+execAccum w = fmap fst . runAccum w
+{-# INLINE execAccum #-}
+
+-- | Run a 'Accum' effect with a 'Semigroup'-based log,
+--   producing the result value and discarding the final log.
+--
+-- @
+-- 'evalAccum' w = 'fmap' 'snd' . 'runAccum' w
+-- @
+--
+-- @since 1.1.2.0
+evalAccum :: MonadIO m => w -> AccumC w m a -> m a
+evalAccum w = fmap snd . runAccum w
+{-# INLINE evalAccum #-}
+
+-- | @since 1.1.2.0
+newtype AccumC w m a = AccumC { runAccumC :: ReaderC (IORef w) m a }
+  deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans, MonadUnliftIO)
+
+instance (Algebra sig m, S.Semigroup w, MonadIO m) => Algebra (Accum w :+: sig) (AccumC w m) where
+  alg hdl sig ctx = case sig of
+    L accum -> do
+      ref <- AccumC (ask @(IORef w))
+      (<$ ctx) <$> case accum of
+        Add w' -> liftIO (modifyIORef' ref (S.<> w'))
+        Look   -> liftIO (readIORef ref)
+    R other  -> AccumC (alg (runAccumC . hdl) (R other) ctx)
+  {-# INLINE alg #-}