diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -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][] diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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][] diff --git a/fused-effects.cabal b/fused-effects.cabal --- a/fused-effects.cabal +++ b/fused-effects.cabal @@ -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 diff --git a/src/Control/Algebra.hs b/src/Control/Algebra.hs --- a/src/Control/Algebra.hs +++ b/src/Control/Algebra.hs @@ -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 diff --git a/src/Control/Carrier/Accum/Church.hs b/src/Control/Carrier/Accum/Church.hs new file mode 100644 --- /dev/null +++ b/src/Control/Carrier/Accum/Church.hs @@ -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 #-} diff --git a/src/Control/Carrier/Accum/IORef.hs b/src/Control/Carrier/Accum/IORef.hs new file mode 100644 --- /dev/null +++ b/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 #-} diff --git a/src/Control/Carrier/Accum/Strict.hs b/src/Control/Carrier/Accum/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Control/Carrier/Accum/Strict.hs @@ -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 #-} diff --git a/src/Control/Carrier/Interpret.hs b/src/Control/Carrier/Interpret.hs --- a/src/Control/Carrier/Interpret.hs +++ b/src/Control/Carrier/Interpret.hs @@ -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 diff --git a/src/Control/Carrier/Lift.hs b/src/Control/Carrier/Lift.hs --- a/src/Control/Carrier/Lift.hs +++ b/src/Control/Carrier/Lift.hs @@ -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 diff --git a/src/Control/Carrier/Reader.hs b/src/Control/Carrier/Reader.hs --- a/src/Control/Carrier/Reader.hs +++ b/src/Control/Carrier/Reader.hs @@ -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 #-} diff --git a/src/Control/Carrier/State/IORef.hs b/src/Control/Carrier/State/IORef.hs new file mode 100644 --- /dev/null +++ b/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 #-} diff --git a/src/Control/Effect/Accum.hs b/src/Control/Effect/Accum.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Accum.hs @@ -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 #-} diff --git a/src/Control/Effect/Accum/Internal.hs b/src/Control/Effect/Accum/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Accum/Internal.hs @@ -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 diff --git a/src/Control/Effect/Choose.hs b/src/Control/Effect/Choose.hs --- a/src/Control/Effect/Choose.hs +++ b/src/Control/Effect/Choose.hs @@ -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 #-} diff --git a/src/Control/Effect/State.hs b/src/Control/Effect/State.hs --- a/src/Control/Effect/State.hs +++ b/src/Control/Effect/State.hs @@ -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" diff --git a/src/Control/Effect/Throw.hs b/src/Control/Effect/Throw.hs --- a/src/Control/Effect/Throw.hs +++ b/src/Control/Effect/Throw.hs @@ -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 diff --git a/test/Accum.hs b/test/Accum.hs new file mode 100644 --- /dev/null +++ b/test/Accum.hs @@ -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)) + ] diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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