fused-effects 0.1.2.1 → 0.2.0.0

raw patch · 12 files changed

+249/−145 lines, 12 filesdep +criteriondep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: criterion

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +13/−0
• LICENSE +1/−1
• README.md +16/−105
• benchmark/Bench.hs +28/−0
• fused-effects.cabal +14/−2
• src/Control/Effect/Error.hs +6/−2
• src/Control/Effect/Lift.hs +9/−1
• src/Control/Effect/Reader.hs +3/−3
• src/Control/Effect/Resource.hs +41/−6
• src/Control/Effect/State.hs +6/−6
• src/Control/Effect/Void.hs +18/−0
• src/Control/Effect/Writer.hs +94/−19

@@ -1,3 +1,16 @@+# 0.2.0.0++- Adds `listen`, `listens`, and `censor` operations to `Writer`.+- Provides explicit type parameters to `run`-style functions in `State`, `Reader`, `Writer`, and `Error`.+  This is a backwards-incompatible change for clients using these functions in combination with visible type applications.+- Adds benchmarks of `WriterC`/`VoidC` wrapped with `Eff` against their unwrapped counterparts.+- Adds `Functor`, `Applicative`, and `Monad` instances for `WriterC`.+- Adds `Functor`, `Applicative`, and `Monad` instances for `VoidC`.+- Fixes a space leak with `WriterC`.+- Removes the `Functor` constraint on `asks` and `gets`.+- Adds `bracketOnError`, `finally`, and `onException` to `Resource`.+- Adds `sendM` to `Lift`.+ # 0.1.2.1  - Loosens the bounds on QuickCheck to accommodate 0.12.

@@ -1,6 +1,6 @@ BSD 3-Clause License -Copyright (c) 2018, Nicolas Wu, Tom Schrijvers, Rob Rix, and Patrick Thomson+Copyright (c) 2018-2019, Nicolas Wu, Tom Schrijvers, Rob Rix, and Patrick Thomson All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -11,12 +11,12 @@   - [Running effects][]   - [Required compiler extensions][]   - [Defining new effects][]-  - [Defining effect handlers][] - [Project overview][]   - [Development][]   - [Versioning][] - [Benchmarks][] - [Related work][]+  - [Contributed packages][]   - [Comparison to `mtl`][]   - [Comparison to `freer-simple`][] @@ -39,6 +39,7 @@ [Benchmarks]: https://github.com/robrix/fused-effects#benchmarks  [Related work]: https://github.com/robrix/fused-effects#related-work+[Contributed packages]: https://github.com/robrix/fused-effects#contributed-packages [Comparison to `mtl`]: https://github.com/robrix/fused-effects#comparison-to-mtl [Comparison to `freer-simple`]: https://github.com/robrix/fused-effects#comparison-to-freer-simple @@ -168,107 +169,9 @@  ### Defining new effects -Effects are a powerful mechanism for abstraction, and so defining new effects is a valuable tool for system architecture. Effects are modelled as (higher-order) functors, with an explicit continuation denoting the remainder of the computation after the effect.--It’s often helpful to start by specifying the types of the desired operations. For our example, we’re going to define a `Teletype` effect, with `read` and `write` operations, which read a string from some input and write a string to some output, respectively:--```haskell-data Teletype (m :: * -> *) k-read :: (Member Teletype sig, Carrier sig m) => m String-write :: (Member Teletype sig, Carrier sig m) => String -> m ()-```--Effect types must have two type parameters: `m`, denoting any computations which the effect embeds, and `k`, denoting the remainder of the computation after the effect. Note that since `Teletype` doesn’t use `m`, the compiler will infer it as being of kind `*` by default. The explicit kind annotation on `m` corrects that.--Next, we can flesh out the definition of the `Teletype` effect by providing constructors for each primitive operation:--```haskell-data Teletype (m :: * -> *) k-  = Read (String -> k)-  | Write String k-  deriving (Functor)-```--The `Read` operation returns a `String`, and hence its continuation is represented as a function _taking_ a `String`. Thus, to continue the computation, a handler will have to provide a `String`. But since the effect type doesn’t say anything about where that `String` should come from, handlers are free to read from `stdin`, use a constant value, etc.--On the other hand, the `Write` operation returns `()`. Since a function `() -> k` is equivalent to a (non-strict) `k`, we can omit the function parameter.--In addition to a `Functor` instance (derived here using `-XDeriveFunctor`), we need two other instances: `HFunctor` and `Effect`. `HFunctor`, named for “higher-order functor,” has one non-default operation, `hmap`, which applies a function to any embedded computations inside an effect. Since `Teletype` is first-order (i.e. it doesn’t have any embedded computations), the definition of `hmap` can be given using `coerce`:--```haskell-instance HFunctor Teletype where-  hmap _ = coerce-```--`Effect` plays a similar role to the combination of `Functor` (which operates on continuations) and `HFunctor` (which operates on embedded computations). It’s used by `Carrier` instances to service any requests for their effect occurring inside other computations—whether embedded or in the continuations. Since these may require some state to be maintained, `handle` takes an initial state parameter (encoded as some arbitrary functor filled with `()`), and its function is phrased as a _distributive law_, mapping state functors containing unhandled computations to handled computations producing the state functor alongside any results.--Since `Teletype`’s operations don’t have any embedded computations, the `Effect` instance only has to operate on the continuations, by wrapping the computations in the state and applying the handler:--```haskell-instance Effect Teletype where-  handle state handler (Read    k) = Read (handler . (<$ state) . k)-  handle state handler (Write s k) = Write s (handler (k <$ state))-```--Now that we have our effect datatype, we can give definitions for `read` and `write`:--```haskell-read :: (Member Teletype sig, Carrier sig m) => m String-read = send (Read ret)--write :: (Member Teletype sig, Carrier sig m) => String -> m ()-write s = send (Write s (ret ()))-```--This gives us enough to write computations using the `Teletype` effect. The next section discusses how to run `Teletype` computations.---### Defining effect handlers--Effects only specify actions, they don’t actually perform them. That task is left up to effect handlers, typically defined as functions calling `interpret` to apply a given `Carrier` instance.--Following from the above section, we can define a carrier for the `Teletype` effect which runs the calls in an underlying `MonadIO` instance:--```haskell-newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }--instance (Carrier sig m, MonadIO m) => Carrier (Teletype :+: sig) (TeletypeIOC m) where-  ret = TeletypeIOC . ret--  eff = TeletypeIOC . handleSum (eff . handleCoercible) (\ t -> case t of-    Read    k -> liftIO getLine      >>= runTeletypeIOC . k-    Write s k -> liftIO (putStrLn s) >>  runTeletypeIOC   k)-```--Here, `ret` is responsible for wrapping pure values in the carrier, and `eff` is responsible for handling an effectful computations. Since the `Carrier` instance handles a sum (`:+:`) of `Teletype` and the remaining signature, `eff` has two parts: a handler for `Teletype` (`alg`), and a handler for teletype effects that might be embedded in other effects in the signature.--In this case, since the `Teletype` carrier is just a thin wrapper around the underlying computation, we can use `handleCoercible` to handle any embedded `TeletypeIOC` carriers by simply mapping `coerce` over them.--That leaves `alg`, which handles `Teletype` effects with one case per constructor. Since we’re assuming the existence of a `MonadIO` instance for the underlying computation, we can use `liftIO` to inject the `getLine` and `putStrLn` actions into it, and then proceed with the continuations, unwrapping them in the process.--Users could use `interpret` directly to run the effect, but it’s more convenient to provide effect handler functions applying `interpret` and then unwrapping the carrier:--```haskell-runTeletypeIO :: (MonadIO m, Carrier sig m) => Eff (TeletypeIOC m) a -> m a-runTeletypeIO = runTeletypeIOC . interpret-```--In general, carriers don’t have to be `Functor`s, let alone `Monad`s. However, sometimes—especially in cases where the carrier is a thin wrapper like this—they can be more convenient to write using (derived) `Monad` instances. In this case, by using `-XGeneralizedNewtypeDeriving`, we can derive `Functor`, `Applicative`, `Monad`, and `MonadIO` instances for `TeletypeIOC`:--```haskell-newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }-  deriving (Applicative, Functor, Monad, MonadIO)-```--This allows us to use `liftIO` directly on the carrier itself, instead of only in the underlying `m`; likewise with `>>=`, `>>`, and `pure`:+The process of defining new effects is outlined in [`docs/defining_effects.md`][], using the classic `Teletype` effect as an example. -```haskell-instance (MonadIO m, Carrier sig m) => Carrier (Teletype :+: sig) (TeletypeIOC m) where-  ret = pure-  eff = handleSum (TeletypeIOC . eff . handleCoercible) (\ t -> case t of-    Read    k -> liftIO getLine      >>= k-    Write s k -> liftIO (putStrLn s) >>  k)-```+[`docs/defining_effects.md`]: https://github.com/robrix/fused-effects/blob/master/docs/defining_effects.md  ## Project overview @@ -307,7 +210,7 @@  ## Benchmarks -`fused-effects` has been [benchmarked against a number of other effect systems](https://github.com/joshvera/freemonad-benchmark). See also [@patrickt’s benchmarks](https://github.com/patrickt/effects-benchmarks).+To run the provided benchmark suite, use `cabal new-bench`. You may wish to provide the `-O2` compiler option to view performance under aggressive optimizations. `fused-effects` has been [benchmarked against a number of other effect systems](https://github.com/joshvera/freemonad-benchmark). See also [@patrickt’s benchmarks](https://github.com/patrickt/effects-benchmarks).   ## Related work@@ -318,7 +221,15 @@ [Monad Transformers and Modular Algebraic Effects: What Binds Them Together]: http://www.cs.kuleuven.be/publicaties/rapporten/cw/CW699.pdf [Fusion for Free—Efficient Algebraic Effect Handlers]: https://people.cs.kuleuven.be/~tom.schrijvers/Research/papers/mpc2015.pdf +### Contributed packages +Though we aim to keep the `fused-effects` core minimal, we encourage the development of external `fused-effects`-compatible libraries. If you've written one that you'd like to be mentioned here, get in touch!++* [`fused-effects-lens`][felens] provides combinators to use the [`lens`][lens] library fluently inside effectful computatios.++[felens]: http://hackage.haskell.org/package/fused-effects-lens+[lens]: http://hackage.haskell.org/package/lens+ ### Comparison to `mtl`  Like [`mtl`][], `fused-effects` provides a library of monadic effects which can be given different interpretations. In `mtl` this is done by defining new instances of the typeclasses encoding the actions of the effect, e.g. `MonadState`. In `fused-effects`, this is done by defining new instances of the `Carrier` typeclass for the effect.@@ -342,9 +253,9 @@ Indeed, `Wrapper` can now be made an instance of `MonadState`:  ```haskell-instance (Carrier sig m, Member (State s) m) => MTL.MonadState s (Wrapper s m) where-  get = get-  put = put+instance (Carrier sig m, Member (State s) sig, Monad m) => MTL.MonadState s (Wrapper s m) where+  get = Control.Effect.State.get+  put = Control.Effect.State.put ```  Thus, the approaches aren’t mutually exclusive; consumers are free to decide which approach makes the most sense for their situation.

@@ -0,0 +1,28 @@+{-# LANGUAGE FlexibleContexts, TypeApplications, TypeOperators #-}+module Main where++import Control.Effect+import Control.Effect.Void+import Control.Effect.Writer+import Control.Monad (replicateM_)+import Criterion.Main+import Data.Monoid (Sum(..))++main :: IO ()+main = defaultMain+  [ bgroup "WriterC"+    [ bgroup "Eff"+      [ bench "100"       $ whnf (run . execWriter @_ @_ @(Sum Int) . tellLoop) 100+      , bench "100000"    $ whnf (run . execWriter @_ @_ @(Sum Int) . tellLoop) 100000+      , bench "100000000" $ whnf (run . execWriter @_ @_ @(Sum Int) . tellLoop) 100000000+      ]+    , bgroup "standalone"+      [ bench "100"       $ whnf (fst . runVoidC . flip runWriterC (Sum (0 :: Int)) . tellLoop) 100+      , bench "100000"    $ whnf (fst . runVoidC . flip runWriterC (Sum (0 :: Int)) . tellLoop) 100000+      , bench "100000000" $ whnf (fst . runVoidC . flip runWriterC (Sum (0 :: Int)) . tellLoop) 100000000+      ]+    ]+  ]++tellLoop :: (Applicative m, Carrier sig m, Member (Writer (Sum Int)) sig) => Int -> m ()+tellLoop i = replicateM_ i (tell (Sum (1 :: Int)))

@@ -1,5 +1,5 @@ name:                fused-effects-version:             0.1.2.1+version:             0.2.0.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/robrix/fused-effects@@ -7,7 +7,7 @@ license-file:        LICENSE author:              Nicolas Wu, Tom Schrijvers, Rob Rix, Patrick Thomson maintainer:          robrix@github.com-copyright:           2018 Nicolas Wu, Tom Schrijvers, Rob Rix, Patrick Thomson+copyright:           2018-2019 Nicolas Wu, Tom Schrijvers, Rob Rix, Patrick Thomson category:            Control build-type:          Simple extra-source-files:@@ -86,6 +86,18 @@                      , doctest >=0.7 && <1.0   hs-source-dirs:      test   default-language:    Haskell2010+++benchmark benchmark+  type:               exitcode-stdio-1.0+  main-is:            Bench.hs+  build-depends:      base >=4.9 && <4.13+                    , criterion+                    , fused-effects+  hs-source-dirs:     benchmark+  default-language:   Haskell2010+  ghc-options:        -threaded -rtsopts "-with-rtsopts=-N -A4m -n2m"+  source-repository head   type:     git

@@ -34,7 +34,11 @@  -- | Run a computation which can throw errors with a handler to run on error. -----   Errors thrown by the handler will escape up to the nearest enclosing 'catchError' (if any).+-- Errors thrown by the handler will escape up to the nearest enclosing 'catchError' (if any).+-- Note that this effect does /not/ handle errors thrown from impure contexts such as IO,+-- nor will it handle exceptions thrown from pure code. If you need to handle IO-based errors,+-- consider if 'Control.Effect.Resource' fits your use case; if not, use 'liftIO' with+-- 'Control.Exception.try' or use 'Control.Exception.Catch' from outside the effect invocation. -- --   prop> run (runError (pure a `catchError` pure)) == Right a --   prop> run (runError (throwError a `catchError` pure)) == Right @Int @Int a@@ -46,7 +50,7 @@ -- | Run an 'Error' effect, returning uncaught errors in 'Left' and successful computations’ values in 'Right'. -- --   prop> run (runError (pure a)) == Right @Int @Int a-runError :: (Carrier sig m, Effect sig, Monad m) => Eff (ErrorC exc m) a -> m (Either exc a)+runError :: forall exc sig m a . (Carrier sig m, Effect sig, Monad m) => Eff (ErrorC exc m) a -> m (Either exc a) runError = runErrorC . interpret  newtype ErrorC e m a = ErrorC { runErrorC :: m (Either e a) }

@@ -1,17 +1,25 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-} module Control.Effect.Lift ( Lift(..)+, sendM , runM , LiftC(..) ) where  import Control.Effect.Carrier+import Control.Effect.Sum import Control.Effect.Internal import Control.Effect.Lift.Internal  -- | Extract a 'Lift'ed 'Monad'ic action from an effectful computation. runM :: Monad m => Eff (LiftC m) a -> m a runM = runLiftC . interpret++-- | Given a @Lift n@ constraint in a signature carried by @m@, 'sendM'+-- promotes arbitrary actions of type @n a@ to @m a@. It is spiritually+-- similar to @lift@ from the @MonadTrans@ typeclass.+sendM :: (Member (Lift n) sig, Carrier sig m, Functor n, Applicative m) => n a -> m a+sendM = send . Lift . fmap pure  newtype LiftC m a = LiftC { runLiftC :: m a } 

@@ -35,8 +35,8 @@ -- | Project a function out of the current environment value. -- --   prop> snd (run (runReader a (asks (applyFun f)))) == applyFun f a-asks :: (Member (Reader r) sig, Carrier sig m, Functor m) => (r -> a) -> m a-asks f = fmap f ask+asks :: (Member (Reader r) sig, Carrier sig m) => (r -> a) -> m a+asks f = send (Ask (ret . f))  -- | Run a computation with an environment value locally modified by the passed function. --@@ -49,7 +49,7 @@ -- | Run a 'Reader' effect with the passed environment value. -- --   prop> run (runReader a (pure b)) == b-runReader :: (Carrier sig m, Monad m) => r -> Eff (ReaderC r m) a -> m a+runReader :: forall r sig m a . (Carrier sig m, Monad m) => r -> Eff (ReaderC r m) a -> m a runReader r m = runReaderC (interpret m) r  newtype ReaderC r m a = ReaderC { runReaderC :: r -> m a }

@@ -1,7 +1,10 @@-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Resource ( Resource(..) , bracket+, bracketOnError+, finally+, onException , runResource , ResourceC(..) ) where@@ -14,14 +17,17 @@  data Resource m k   = forall resource any output . Resource (m resource) (resource -> m any) (resource -> m output) (output -> k)+  | forall resource any output . OnError  (m resource) (resource -> m any) (resource -> m output) (output -> k)  deriving instance Functor (Resource m)  instance HFunctor Resource where   hmap f (Resource acquire release use k) = Resource (f acquire) (f . release) (f . use) k+  hmap f (OnError acquire release use k)  = OnError  (f acquire) (f . release) (f . use) k  instance Effect Resource where   handle state handler (Resource acquire release use k) = Resource (handler (acquire <$ state)) (handler . fmap release) (handler . fmap use) (handler . fmap k)+  handle state handler (OnError acquire release use k)  = OnError  (handler (acquire <$ state)) (handler . fmap release) (handler . fmap use) (handler . fmap k)  -- | Provides a safe idiom to acquire and release resources safely. --@@ -40,7 +46,29 @@         -> m a bracket acquire release use = send (Resource acquire release use ret) +-- | Like 'bracket', but only performs the final action if there was an+-- exception raised by the in-between computation.+bracketOnError :: (Member Resource sig, Carrier sig m)+               => m resource           -- ^ computation to run first ("acquire resource")+               -> (resource -> m any)  -- ^ computation to run last ("release resource")+               -> (resource -> m a)    -- ^ computation to run in-between+               -> m a+bracketOnError acquire release use = send (OnError acquire release use ret) +-- | Like 'bracket', but for the simple case of one computation to run afterward.+finally :: (Member Resource sig, Carrier sig m, Applicative m)+        => m a -- ^ computation to run first+        -> m b -- ^ computation to run afterward (even if an exception was raised)+        -> m a+finally act end = bracket (pure ()) (const end) (const act)++-- | Like 'bracketOnError', but for the simple case of one computation to run afterward.+onException :: (Member Resource sig, Carrier sig m, Applicative m)+        => m a -- ^ computation to run first+        -> m b -- ^ computation to run afterward if an exception was raised+        -> m a+onException act end = bracketOnError (pure ()) (const end) (const act)+ runResource :: (Carrier sig m, MonadIO m)             => (forall x . m x -> IO x)             -> Eff (ResourceC m) a@@ -56,8 +84,15 @@   ret a = ResourceC (const (ret a))   eff op = ResourceC (\ handler -> handleSum     (eff . handlePure (runResourceC handler))-    (\ (Resource acquire release use k) -> liftIO (Exc.bracket-      (handler (runResourceC handler acquire))-      (handler . runResourceC handler . release)-      (handler . runResourceC handler . use))-      >>= runResourceC handler . k) op)+    (\case+        Resource acquire release use k -> liftIO (Exc.bracket+                                                    (handler (runResourceC handler acquire))+                                                    (handler . runResourceC handler . release)+                                                    (handler . runResourceC handler . use))+                                            >>= runResourceC handler . k+        OnError acquire release use k -> liftIO (Exc.bracketOnError+                                                    (handler (runResourceC handler acquire))+                                                    (handler . runResourceC handler . release)+                                                    (handler . runResourceC handler . use))+                                            >>= runResourceC handler . k+    ) op)

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, KindSignatures, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExplicitForAll, FlexibleContexts, FlexibleInstances, KindSignatures, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} module Control.Effect.State ( State(..) , get@@ -38,8 +38,8 @@ -- | Project a function out of the current state value. -- --   prop> snd (run (runState a (gets (applyFun f)))) == applyFun f a-gets :: (Member (State s) sig, Carrier sig m, Functor m) => (s -> a) -> m a-gets f = fmap f get+gets :: (Member (State s) sig, Carrier sig m) => (s -> a) -> m a+gets f = send (Get (ret . f))  -- | Replace the state value with a new value. --@@ -61,19 +61,19 @@ -- | Run a 'State' effect starting from the passed value. -- --   prop> run (runState a (pure b)) == (a, b)-runState :: (Carrier sig m, Effect sig) => s -> Eff (StateC s m) a -> m (s, a)+runState :: forall s sig m a . (Carrier sig m, Effect sig) => s -> Eff (StateC s m) a -> m (s, a) runState s m = runStateC (interpret m) s  -- | Run a 'State' effect, yielding the result value and discarding the final state. -- --   prop> run (evalState a (pure b)) == b-evalState :: (Carrier sig m, Effect sig, Functor m) => s -> Eff (StateC s m) a -> m a+evalState :: forall s sig m a . (Carrier sig m, Effect sig, Functor m) => s -> Eff (StateC s m) a -> m a evalState s m = fmap snd (runStateC (interpret m) s)  -- | Run a 'State' effect, yielding the final state and discarding the return value. -- --   prop> run (execState a (pure b)) == a-execState :: (Carrier sig m, Effect sig, Functor m) => s -> Eff (StateC s m) a -> m s+execState :: forall s sig m a . (Carrier sig m, Effect sig, Functor m) => s -> Eff (StateC s m) a -> m s execState s m = fmap fst (runStateC (interpret m) s)  

@@ -27,6 +27,24 @@  newtype VoidC a = VoidC { runVoidC :: a } +instance Functor VoidC where+  fmap f (VoidC a) = VoidC (f a)+  {-# INLINE fmap #-}++instance Applicative VoidC where+  pure = VoidC+  {-# INLINE pure #-}++  VoidC f <*> VoidC a = VoidC (f a)+  {-# INLINE (<*>) #-}++instance Monad VoidC where+  return = pure+  {-# INLINE return #-}++  VoidC a >>= f = f a+  {-# INLINE (>>=) #-}+ instance Carrier Void VoidC where   ret = VoidC   {-# INLINE ret #-}

@@ -1,7 +1,10 @@-{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, ExplicitForAll, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Writer ( Writer(..) , tell+, listen+, listens+, censor , runWriter , execWriter , WriterC(..)@@ -10,51 +13,123 @@ import Control.Effect.Carrier import Control.Effect.Sum import Control.Effect.Internal-import Data.Bifunctor (first)-import Data.Coerce -data Writer w (m :: * -> *) k = Tell w k-  deriving (Functor)+data Writer w m k+  = Tell w k+  | forall a . Listen (m a) (w -> a -> k)+  | forall a . Censor (w -> w) (m a) (a -> k) +deriving instance Functor (Writer w m)+ instance HFunctor (Writer w) where-  hmap _ = coerce+  hmap _ (Tell w     k) = Tell w         k+  hmap f (Listen   m k) = Listen   (f m) k+  hmap f (Censor g m k) = Censor g (f m) k   {-# INLINE hmap #-}  instance Effect (Writer w) where-  handle state handler (Tell w k) = Tell w (handler (k <$ state))+  handle state handler (Tell w     k) = Tell w                          (handler (k <$ state))+  handle state handler (Listen   m k) = Listen   (handler (m <$ state)) (fmap handler . fmap . k)+  handle state handler (Censor f m k) = Censor f (handler (m <$ state)) (handler . fmap k)+  {-# INLINE handle #-}  -- | Write a value to the log. -- --   prop> fst (run (runWriter (mapM_ (tell . Sum) (0 : ws)))) == foldMap Sum ws tell :: (Member (Writer w) sig, Carrier sig m) => w -> m () tell w = send (Tell w (ret ()))+{-# INLINE tell #-} +-- | Run a computation, returning the pair of its output and its result.+--+--   prop> run (runWriter (fst <$ tell (Sum a) <*> listen @(Sum Integer) (tell (Sum b)))) == (Sum a <> Sum b, Sum b)+listen :: (Member (Writer w) sig, Carrier sig m) => m a -> m (w, a)+listen m = send (Listen m (curry ret))+{-# INLINE listen #-} +-- | Run a computation, applying a function to its output and returning the pair of the modified output and its result.+--+--   prop> run (runWriter (fst <$ tell (Sum a) <*> listens @(Sum Integer) (applyFun f) (tell (Sum b)))) == (Sum a <> Sum b, applyFun f (Sum b))+listens :: (Member (Writer w) sig, Carrier sig m) => (w -> b) -> m a -> m (b, a)+listens f m = send (Listen m (curry ret . f))+{-# INLINE listens #-}++-- | Run a computation, modifying its output with the passed function.+--+--   prop> run (execWriter (censor (applyFun f) (tell (Sum a)))) == applyFun f (Sum a)+--   prop> run (execWriter (tell (Sum a) *> censor (applyFun f) (tell (Sum b)) *> tell (Sum c))) == (Sum a <> applyFun f (Sum b) <> Sum c)+censor :: (Member (Writer w) sig, Carrier sig m) => (w -> w) -> m a -> m a+censor f m = send (Censor f m ret)+{-# INLINE censor #-}++ -- | Run a 'Writer' effect with a 'Monoid'al log, producing the final log alongside the result value. -- --   prop> run (runWriter (tell (Sum a) *> pure b)) == (Sum a, b)-runWriter :: (Carrier sig m, Effect sig, Functor m, Monoid w) => Eff (WriterC w m) a -> m (w, a)-runWriter m = runWriterC (interpret m)+runWriter :: forall w sig m a . (Carrier sig m, Effect sig, Monad m, Monoid w) => Eff (WriterC w m) a -> m (w, a)+runWriter m = runWriterC (interpret m) mempty+{-# INLINE runWriter #-}  -- | Run a 'Writer' effect with a 'Monoid'al log, producing the final log and discarding the result value. -- --   prop> run (execWriter (tell (Sum a) *> pure b)) == Sum a-execWriter :: (Carrier sig m, Effect sig, Functor m, Monoid w) => Eff (WriterC w m) a -> m w-execWriter m = fmap fst (runWriterC (interpret m))+execWriter :: forall w sig m a . (Carrier sig m, Effect sig, Monad m, Monoid w) => Eff (WriterC w m) a -> m w+execWriter = fmap fst . runWriter+{-# INLINE execWriter #-}  -newtype WriterC w m a = WriterC { runWriterC :: m (w, a) }+-- | A space-efficient carrier for 'Writer' effects.+--+--   This is based on a post Gabriel Gonzalez made to the Haskell mailing list: https://mail.haskell.org/pipermail/libraries/2013-March/019528.html+--+--   Note that currently, the constant-space behaviour observed there only occurs when using 'WriterC' and 'VoidC' without 'Eff' wrapping them. See the @benchmark@ component for details.+newtype WriterC w m a = WriterC { runWriterC :: w -> m (w, a) } -instance (Monoid w, Carrier sig m, Effect sig, Functor m) => Carrier (Writer w :+: sig) (WriterC w m) where-  ret a = WriterC (ret (mempty, a))-  eff = WriterC . handleSum-    (eff . handle (mempty, ()) (uncurry runWriter'))-    (\ (Tell w k) -> first (mappend w) <$> runWriterC k)-    where runWriter' w = fmap (first (mappend w)) . runWriterC+instance Functor m => Functor (WriterC w m) where+  fmap f (WriterC run) = WriterC (\ w -> fmap (fmap f) (run w))+  {-# INLINE fmap #-} +instance (Monad m, Monoid w) => Applicative (WriterC w m) where+  pure a = WriterC $ \w -> pure (w, a)+  {-# INLINE pure #-} +  WriterC f <*> WriterC a = WriterC $ \ w -> do+    (w', f') <- f w+    (w'', a') <- a w'+    let fa = f' a'+    fa `seq` pure (w'', fa)+  {-# INLINE (<*>) #-}++instance (Monad m, Monoid w) => Monad (WriterC w m) where+  return = pure+  {-# INLINE return #-}++  m >>= f  = WriterC $ \w -> do+    (w', a) <- runWriterC m w+    runWriterC (f a) w'+  {-# INLINE (>>=) #-}++instance (Monoid w, Carrier sig m, Effect sig, Monad m) => Carrier (Writer w :+: sig) (WriterC w m) where+  ret a = WriterC (\ w -> ret (w, a))+  {-# INLINE ret #-}++  eff op = WriterC (\ w -> handleSum (eff . handleState w runWriterC) (\case+    Tell w'    k -> let w'' = mappend w w' in w'' `seq` runWriterC k w''+    Listen   m k -> do+      (w', a) <- runWriterC m mempty+      let w'' = mappend w w'+      w'' `seq` runWriterC (k w' a) w''+    Censor f m k -> do+      (w', a) <- runWriterC m mempty+      let w'' = mappend w (f w')+      w'' `seq` runWriterC (k a) w'')+    op)+  {-# INLINE eff #-}++ -- $setup -- >>> :seti -XFlexibleContexts+-- >>> :seti -XTypeApplications -- >>> import Test.QuickCheck -- >>> import Control.Effect.Void--- >>> import Data.Monoid (Sum(..))+-- >>> import Data.Semigroup (Semigroup(..), Sum(..))