fused-effects 1.1.1.3 → 1.1.2.0

raw patch · 19 files changed

+725/−8 lines, 19 filesdep +unliftio-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: unliftio-core

API changes (from Hackage documentation)

Files

• ChangeLog.md +18/−0
• README.lhs +1/−1
• README.md +1/−1
• fused-effects.cabal +9/−1
• src/Control/Algebra.hs +15/−0
• src/Control/Carrier/Accum/Church.hs +133/−0
• src/Control/Carrier/Accum/IORef.hs +99/−0
• src/Control/Carrier/Accum/Strict.hs +136/−0
• src/Control/Carrier/Interpret.hs +3/−2
• src/Control/Carrier/Lift.hs +2/−1
• src/Control/Carrier/Reader.hs +5/−0
• src/Control/Carrier/State/IORef.hs +107/−0
• src/Control/Effect/Accum.hs +66/−0
• src/Control/Effect/Accum/Internal.hs +12/−0
• src/Control/Effect/Choose.hs +36/−0
• src/Control/Effect/State.hs +2/−1
• src/Control/Effect/Throw.hs +4/−0
• test/Accum.hs +73/−0
• test/Test.hs +3/−1

@@ -1,3 +1,20 @@+# v1.1.2.0++- Adds `MonadUnliftIO` instances for `ReaderC`, `LiftC`, and `InterpretC`. ([#420](https://github.com/fused-effects/fused-effects/pull/420))++- 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.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))++- Adds an `IORef`-based carrier in `Control.Carrier.State.IORef`. ([#422](https://github.com/fused-effects/fused-effects/pull/422))++ # v1.1.1.3  - Adds support for `inspection-testing` 0.5.@@ -6,6 +23,7 @@ # v1.1.1.2  - Adds support for `ghc` 9.2.1 and `base` 4.16.+  # v1.1.1.1 

@@ -1,6 +1,6 @@ # A fast, flexible, fused effect system for Haskell -[![Build Status](https://action-badges.now.sh/fused-effects/fused-effects)](https://github.com/fused-effects/fused-effects/actions) [![hackage](https://img.shields.io/hackage/v/fused-effects.svg?color=blue&style=popout)](http://hackage.haskell.org/package/fused-effects)+[![Build Status](https://github.com/fused-effects/fused-effects/actions/workflows/ci.yml/badge.svg)](https://github.com/fused-effects/fused-effects/actions) [![hackage](https://img.shields.io/hackage/v/fused-effects.svg?color=blue&style=popout)](http://hackage.haskell.org/package/fused-effects)  - [Overview][]   - [Algebraic effects][]

@@ -1,6 +1,6 @@ # A fast, flexible, fused effect system for Haskell -[![Build Status](https://action-badges.now.sh/fused-effects/fused-effects)](https://github.com/fused-effects/fused-effects/actions) [![hackage](https://img.shields.io/hackage/v/fused-effects.svg?color=blue&style=popout)](http://hackage.haskell.org/package/fused-effects)+[![Build Status](https://github.com/fused-effects/fused-effects/actions/workflows/ci.yml/badge.svg)](https://github.com/fused-effects/fused-effects/actions) [![hackage](https://img.shields.io/hackage/v/fused-effects.svg?color=blue&style=popout)](http://hackage.haskell.org/package/fused-effects)  - [Overview][]   - [Algebraic effects][]

@@ -1,7 +1,7 @@ cabal-version:       2.2  name:                fused-effects-version:             1.1.1.3+version:             1.1.2.0 synopsis:            A fast, flexible, fused effect system. description:         A fast, flexible, fused effect system, à la Effect Handlers in Scope, Monad Transformers and Modular Algebraic Effects: What Binds Them Together, and Fusion for Free—Efficient Algebraic Effect Handlers. homepage:            https://github.com/fused-effects/fused-effects@@ -55,6 +55,9 @@     Control.Algebra     Control.Algebra.Handler     -- Carriers+    Control.Carrier.Accum.Church+    Control.Carrier.Accum.IORef+    Control.Carrier.Accum.Strict     Control.Carrier.Choose.Church     Control.Carrier.Cull.Church     Control.Carrier.Cut.Church@@ -70,6 +73,7 @@     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@@ -79,6 +83,7 @@     Control.Carrier.Writer.Church     Control.Carrier.Writer.Strict     -- Effects+    Control.Effect.Accum     Control.Effect.Catch     Control.Effect.Choose     Control.Effect.Cull@@ -99,6 +104,7 @@     Control.Effect.Trace     Control.Effect.Writer   other-modules:+    Control.Effect.Accum.Internal     Control.Effect.Catch.Internal     Control.Effect.Choose.Internal     Control.Effect.Empty.Internal@@ -112,6 +118,7 @@   build-depends:       base          >= 4.9 && < 4.17     , transformers  >= 0.4 && < 0.6+    , unliftio-core >= 0.2 && < 0.3   test-suite examples@@ -139,6 +146,7 @@   hs-source-dirs: test   main-is:        Test.hs   other-modules:+    Accum     Catch     Choose     Cull

@@ -30,6 +30,9 @@ ) where  import           Control.Algebra.Handler+#if MIN_VERSION_transformers(0,5,4)+import           Control.Effect.Accum.Internal+#endif import           Control.Effect.Catch.Internal import           Control.Effect.Choose.Internal import           Control.Effect.Empty.Internal@@ -41,6 +44,9 @@ import           Control.Effect.Sum ((:+:)(..), Member(..), Members) import           Control.Effect.Throw.Internal import           Control.Effect.Writer.Internal+#if MIN_VERSION_transformers(0,5,4)+import qualified Control.Monad.Trans.Accum as Accum+#endif import qualified Control.Monad.Trans.Except as Except import qualified Control.Monad.Trans.Identity as Identity import qualified Control.Monad.Trans.Maybe as Maybe@@ -326,3 +332,12 @@     L (Censor f m) -> Writer.Strict.censor f (hdl (m <$ ctx))     R other        -> Writer.Strict.WriterT $ getSwap <$> thread ((\ (Swap (x, s)) -> Swap . fmap (mappend s) <$> Writer.Strict.runWriterT x) ~<~ hdl) other (Swap (ctx, mempty))   {-# INLINE alg #-}++#if MIN_VERSION_transformers(0,5,4)+instance (Algebra sig m, Monoid w) => Algebra (Accum w :+: sig) (Accum.AccumT w m) where+  alg hdl sig ctx = case sig of+    L (Add w) -> ctx <$ Accum.add w+    L Look    -> Accum.looks (<$ ctx)+    R other   -> Accum.AccumT $ \w -> getSwap <$> thread ((\(Swap (x, s)) -> Swap . fmap (mappend s) <$> Accum.runAccumT x s) ~<~ hdl) other (Swap (ctx, w))+  {-# INLINE alg #-}+#endif

@@ -0,0 +1,133 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}++{- | A high-performance, strict, church-encoded carrier for 'Accum'.++This carrier issues left-associated 'mappend's, meaning that 'Monoid's such as @[]@ with poor performance for left-associated 'mappend's are ill-suited for use with this carrier. Alternatives such as 'Data.Monoid.Endo', @Seq@, or @DList@ may be preferred.++@since 1.1.2.0+-}++module Control.Carrier.Accum.Church+( -- * 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++-- | Run an 'Accum' effect with a 'Monoid'al log, applying a continuation to the final log and result.+--+-- @+-- 'runAccum' k w0 ('pure' a) = k 'w0' a+-- @+-- @+-- 'runAccum' k w0 ('add' w) = k (w0 <> w) ()+-- @+-- @+-- 'runAccum' k w0 ('add' w >> 'look') = k (w0 <> w) (w0 <> w)+-- @+--+-- @since 1.1.2.0+runAccum :: (w -> a -> m b) -> w -> AccumC w m a -> m b+runAccum k w ma = runAccumC ma k w+{-# INLINE runAccum #-}++-- | Run an 'Accum' effect (typically with a 'Monoid'al log),+--   producing the final log and discarding the result value.+--+-- @+-- 'execAccum' = 'runAccum' ('const' '.' 'pure')+-- @+--+-- @since 1.1.2.0+execAccum :: Applicative m => w -> AccumC w m a -> m w+execAccum = runAccum (const . pure)+{-# INLINE execAccum #-}++-- | Run an 'Accum' effect (typically with a 'Monoid'al log),+--   producing the result value and discarding the final log.+--+-- @+-- 'evalAccum' = 'runAccum' ('const' '.' 'pure')+-- @+--+-- @since 1.1.2.0+evalAccum :: Applicative m => w -> AccumC w m a -> m a+evalAccum = runAccum $ const pure+{-# INLINE evalAccum #-}++-- | @since 1.1.2.0+newtype AccumC w m a = AccumC { runAccumC :: forall r . (w -> a -> m r) -> w -> m r }++instance Monoid w => MonadTrans (AccumC w) where+  lift ma = AccumC $ \k _ -> ma >>= k mempty+  {-# INLINE lift #-}++instance Functor (AccumC w m) where+  fmap f ma = AccumC $ \k w -> runAccumC ma (\w a -> k w $ f a) w+  {-# INLINE fmap #-}++instance Monoid w => Applicative (AccumC w m) where+  pure a = AccumC $ \k _ -> k mempty a+  {-# INLINE pure #-}++  mf <*> ma = AccumC $ \k w ->+    runAccumC mf (\w' f -> runAccumC ma (\w'' a -> k (w' `mappend` w'') $ f a) (w `mappend` w')) w+  {-# INLINE (<*>) #-}++instance (Alternative m, Monad m, Monoid w) => Alternative (AccumC w m) where+  empty = lift empty+  {-# INLINE empty #-}++  ma1 <|> ma2 = AccumC $ \k w -> runAccumC ma1 k w <|> runAccumC ma2 k w+  {-# INLINE (<|>) #-}++instance (Monad m, Monoid w) => Monad (AccumC w m) where+  ma >>= f = AccumC $ \k w -> runAccumC ma (\w' a -> runAccumC (f a) (\w'' -> k $ w' `mappend` w'') (w `mappend` w')) w+  {-# INLINE (>>=) #-}++instance (MonadPlus m, Monoid w) => MonadPlus (AccumC w m) where+  mzero = lift mzero+  {-# INLINE mzero #-}++  ma1 `mplus` ma2 = AccumC $ \k w -> runAccumC ma1 k w `mplus` runAccumC ma2 k w+  {-# INLINE mplus #-}++instance (MonadFail m, Monoid w) => MonadFail (AccumC w m) where+  fail msg = AccumC $ const $ const $ Fail.fail msg+  {-# INLINE fail #-}++instance (MonadFix m, Monoid w) => MonadFix (AccumC w m) where+  mfix ma = AccumC $ \ k w -> mfix ((\accumC -> runAccumC accumC (curry pure) w) . ma . snd) >>= uncurry k+  {-# INLINE mfix #-}++instance (MonadIO m, Monoid w) => MonadIO (AccumC w m) where+  liftIO = lift . liftIO+  {-# INLINE liftIO #-}++instance (Algebra sig m, Monoid w) => Algebra (Accum w :+: sig) (AccumC w m) where+  alg hdl sig ctx = AccumC $ \k w -> case sig of+    L accum -> case accum of+      Add w' -> k w' ctx+      Look   -> k mempty $ w <$ ctx+    R other  -> thread (uncurry (runAccum (curry pure)) ~<~ hdl) other (w, ctx) >>= uncurry k+  {-# INLINE alg #-}

@@ -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 #-}

@@ -0,0 +1,136 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# 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 'tell'.+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.++-- | @since 1.1.2.0+-}++module Control.Carrier.Accum.Strict+( -- * 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++-- | Run an 'Accum' effect with a 'Monoid'al log, applying a continuation to the final log and result.+--+-- @+-- '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 :: w -> AccumC w m a -> m (w, a)+runAccum = flip runAccumC+{-# INLINE runAccum #-}++-- | Run a 'Accum' effect (typically with a 'Monoid'al log),+--   producing the final log and discarding the result value.+--+-- @+-- 'execAccum' w = 'fmap' 'fst' . 'runAccum' w+-- @+--+-- @since 1.1.2.0+execAccum :: (Functor m) => w -> AccumC w m a -> m w+execAccum w = fmap fst . runAccum w+{-# INLINE execAccum #-}++-- | Run a 'Accum' effect (typically with a 'Monoid'al log),+--   producing the result value and discarding the final log.+--+-- @+-- 'evalAccum' w = 'fmap' 'snd' . 'runAccum' w+-- @+--+-- @since 1.1.2.0+evalAccum :: (Functor 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 :: w -> m (w, a) }++instance Monoid w => MonadTrans (AccumC w) where+  lift ma = AccumC $ \_ -> (mempty, ) <$> ma+  {-# INLINE lift #-}++instance Functor m => Functor (AccumC w m) where+  fmap f ma = AccumC $ fmap (fmap f) . runAccumC ma+  {-# INLINE fmap #-}++instance (Monad m, Monoid w) => Applicative (AccumC w m) where+  pure a = AccumC $ const $ pure (mempty, a)+  {-# INLINE pure #-}++  mf <*> ma = AccumC $ \w -> do+    (w' , f) <- runAccumC mf w+    (w'', a) <- runAccumC ma $ mappend w w'+    return (mappend w' w'', f a)+  {-# INLINE (<*>) #-}++instance (Alternative m, Monad m, Monoid w) => Alternative (AccumC w m) where+  empty = lift empty+  {-# INLINE empty #-}++  ma1 <|> ma2 = AccumC $ \w -> runAccumC ma1 w <|> runAccumC ma2 w+  {-# INLINE (<|>) #-}++instance (Monad m, Monoid w) => Monad (AccumC w m) where+  ma >>= f = AccumC $ \w -> do+    (w', a) <- runAccumC ma w+    (w'', b) <- runAccumC (f a) $ mappend w w'+    return (mappend w' w'', b)+  {-# INLINE (>>=) #-}++instance (MonadPlus m, Monoid w) => MonadPlus (AccumC w m) where+  mzero = lift mzero+  {-# INLINE mzero #-}++  ma1 `mplus` ma2 = AccumC $ \w -> runAccumC ma1 w `mplus` runAccumC ma2 w+  {-# INLINE mplus #-}++instance (MonadFail m, Monoid w) => MonadFail (AccumC w m) where+  fail = AccumC . const . Fail.fail+  {-# INLINE fail #-}++instance (MonadFix m, Monoid w) => MonadFix (AccumC w m) where+  mfix ma = AccumC $ \w -> mfix $ flip runAccumC w . ma . snd+  {-# INLINE mfix #-}++instance (MonadIO m, Monoid w) => MonadIO (AccumC w m) where+  liftIO = lift . liftIO+  {-# INLINE liftIO #-}++instance (Algebra sig m, Monoid w) => Algebra (Accum w :+: sig) (AccumC w m) where+  alg hdl sig ctx = AccumC $ \w -> case sig of+    L accum -> case accum of+      Add w' -> pure (w', ctx)+      Look   -> pure (mempty, w <$ ctx)+    R other  -> thread (uncurry runAccum ~<~ hdl) other (w, ctx)+  {-# INLINE alg #-}

@@ -33,6 +33,7 @@ import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Trans.Class+import Control.Monad.IO.Unlift (MonadUnliftIO) import Data.Functor.Const (Const(..)) import Data.Kind (Type) import Unsafe.Coerce (unsafeCoerce)@@ -53,7 +54,7 @@  -- For more information on this technique, see the @reflection@ library. We use the formulation described in https://github.com/ekmett/reflection/issues/31 for better inlining. ----- Essentially we can view @k@ as internally a function of type @Reifies s a -> Tagged s r@, whch we can again view as just @a -> Tagged s r@ through @unsafeCoerce@. After this coercion, we just apply the function to @a@.+-- Essentially we can view @k@ as internally a function of type @Reifies s a -> Tagged s r@, which we can again view as just @a -> Tagged s r@ through @unsafeCoerce@. After this coercion, we just apply the function to @a@. reify :: a -> (forall s . Reifies s a => Const r s) -> r reify a k = unsafeCoerce (Magic k) a @@ -87,7 +88,7 @@  -- | @since 1.0.0.0 newtype InterpretC s (sig :: (Type -> Type) -> (Type -> Type)) m a = InterpretC { runInterpretC :: m a }-  deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus)+  deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadUnliftIO)  instance MonadTrans (InterpretC s sig) where   lift = InterpretC

@@ -20,6 +20,7 @@ import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Trans.Class+import Control.Monad.IO.Unlift (MonadUnliftIO)  -- | Extract a 'Lift'ed 'Monad'ic action from an effectful computation. --@@ -30,7 +31,7 @@  -- | @since 1.0.0.0 newtype LiftC m a = LiftC (m a)-  deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus)+  deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadUnliftIO)  instance MonadTrans LiftC where   lift = LiftC

@@ -24,6 +24,7 @@ import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Trans.Class+import Control.Monad.IO.Unlift  -- | Run a 'Reader' effect with the passed environment value. --@@ -98,3 +99,7 @@     L (Local f m) -> runReader (f r) (hdl (m <$ ctx))     R other       -> alg (runReader r . hdl) other ctx   {-# INLINE alg #-}++instance MonadUnliftIO m => MonadUnliftIO (ReaderC r m) where+  withRunInIO inner = ReaderC $ \ r -> withRunInIO $ \ run -> inner (run . runReader r)+  {-# INLINE withRunInIO #-}

@@ -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 #-}

@@ -0,0 +1,66 @@+{- | An effect allowing writes to an accumulated quantity alongside a computed value,+and reads from the accumulator.+An 'Accum' @w@ effect keeps track of a monoidal datum of type @w@ and strictly appends to that monoidal value with the 'add' effect.+Previous writes to that value can be read with the 'look' effect.++Predefined carriers:++* "Control.Carrier.Accum.Church"+* "Control.Carrier.Accum.Strict". (A lazy carrier is not provided due to the inherent space leaks associated with lazy accumulation monads, similar to lazy writer monads.)+* "Control.Monad.Trans.Accum"++If 'Accum' @w@ is the last effect in a stack, it can be interpreted to a function @w -> (w, a)@ given some result type @a@ and the presence of a 'Monoid' instance for @w@.++-- | @since 1.1.2.0+-}++module Control.Effect.Accum+( -- * Accumulation effect+  Accum(..)+, add+, look+, looks+  -- * Re-exports+, Algebra+, Has+, run+) where++import Control.Algebra+import Control.Effect.Accum.Internal (Accum(..))+++-- | Write a value to the log.+--+-- @+-- 'runAccum' w0 ('add' w '>>' m) = 'Data.Bifunctor.first' ('mappend' w) '<$>' 'runAccum' w0 m+-- 'runAccum' w0 ('add' w '>>' m) = runAccum (w0 <> w) m+-- @+--+-- @since 1.1.2.0+add :: Has (Accum w) sig m => w -> m ()+add w = send (Add w)+{-# INLINE add #-}++-- | Look up the previous accumulation+--+-- @+-- 'runAccum' w 'look' = 'return' (w, w)+-- 'runAccum' w ('look' >>= continuation) = 'runAccum' w (continuation w)+-- @+--+-- @since 1.1.2.0+look :: Has (Accum w) sig m => m w+look = send Look+{-# INLINE look #-}++-- | Look up the previous accumulation and apply a function to it.+--+-- @+-- looks f = fmap f look+-- @+--+-- @since 1.1.2.0+looks :: Has (Accum w) sig m => (w -> a) -> m a+looks f = fmap f look+{-# INLINE looks #-}

@@ -0,0 +1,12 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+module Control.Effect.Accum.Internal+( Accum(..)+) where++import Data.Kind (Type)++-- | @since 1.1.2.0+data Accum w (m :: Type -> Type) k where+  Add  :: w -> Accum w m ()+  Look ::      Accum w m w

@@ -1,3 +1,4 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-}  {- | An effect modelling nondeterminism without failure (one or more successful results).@@ -29,8 +30,16 @@ ) where  import           Control.Algebra+import qualified Control.Applicative as A import           Control.Effect.Choose.Internal (Choose(..)) import           Control.Effect.Empty+import           Control.Monad (MonadPlus)+import           Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class (MonadIO)+import           Control.Monad.IO.Unlift (MonadUnliftIO)+import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Zip import           Data.Bool (bool) import           Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Semigroup as S@@ -107,6 +116,7 @@  -- | @since 1.0.0.0 newtype Choosing m a = Choosing { getChoosing :: m a }+  deriving (Algebra sig, Applicative, Foldable, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadUnliftIO, MonadZip)  instance Has Choose sig m => S.Semigroup (Choosing m a) where   Choosing m1 <> Choosing m2 = Choosing (m1 <|> m2)@@ -118,3 +128,29 @@    mappend = (S.<>)   {-# INLINE mappend #-}++instance (Has Choose sig m, Has Empty sig m) => A.Alternative (Choosing m) where+  empty = mempty+  {-# INLINE empty #-}++  (<|>) = mappend+  {-# INLINE (<|>) #-}++instance (Has Choose sig m, Has Empty sig m) => MonadPlus (Choosing m)++instance MonadTrans Choosing where+  lift = Choosing+  {-# INLINE lift #-}++instance Traversable m => Traversable (Choosing m) where+  sequenceA (Choosing m) = fmap Choosing (sequenceA m)+  {-# INLINE sequenceA #-}++  traverse f (Choosing m) = fmap Choosing (traverse f m)+  {-# INLINE traverse #-}++  sequence (Choosing m) = fmap Choosing (sequence m)+  {-# INLINE sequence #-}++  mapM f (Choosing m) = fmap Choosing (mapM f m)+  {-# INLINE mapM #-}

@@ -4,9 +4,10 @@  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"

@@ -23,6 +23,10 @@  -- | Throw an error, escaping the current computation up to the nearest 'Control.Effect.Catch.catchError' (if any). --+-- @+-- runThrow (throwError e >>= k) = runThrow (throwError e)+-- @+-- -- @since 0.1.0.0 throwError :: Has (Throw e) sig m => e -> m a throwError = send . Throw

@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Accum+( tests+) where++import qualified Control.Carrier.Accum.Church as C.Accum.Church+import qualified Control.Carrier.Accum.Strict as C.Accum.Strict+import           Control.Effect.Accum+#if MIN_VERSION_transformers(0,5,4)+import qualified Control.Monad.Trans.Accum as T.Accum+import           Data.Tuple (swap)+#endif+import           Gen+import qualified Monad+import qualified MonadFix+import Data.Bifunctor (first)++tests :: TestTree+tests = testGroup "Accum"+  [ testGroup "AccumC (Church)" $+    [ testMonad+    , testMonadFix+    , testAccum+    ] >>= ($ runC (C.Accum.Church.runAccum (curry pure)))+  , testGroup "AccumC (Strict)" $+    [ testMonad+    , testMonadFix+    , testAccum+    ] >>= ($ runC C.Accum.Strict.runAccum)+#if MIN_VERSION_transformers(0,5,4)+  , testGroup "AccumT" $ testAccum (runC (fmap (fmap swap) . flip T.Accum.runAccumT))+#endif+  ] where+  testMonad    run = Monad.test    (m (gen0 w) (\_ _ -> [])) a b c initial run+  testMonadFix run = MonadFix.test (m (gen0 w) (\_ _ -> [])) a b   initial run+  testAccum    run = Accum.test    (m (gen0 w) (\_ _ -> [])) a     w       run+  initial = pair <*> w <*> unit++gen0+  :: forall w sig m a+  .  (Has (Accum w) sig m, Arg w, Vary w, Show w)+  => GenTerm w+  -> GenTerm a+  -> [GenTerm (m a)]+gen0 w a =+  [ infixL 4 "<$" (<$) <*> a <*> (label "add" add <*> w)+  , label "looks" (looks @w) <*> fn a+  ]++test+  :: forall w sig m a+  .  (Has (Accum w) sig m, Arg w, Eq a, Eq w, Show a, Show w, Vary w, Monoid w)+  => GenM m+  -> GenTerm a+  -> GenTerm w+  -> Run ((,) w) ((,) w) m+  -> [TestTree]+test m a w (Run runAccum) =+  [ testProperty "look returns the log variable (simple)" . forall (w :. Nil) $+    \ w -> runAccum (w, look) === Identity (mempty, w)+  , testProperty "add appends to the log variable (simple)" . forall (w :. w :. Nil) $+    \ w0 w -> runAccum (w0, add w) === Identity (w, ())+  , testProperty "look returns the log variable (continuation)" . forall (w :. fn (m a) :. Nil) $+    \ w0 k -> runAccum (w0, look >>= k) === runAccum (w0, k w0)+  , testProperty "add appends to the log variable and alters the environment for look" . forall (w :. w :. Nil) $+    \ w0 w -> runAccum (w0, add w >> look) === runAccum (mappend w0 w, look @w <* add w)+  , testProperty "add appends to the log variable and alters the environment for continuations" . forall (w :. w :. m a :. Nil) $+    \ w0 w k -> runAccum (w0, add w >> k) === (first (mappend w) <$> runAccum (mappend w0 w, k))+  ]

@@ -2,6 +2,7 @@ ( main ) where +import qualified Accum import qualified Catch import qualified Choose import qualified Cull@@ -24,7 +25,8 @@  main :: IO () main = defaultMain $ map checkTestTree-  [ Catch.tests+  [ Accum.tests+  , Catch.tests   , Choose.tests   , Cull.tests   , Cut.tests