effet (empty) → 0.1.0.0
raw patch · 27 files changed
+3033/−0 lines, 27 filesdep +basedep +containersdep +monad-control
Dependencies added: base, containers, monad-control, template-haskell, transformers, transformers-base
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +293/−0
- effet.cabal +68/−0
- src/Control/Effect/Cont.hs +101/−0
- src/Control/Effect/Embed.hs +65/−0
- src/Control/Effect/Error.hs +91/−0
- src/Control/Effect/Machinery.hs +47/−0
- src/Control/Effect/Machinery/Default.hs +54/−0
- src/Control/Effect/Machinery/Kind.hs +68/−0
- src/Control/Effect/Machinery/TH.hs +613/−0
- src/Control/Effect/Machinery/Tagger.hs +41/−0
- src/Control/Effect/Machinery/Via.hs +68/−0
- src/Control/Effect/Map.hs +122/−0
- src/Control/Effect/Map/Lazy.hs +63/−0
- src/Control/Effect/Map/Strict.hs +63/−0
- src/Control/Effect/RWS.hs +253/−0
- src/Control/Effect/RWS/Lazy.hs +82/−0
- src/Control/Effect/RWS/Strict.hs +121/−0
- src/Control/Effect/Reader.hs +110/−0
- src/Control/Effect/Resource.hs +143/−0
- src/Control/Effect/State.hs +136/−0
- src/Control/Effect/State/Lazy.hs +73/−0
- src/Control/Effect/State/Strict.hs +73/−0
- src/Control/Effect/Writer.hs +101/−0
- src/Control/Effect/Writer/Lazy.hs +56/−0
- src/Control/Effect/Writer/Strict.hs +93/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for effet + +## 0.1.0.0 (2020-07-17) + +* Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Michael Szvetits (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Michael Szvetits nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,293 @@+<p align="center">+<img src="./logo.png">+</p>++# effet++[](https://hackage.haskell.org/package/effet)++[plucking constraints]: https://www.parsonsmatt.org/2020/01/03/plucking_constraints.html++[Overview]: https://github.com/typedbyte/effet#overview+[Quick-Start Guide]: https://github.com/typedbyte/effet#quick-start-guide+[Defining Effects]: https://github.com/typedbyte/effet#defining-effects+[Using Effects]: https://github.com/typedbyte/effet#using-effects+[Defining Effect Handlers]: https://github.com/typedbyte/effet#defining-effect-handlers+[Using Effect Handlers]: https://github.com/typedbyte/effet#using-effect-handlers+[Tagging, Retagging, Untagging]: https://github.com/typedbyte/effet#tagging-retagging-untagging+[Limitations and Remarks]: https://github.com/typedbyte/effet#limitations-and-remarks++* [Overview][]+* [Quick-Start Guide][]+ * [Defining Effects][]+ * [Using Effects][]+ * [Defining Effect Handlers][]+ * [Using Effect Handlers][]+ * [Tagging, Retagging, Untagging][]+* [Limitations and Remarks][]++## Overview++`effet` is an effect system based on type classes, written in Haskell. A central idea of an effect system is to track effects (like performing a file system access) on the type level in order to describe the behavior of functions more precisely. Another central idea of an effect system is the well-known design principle of separating an interface (the *effect*) from its actual implementation (the *effect handler* or *effect interpreter*). Hence, `effet` allows developers to write programs by composing functions which describe their effects on the type level, and to provide different implementation strategies for those effects when running the programs.++`effet` is by far not the first library which pursues these ideas. It borrows various ideas from existing libraries, just to name a few:++* It is based on type classes, like `mtl` and `fused-effects`.+* It is based on [plucking constraints][], like `mtl`, but without the "n² instances problem".+* It supports `TemplateHaskell`-based generation of the effect infrastructure, like `polysemy`.+* It supports functional dependencies and tagged effects for effect disambiguation, like `ether`.++`effet` has a rather down-to-earth implementation without much magic. It is like a thin wrapper around the `transformers` library and its lifting friends `transformers-base` and `monad-control`, thus minimizing the reinvention of the wheel. The library and its documentation can be found on [Hackage](https://hackage.haskell.org/package/effet).++## Quick-Start Guide++### Defining Effects++When defining effects or effect handlers, the module *Control.Effect.Machinery* provides everything we need:++```haskell+import Control.Effect.Machinery+```++Effects are ordinary type classes, like the following:++```haskell+class Monad m => FileSystem' tag m where+ readFile' :: FilePath -> m String+ writeFile' :: FilePath -> String -> m ()+```++Note the `tag` type parameter. Such a parameter is used to disambiguate effects of the same type, i.e. we can use multiple `FileSystem` effects in our program simultaneously. In `effet`, the naming convention is to use an apostrophe as name suffix whenever we use tags. However, `effet` is not limited to that, we can easily define our effect without a `tag` parameter:++```haskell+class Monad m => FileSystem m where+ readFile :: FilePath -> m String+ writeFile :: FilePath -> String -> m ()+```++Let's go on with the tagged version for now and pretend that the untagged type class does not exist. The next step is to generate the effect handling, lifting and tagging infrastructure for our new effect using the `TemplateHaskell` language extension:++```haskell+makeTaggedEffect ''FileSystem'+```++This line generates the necessary infrastructure for combining our new effect with other effects. We also get the untagged version of the effect for free, i.e. the corresponding untagged definitions (`FileSystem`, `readFile`, `writeFile`, note the missing apostrophes) are generated for us. This line also generates functions which help us to tag (`tagFileSystem'`), retag+(`retagFileSystem'`) and untag (`untagFileSystem'`) our effect. More on that later.++`effet` also provides the function `makeTaggedEffectWith` to define our own naming convention if we don't like the apostrophes. For untagged effects, we would have simply used the function `makeEffect` instead.++### Using Effects++We can now use our effect to write programs that access the file system. We will define a simple program which appends something to a file. In order to make it more interesting, we will combine it with the pre-defined `Writer` effect to report the file size before and after appending, just to demonstrate the interplay with other effects:++```haskell+import Control.Effect.Writer+```++```haskell+program :: (FileSystem m, Writer [Int] m) => FilePath -> String -> m ()+program path txt = do+ content <- readFile path+ let size = length content+ tell [size]+ seq size $ writeFile path (content ++ txt)+ tell [size + length txt]+```++In order to run this program, we need a handler (or "interpreter") for our effect. There are several ways to interpret our effect. We could, for example, really access our local file system or just provide a virtual, in-memory file system. Hence, we will define two effect handlers for demonstration purposes.++### Defining Effect Handlers++First of all, we could – in theory – interpret effects without using `effet` at all, which is something that is not possible in many other effect systems. Since effects are ordinary type classes, we would just instantiate the monad type `m` with a type that provides instances for all (!) the effect type classes that constrain `m`. This is where the so-called "n² instances problem" of `mtl` comes from, since every effect handler that wants to handle a single effect (i.e., that wants to provide a type class instance for the effect it wants to handle) must also provide type class instances for all other effects – some of which might not even be known at compile-time – in order to delegate them to their corresponding effect handlers.++The advantage of `effet` is the ability to interpret effects separately, one by one, by [plucking constraints][] and not caring about all effects at the same time. In `effet`, we write an effect handler by defining a type and a corresponding type class instance for the effect we are interested in and let the infrastructure of `effet` handle the delegation of all other effects to their corresponding effect handlers.++An effect handler is a monad transformer which provides an instance for our effect type class. First, let's define the handler type for the local file system handler. We can derive all the necessary instances for proper effect lifting, some of them by using the `DerivingVia` language extension:++```haskell+newtype LocalFS m a =+ LocalFS { runLocalFS :: m a }+ deriving (Applicative, Functor, Monad, MonadIO)+ deriving (MonadTrans, MonadTransControl) via Default+ deriving (MonadBase b, MonadBaseControl b)+```++Next, we provide the instance for our `FileSystem'` effect. We need another import for that:++```haskell+import qualified System.IO as IO+```++```haskell+instance MonadIO m => FileSystem' tag (LocalFS m) where+ readFile' path = liftIO $ IO.readFile path+ writeFile' path txt = liftIO $ IO.writeFile path txt+```++Note that we do not need a separate instance for the untagged version of our effect which was generated before.++In order to make the usage of our instance more comfortable, we additionally provide two functions which instruct the type system to use our particular instance for handling the `FileSystem` effect when running a particular program. We write one tagged and one untagged version:++```haskell+runLocalFileSystem' :: (FileSystem' tag `Via` LocalFS) m a -> m a+runLocalFileSystem' = coerce++runLocalFileSystem :: (FileSystem `Via` LocalFS) m a -> m a+runLocalFileSystem = runLocalFileSystem' @G+```++Done! Now let's provide similar definitions for our virtual file system. Instead of `IO`, we will use the `Map` effect that is shipped with `effet` in order to map file paths to their corresponding contents. For simplification, we will assume that the contents of non-existing files are empty strings:++```haskell+newtype VirtualFS m a =+ VirtualFS { runVirtualFS :: m a }+ deriving (Applicative, Functor, Monad, MonadIO)+ deriving (MonadTrans, MonadTransControl) via Default+ deriving (MonadBase b, MonadBaseControl b)++instance Map' tag FilePath String m => FileSystem' tag (VirtualFS m) where+ readFile' path = VirtualFS $ fromMaybe "" <$> lookup' @tag path+ writeFile' path txt = VirtualFS $ insert' @tag path txt++runVirtualFileSystem' :: (FileSystem' tag `Via` VirtualFS) m a -> m a+runVirtualFileSystem' = coerce++runVirtualFileSystem :: (FileSystem `Via` VirtualFS) m a -> m a+runVirtualFileSystem = runVirtualFileSystem' @G+```++As we can see above, there is some boilerplate involved when defining effect handlers, like the two `run`-functions which look almost identically. There is certainly potential to generate more code to mitigate this in the future.++### Using Effect Handlers++Now we have all our puzzle pieces together in order to run our program with different effect handlers. Let's recap the type of our program:++```haskell+program :: (FileSystem m, Writer [Int] m) => FilePath -> String -> m ()+```++Let's see what happens if we use our `runVirtualFileSystem` function on that program after we feed it some file path and the content that should be appended to the file:++```haskell+test :: (Map FilePath String m, Writer [Int] m) => m ()+test = runVirtualFileSystem $ program "/tmp/test.txt" "hello"+```++What happened? We handled the `FileSystem` effect using our virtual file system handler (i.e., we "plucked the constraint"), which gives us a new program as result that still needs its `Map` and `Writer` effects handled. We essentially reinterpreted one effect (`FileSystem`) in terms of another (`Map`) without touching all the other effects (`Writer`). In order to run the remaining two effects, we just need to import some of the pre-defined effect handlers for the `Map` and `Writer` effects:++```haskell+import Control.Effect.Map.Lazy+import Control.Effect.Writer.Lazy+```++And here is the complete code for running our program either locally or virtually:++```haskell+runLocalProgram :: MonadIO m => m ([Int], ())+runLocalProgram+ = runWriter+ . runLocalFileSystem+ $ program "/tmp/test.txt" "hello"++runVirtualProgram :: Monad m => m ([Int], ())+runVirtualProgram+ = runWriter+ . runMap+ . runVirtualFileSystem+ $ program "/tmp/test.txt" "hello"+```++As we can see by the types, no `IO` is involved in the virtual program, since we do not touch the actual file system.++We decided to handle our `Map` and `Writer` effects using their lazy implementations. We could, for example, easily switch the handlers to their strict counterparts, or even use some other Map-like implementation for our `Map` effect, like Redis.++### Tagging, Retagging, Untagging++If we write a program with multiple `FileSystem'` effects, we can disambiguate them using the tags ...++```haskell+fsProgram :: (FileSystem' "fs1" m, FileSystem' "fs2" m) => m ()+fsProgram = do+ writeFile' @"fs1" "/tmp/test.txt" "first content"+ writeFile' @"fs2" "/tmp/test.txt" "second content"+```++... and interpret them differently, one using the local and one using the virtual file system, for example:++```haskell+runDifferently :: MonadIO m => m ()+runDifferently+ = runMap' @"fs1"+ . runVirtualFileSystem' @"fs1"+ . runLocalFileSystem' @"fs2"+ $ fsProgram+```++We could also use one tagged (`FileSystem'`) and one untagged (`FileSystem`) effect to disambiguate them, of course.++We can also change the tags of our effects before interpretation using the generated `tagFileSystem'`, `retagFileSystem'` and `untagFileSystem'` functions. We could, for example, merge the two effects into a single tag and interpret them uniformly:++```haskell+runUniformly :: Monad m => m ()+runUniformly+ = runMap' @"fs1"+ . runVirtualFileSystem' @"fs1"+ . retagFileSystem' @"fs2" @"fs1"+ $ fsProgram+```++In the example above, we merge tag `fs2` into tag `fs1` and interpret them together using the virtual file system. We can achieve the same result by untagging both effects and then using the untagged versions of the interpretation functions:++```haskell+runUntagged :: Monad m => m ()+runUntagged+ = runMap+ . runVirtualFileSystem+ . untagFileSystem' @"fs2"+ . untagFileSystem' @"fs1"+ $ fsProgram+```++Tagging, retagging and untagging are useful if we want to compose two functions which have the same effects, but we want to interpret them differently after composition. Note that there is a chance that two authors write two different libraries using the same effects, but do not know from each other ...++```haskell+-- somewhere in library A+functionA :: FileSystem m => m ()+functionA = ...+```++```haskell+-- somewhere in library B+functionB :: FileSystem m => m ()+functionB = ...+```++... and we want to compose these functions, but interpret the effects differently after composition:++```haskell+-- oops, the effects were merged!+ourProgram :: FileSystem m => m ()+ourProgram = functionA >> functionB+```++We then need to introduce a tag for at least one of the two functions ...++```haskell+-- now the effects are separated+ourProgram :: (FileSystem m, FileSystem' "b" m) => m ()+ourProgram = functionA >> tagFileSystem' @"b" functionB+```++... which again allows us to interpret the effects independently as described above.++## Limitations and Remarks++* A handler can handle exactly one effect. This restriction might be lifted in the future.+* `TemplateHaskell`-based code generation can yield code that does not compile if you go crazy with `m`-based parameters in higher-order effect methods (where `m` is the monad type parameter of the effect type class). In such cases, one has to write the necessary type class instances by hand.+* It is not possible to define an effect type class based on other effect type classes, like `mtl` does with `RWS` (not to be confused with writing an effect *handler* based on other effects, which is possible). This restriction might be lifted in the future if a handler can handle multiple effects (see the first point). In other words, effect definitions like the following are currently not possible, at least not in combination with the provided code generation infrastructure:+ ```haskell+ class (Reader r m, Writer w m, State s m) => RWS r w s m where+ ...+ ```+* The performance should be `mtl`-like, but this has not been verified yet.+* The library needs some tests.
+ effet.cabal view
@@ -0,0 +1,68 @@+cabal-version: 1.12 ++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 5e1b55b6a5d186ec023537858ae4098ce19caa92be7cc2d07e60ea0630e75011++name: effet+version: 0.1.0.0+synopsis: An Effect System based on Type Classes+description: Please see the README on GitHub at <https://github.com/typedbyte/effet#readme>+category: Control+homepage: https://github.com/typedbyte/effet#readme+bug-reports: https://github.com/typedbyte/effet/issues+author: Michael Szvetits+maintainer: typedbyte@qualified.name+copyright: 2020 Michael Szvetits+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/typedbyte/effet++library+ exposed-modules:+ Control.Effect.Cont+ Control.Effect.Embed+ Control.Effect.Error+ Control.Effect.Machinery+ Control.Effect.Machinery.Default+ Control.Effect.Machinery.Kind+ Control.Effect.Machinery.Tagger+ Control.Effect.Machinery.TH+ Control.Effect.Machinery.Via+ Control.Effect.Map+ Control.Effect.Map.Lazy+ Control.Effect.Map.Strict+ Control.Effect.Reader+ Control.Effect.Resource+ Control.Effect.RWS+ Control.Effect.RWS.Lazy+ Control.Effect.RWS.Strict+ Control.Effect.State+ Control.Effect.State.Lazy+ Control.Effect.State.Strict+ Control.Effect.Writer+ Control.Effect.Writer.Lazy+ Control.Effect.Writer.Strict+ other-modules:+ Paths_effet+ hs-source-dirs:+ src+ default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators UndecidableInstances+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5+ , containers >=0.6.2.1 && <0.7+ , monad-control >=1.0.2.3 && <1.1+ , template-haskell >=2.15.0.0 && <2.16+ , transformers >=0.5.6.2 && <0.6+ , transformers-base >=0.4.5.2 && <0.5+ default-language: Haskell2010
+ src/Control/Effect/Cont.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Cont+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- The continuation effect, similar to the @MonadCont@ type class from the+-- @mtl@ library.+-----------------------------------------------------------------------------+module Control.Effect.Cont+ ( -- * Tagged Continuation Effect+ Cont'(..)+ -- * Untagged Continuation Effect+ -- | If you don't require disambiguation of multiple continuation effects+ -- (i.e., you only have one continuation effect in your monadic context),+ -- it is recommended to always use the untagged continuation effect.+ , Cont+ , callCC+ -- * Interpretations+ , runCont'+ , runCont+ , evalCont'+ , evalCont+ -- * Tagging and Untagging+ -- | Conversion functions between the tagged and untagged continuation effect,+ -- usually used in combination with type applications, like:+ --+ -- @+ -- 'tagCont'' \@\"newTag\" program+ -- 'retagCont'' \@\"oldTag\" \@\"newTag\" program+ -- 'untagCont'' \@\"erasedTag\" program+ -- @+ -- + , tagCont'+ , retagCont'+ , untagCont'+ ) where++-- transformers+import qualified Control.Monad.Trans.Cont as C++import Control.Effect.Machinery++-- | An effect that adds an abortive continuation to a computation.+class Monad m => Cont' tag m where+ -- | Adapted from the @mtl@ library documentation:+ --+ -- @callCC'@ (call-with-current-continuation) calls a function with the+ -- current continuation as its argument. Provides an escape continuation+ -- mechanism for use with continuation monads. Escape continuations allow to+ -- abort the current computation and return a value immediately. They achieve+ -- a similar result to 'Control.Effect.Error.throwError'' and+ -- 'Control.Effect.Error.catchError'' of the 'Control.Effect.Error.Error''+ -- effect. Advantage of this function over calling @return@ is that it makes+ -- the continuation explicit, allowing more flexibility and better control.+ --+ -- The standard idiom used with @callCC'@ is to provide a lambda-expression to+ -- name the continuation. Then calling the named continuation anywhere within+ -- its scope will escape from the computation, even if it is many layers deep+ -- within nested computations.+ callCC' :: ((a -> m b) -> m a) -> m a++makeHandler ''Cont'+makeTagger ''Cont'++instance {-# OVERLAPPABLE #-} Control (Cont' tag) t m => Cont' tag (Via eff t m) where+ callCC' f =+ liftWith+ ( \run -> callCC' @tag $ \c -> run . f $+ \a -> lift (run (pure a) >>= c)+ )+ >>= restoreT . pure+ {-# INLINEABLE callCC' #-}++instance Cont' tag (C.ContT r m) where+ callCC' = C.callCC+ {-# INLINE callCC' #-}++-- | Runs the continuation effect with a given final continuation.+runCont' :: forall tag r m a. (a -> m r) -> (Cont' tag `Via` C.ContT r) m a -> m r+runCont' f = flip C.runContT f . runVia+{-# INLINE runCont' #-}++-- | The untagged version of 'runCont''.+runCont :: (a -> m r) -> (Cont `Via` C.ContT r) m a -> m r+runCont = runCont' @G+{-# INLINE runCont #-}++-- | Runs the continuation effect with 'pure' as final continuation.+evalCont' :: forall tag r m. Applicative m => (Cont' tag `Via` C.ContT r) m r -> m r+evalCont' = runCont' pure+{-# INLINE evalCont' #-}++-- | The untagged version of 'evalCont''.+evalCont :: Applicative m => (Cont `Via` C.ContT r) m r -> m r+evalCont = evalCont' @G+{-# INLINE evalCont #-}
+ src/Control/Effect/Embed.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Embed+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- The embed effect for integrating arbitrary monads into the effect system.+-----------------------------------------------------------------------------+module Control.Effect.Embed+ ( -- * Embed Effect+ Embed(..)+ -- * Interpretations+ , Transformation+ , runEmbed+ ) where++-- transformers+import Control.Monad.Trans.Reader (ReaderT(ReaderT), runReaderT)++import Control.Effect.Machinery hiding (embed)++-- | An effect that integrates a monad @n@ into the computation @m@.+class Monad m => Embed n m where+ -- | Monadic actions in @n@ can be lifted into @m@ via 'embed'.+ --+ -- 'embed' is like 'liftIO', but not limited to 'IO'. In fact, 'liftIO' can+ -- be realized using 'embed' by specializing @n@ to @IO@.+ embed :: n a -> m a++makeEffect ''Embed++instance Monad m => Embed m m where+ embed = id+ {-# INLINE embed #-}++newtype F n t = F (forall b. n b -> t b)++-- | The transformation interpreter of the embed effect. This type implements the+-- 'Embed' type class by transforming the integrated monad @n@ into another+-- integrated monad @t@ via natural transformation.+--+-- When interpreting the effect, you usually don\'t interact with this type directly,+-- but instead use one of its corresponding interpretation functions.+newtype Transformation n t m a =+ Transformation { runTransformation :: ReaderT (F n t) m a }+ deriving (Applicative, Functor, Monad, MonadIO)+ deriving (MonadTrans, MonadTransControl)+ deriving (MonadBase b, MonadBaseControl b)++instance Embed t m => Embed n (Transformation n t m) where+ embed na = Transformation . ReaderT $+ \(F f) -> embed (f na)+ {-# INLINE embed #-}++-- | Runs the embed effect by transforming the integrated monad @n@ into another+-- integrated monad @t@.+runEmbed :: (forall b. n b -> t b) -- ^ The natural transformation from monad @n@ to monad @t@.+ -> (Embed n `Via` Transformation n t) m a -- ^ The program whose embed effect should be handled.+ -> m a -- ^ The program with its embed effect handled.+runEmbed f = flip runReaderT (F f) . runTransformation . runVia+{-# INLINE runEmbed #-}
+ src/Control/Effect/Error.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Error+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- The error effect, similar to the @MonadError@ type class from the+-- @mtl@ library.+-----------------------------------------------------------------------------+module Control.Effect.Error+ ( -- * Tagged Error Effect+ Error'(..)+ -- * Untagged Error Effect+ -- | If you don't require disambiguation of multiple error effects+ -- (i.e., you only have one error effect in your monadic context),+ -- it is recommended to always use the untagged error effect.+ , Error+ , throwError+ , catchError+ -- * Convenience Functions+ -- | If you don't require disambiguation of multiple error effects+ -- (i.e., you only have one error effect in your monadic context),+ -- it is recommended to always use the untagged functions.+ , liftEither'+ , liftEither+ -- * Interpretations+ , runError'+ , runError+ -- * Tagging and Untagging+ -- | Conversion functions between the tagged and untagged error effect,+ -- usually used in combination with type applications, like:+ --+ -- @+ -- 'tagError'' \@\"newTag\" program+ -- 'retagError'' \@\"oldTag\" \@\"newTag\" program+ -- 'untagError'' \@\"erasedTag\" program+ -- @+ -- + , tagError'+ , retagError'+ , untagError'+ ) where++-- base+import Data.Coerce (coerce)++-- transformers+import Control.Monad.Trans.Except (ExceptT(ExceptT), catchE, throwE)++import Control.Effect.Machinery (G, Tagger(Tagger), Via(Via), makeTaggedEffect)++-- | An effect that equips a computation with the ability to throw and catch+-- exceptions.+class Monad m => Error' tag e m | tag m -> e where+ -- | Throws an exception during the computation and begins exception+ -- processing.+ throwError' :: e -> m a+ -- | Catches an exception in order to handle it and return to normal execution.+ catchError' :: m a -> (e -> m a) -> m a++makeTaggedEffect ''Error'++instance Monad m => Error' tag e (ExceptT e m) where+ throwError' = throwE+ {-# INLINE throwError' #-}+ catchError' = catchE+ {-# INLINE catchError' #-}++-- | Lifts an @'Either' e@ into any @'Error'' e@.+liftEither' :: forall tag e m a. Error' tag e m => Either e a -> m a+liftEither' = either (throwError' @tag) pure+{-# INLINE liftEither' #-}++-- | The untagged version of 'liftEither''.+liftEither :: Error e m => Either e a -> m a+liftEither = liftEither' @G+{-# INLINE liftEither #-}++-- | Runs the error effect by wrapping exceptions in the 'Either' type.+runError' :: (Error' tag e `Via` ExceptT e) m a -> m (Either e a)+runError' = coerce+{-# INLINE runError' #-}++-- | The untagged version of 'runError''.+runError :: (Error e `Via` ExceptT e) m a -> m (Either e a)+runError = coerce+{-# INLINE runError #-}
+ src/Control/Effect/Machinery.hs view
@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Machinery+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- This module exports all the definitions needed to define effects and their+-- corresponding handlers. Usually, importing this module is everything you+-- need to get started.+-----------------------------------------------------------------------------+module Control.Effect.Machinery+ ( -- * Re-exports from @effet@+ module Control.Effect.Machinery.Default+ , module Control.Effect.Machinery.Kind+ , module Control.Effect.Machinery.Tagger+ , module Control.Effect.Machinery.TH+ , module Control.Effect.Machinery.Via+ -- * Re-exports from @base@+ , module Control.Monad.IO.Class+ -- * Re-exports from @monad-control@+ , module Control.Monad.Trans.Control+ -- * Re-exports from @transformers@+ , module Control.Monad.Trans.Class+ -- * Re-exports from @transformers-base@+ , module Control.Monad.Base+ ) where++-- base+import Control.Monad.IO.Class++-- monad-control+import Control.Monad.Trans.Control -- hiding (embed)++-- transformers+import Control.Monad.Trans.Class++-- transformers-base+import Control.Monad.Base++import Control.Effect.Machinery.Default+import Control.Effect.Machinery.Kind+import Control.Effect.Machinery.Tagger+import Control.Effect.Machinery.TH+import Control.Effect.Machinery.Via
+ src/Control/Effect/Machinery/Default.hs view
@@ -0,0 +1,54 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Machinery.Default+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- This module provides default implementations for the 'MonadTrans' and+-- 'MonadTransControl' type classes.+-----------------------------------------------------------------------------+module Control.Effect.Machinery.Default (Default(..)) where++-- base+import Control.Monad.IO.Class (MonadIO)++-- monad-control+import Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl, StT,+ liftWith, restoreT)++-- transformers+import Control.Monad.Trans.Class (MonadTrans, lift)++-- transformers-base+import Control.Monad.Base (MonadBase)++-- | This type provides default implementations for the 'MonadTrans' and+-- 'MonadTransControl' type classes. The type is intended to be targeted by the+-- @DerivingVia@ language extension when writing an effect handler newtype that+-- wraps a monad @m a@ :+--+-- @+-- newtype MyHandler m a =+-- MyHandler { runMyHandler :: m a }+-- deriving (Applicative, Functor, Monad, MonadIO)+-- deriving (MonadTrans, MonadTransControl) via 'Default'+-- deriving (MonadBase b, MonadBaseControl b)+-- @+newtype Default m a =+ Default { runDefault :: m a }+ deriving (Applicative, Functor, Monad, MonadIO)+ deriving (MonadBase b, MonadBaseControl b)++instance MonadTrans Default where+ lift = Default+ {-# INLINE lift #-}++instance MonadTransControl Default where+ type StT Default a = a+ liftWith f = Default (f runDefault)+ {-# INLINE liftWith #-}+ restoreT = Default+ {-# INLINE restoreT #-}
+ src/Control/Effect/Machinery/Kind.hs view
@@ -0,0 +1,68 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Machinery.Kind+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- This module defines some constraint synonyms and kinds that are used+-- throughout this library, hopefully to increase the readability of the code+-- at some points.+-----------------------------------------------------------------------------+module Control.Effect.Machinery.Kind where++-- base+import Data.Kind (Constraint, Type)++-- monad-control+import Control.Monad.Trans.Control (MonadTransControl)++-- transformers+import Control.Monad.Trans.Class (MonadTrans)++-- | The kind of monads.+type SomeMonad = Type -> Type++-- | The kind of effects, which are type classes with a monad type parameter at+-- the end.+type Effect = SomeMonad -> Constraint++-- | The kind of monad transformers, also known as effect handlers or effect+-- interpreters.+type Transformer = SomeMonad -> Type -> Type++-- | This type synonym indicates that an effect is handled by a specific monad+-- transformer.+type Handle (eff :: Effect) (t :: Transformer) m =+ eff (t m)++-- | This constraint synonym indicates that a first-order effect is not handled+-- by a specific monad transformer and must thus be delegated (\"lifted\")+-- further down the monad transformer stack in order to find its associated+-- handler.+--+-- Roughly speaking, a first-order effect is a type class whose monad type+-- parameter @m@ appears only in positive position when looking at the types of+-- its corresponding class methods (e.g., @m@ appears only in the result type).+--+-- An example of a first-order effect is the 'Control.Effect.State.State'' effect.+type Lift (eff :: Effect) (t :: Transformer) m =+ (eff m, Monad (t m), MonadTrans t)++-- | This constraint synonym indicates that a higher-order effect is not handled+-- by a specific monad transformer and must thus be delegated (\"lifted\")+-- further down the monad transformer stack in order to find its associated+-- handler.+--+-- Roughly speaking, a higher-order effect is a type class whose monad type+-- parameter @m@ appears in negative position when looking at the types of its+-- corresponding class methods (e.g., @m@ appears in the type of a method+-- parameter).+--+-- An example of a higher-order effect is the 'Control.Effect.Reader.Reader'' effect,+-- since its class method 'Control.Effect.Reader.local'' has a parameter of+-- type @m a@.+type Control (eff :: Effect) (t :: Transformer) m =+ (eff m, Monad (t m), MonadTransControl t)
+ src/Control/Effect/Machinery/TH.hs view
@@ -0,0 +1,613 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Machinery.TH+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- This module provides @TemplateHaskell@ functions to generate the handling,+-- lifting and tagging infrastructure for effect type classes.+-----------------------------------------------------------------------------+module Control.Effect.Machinery.TH+ ( -- * Common Generators+ makeEffect+ , makeHandler+ , makeLifter+ -- * Tag-based Generators+ , makeTaggedEffect+ , makeTaggedEffectWith+ , makeTagger+ , makeTaggerWith+ -- * Naming Convention+ , removeApostrophe+ ) where++-- base+import Control.Monad (forM, replicateM)+import Data.List (isSuffixOf)+import Data.Maybe (maybeToList)++-- monad-control+import Control.Monad.Trans.Control (liftWith, restoreT)++-- template-haskell+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax hiding (Lift, lift)++-- transformers+import Control.Monad.Trans.Class (lift)++import Control.Effect.Machinery.Kind (Control, Handle, Lift)+import Control.Effect.Machinery.Tagger (Tagger, runTagger)+import Control.Effect.Machinery.Via (G, Via(Via), runVia)++data ClassInfo = ClassInfo+ { clsCxt :: Cxt+ , clsName :: Name+ , clsTyVars :: [TyVarBndr]+ , _clsFunDeps :: [FunDep]+ , clsDecs :: [Dec]+ }++data EffectInfo = EffectInfo+ { _effCxt :: Cxt+ , effType :: Q Type+ , effParams :: [TyVarBndr]+ , effMonad :: TyVarBndr+ , effName :: Name+ , effTrafoName :: Name+ , effSigs :: [Signature]+ }++data TaggedInfo = TaggedInfo+ { tgTag :: TyVarBndr+ , tgParams :: [TyVarBndr]+ , tgMonad :: TyVarBndr+ , tgEffName :: Name+ , tgNameMap :: String -> Q String+ , tgSigs :: [Signature]+ }++data Signature = Signature+ { sigName :: Name+ , sigType :: Type+ }++synonymName :: TaggedInfo -> Q Name+synonymName info = mapName (tgNameMap info) (tgEffName info)++resultType :: Name -> Type -> Q Type+resultType m typ =+ case typ of+ VarT n `AppT` a | n == m -> pure a+ ArrowT `AppT` _ `AppT` r -> resultType m r+ ForallT _ _ t -> resultType m t+ SigT t _ -> resultType m t+ ParensT t -> resultType m t+ other -> fail+ $ "Expected a return type of the form 'm a', but encountered: "+ ++ show other++restorables :: Bool -> Name -> Type -> [Type]+restorables neg m typ =+ case typ of+ VarT n `AppT` a | n == m && neg -> [a]+ ArrowT `AppT` a `AppT` r -> restorables (not neg) m a ++ restorables neg m r+ ForallT _ _ t -> restorables neg m t+ SigT t _ -> restorables neg m t+ ParensT t -> restorables neg m t+ other -> fail+ $ "Encountered an unknown term when finding restorables: "+ ++ show other++isHigherType :: TyVarBndr -> Type -> Bool+isHigherType monad = go False+ where+ m = tyVarName monad+ go negPos typ =+ case typ of+ VarT n `AppT` _ | n == m -> negPos+ ArrowT `AppT` a `AppT` r ->+ go (not negPos) a || go negPos r+ ForallT _ _ t ->+ go negPos t+ _ ->+ False++isHigherOrder :: TyVarBndr -> Signature -> Bool+isHigherOrder monad = isHigherType monad . sigType++signature :: Dec -> Q Signature+signature dec =+ case dec of+ SigD name typ ->+ pure (Signature name typ)+ other ->+ fail+ $ "The generation of the effect handling machinery currently supports"+ ++ " only signatures, but encountered: "+ ++ show other++unkindTyVar :: TyVarBndr -> TyVarBndr+unkindTyVar (KindedTV n _) = PlainTV n+unkindTyVar unkinded = unkinded++tyVarName :: TyVarBndr -> Name+tyVarName (PlainTV n ) = n+tyVarName (KindedTV n _) = n++tyVarType :: TyVarBndr -> Q Type+tyVarType (PlainTV n ) = varT n+tyVarType (KindedTV n k) = sigT (varT n) k++effectVars :: ClassInfo -> Q ([TyVarBndr], TyVarBndr)+effectVars info =+ case clsTyVars info of+ [] -> fail+ $ "The specified effect type class `"+ ++ nameBase (clsName info)+ ++ "' has no monad type variable. "+ ++ "It is expected to be the last type variable."+ vs ->+ pure+ (init vs, last vs)++effectInfo :: ClassInfo -> Q EffectInfo+effectInfo info = do+ (params, clsM) <- effectVars info+ t <- newName "t"+ sigs <- mapM signature (clsDecs info)+ pure $+ EffectInfo+ ( clsCxt info )+ ( foldl appT (conT $ clsName info) (fmap tyVarType params) )+ ( params )+ ( clsM )+ ( clsName info )+ ( t )+ ( sigs )++extractTag :: [TyVarBndr] -> Q (TyVarBndr, [TyVarBndr])+extractTag [] = fail "The effect has no tag parameter."+extractTag (v:vs) = pure (v, vs)++-- | Extracts the untagged name from a name which is expected to end with \"\'\".+-- In other words, this function removes the suffix \"\'\" from a given name,+-- or fails otherwise.+removeApostrophe :: String -> Q String+removeApostrophe name =+ if "'" `isSuffixOf` name then+ pure $ init name+ else+ fail $ "Tagged effect and function names are expected to end with \"'\"."++mapName :: (String -> Q String) -> Name -> Q Name+mapName f = fmap mkName . f . nameBase++taggedInfo :: (String -> Q String) -> EffectInfo -> Q TaggedInfo+taggedInfo f info = do+ (tag, params) <- extractTag (effParams info)+ pure $+ TaggedInfo+ ( tag )+ ( params )+ ( effMonad info )+ ( effName info )+ ( f )+ ( effSigs info )++classInfo :: Name -> Q ClassInfo+classInfo className = do+ info <- reify className+ case info of+ ClassI (ClassD context name tyVars funDeps decs) _ ->+ pure (ClassInfo context name tyVars funDeps decs)+ other ->+ fail+ $ "The specified name `"+ ++ nameBase className+ ++ "' is not a type class, but the following instead: "+ ++ show other++instanceCxt :: Name -> EffectInfo -> Q Cxt+instanceCxt name info = cxt+ [+ conT name+ `appT` effType info+ `appT` varT (effTrafoName info)+ `appT` tyVarType (effMonad info)+ ]++instanceHead :: Q Type -> EffectInfo -> Q Type+instanceHead eff info =+ effType info+ `appT` (+ conT ''Via+ `appT` eff+ `appT` varT (effTrafoName info)+ `appT` tyVarType (effMonad info)+ )++-- | Generates the effect handling and lifting infrastructure for an effect which+-- does not have a tag type parameter. Requires the @TemplateHaskell@ language+-- extension.+--+-- Consider the following effect type class:+--+-- @+-- class 'Monad' m => MyEffect a b c m where+-- ...+-- @+--+-- @makeEffect ''MyEffect@ then generates two instances for this effect type+-- class ('Lift' for first-order effects, 'Control' for higher-order effects):+--+-- @+-- instance 'Handle' (MyEffect a b c) t m => MyEffect a b c ('Via' (MyEffect a b c) t m) where+-- ...+--+-- instance {-\# OVERLAPPABLE \#-} 'Lift'/'Control' (MyEffect a b c) t m => MyEffect a b c ('Via' eff t m) where+-- ...+-- @+--+-- Without @TemplateHaskell@, you have to write these instances by hand. These+-- two instances can also be generated separately, see 'makeHandler' and 'makeLifter'.+makeEffect :: Name -> Q [Dec]+makeEffect className = do+ clsInfo <- classInfo className+ effInfo <- effectInfo clsInfo+ hInstance <- handler effInfo+ lInstance <- lifter effInfo+ pure [hInstance, lInstance]++-- | Similar to 'makeTaggedEffect', but only generates the tag-related definitions.+makeTagger :: Name -> Q [Dec]+makeTagger = makeTaggerWith removeApostrophe++-- | Similar to 'makeTaggedEffectWith', but only generates the tag-related definitions.+makeTaggerWith :: (String -> Q String) -> Name -> Q [Dec]+makeTaggerWith f className = do+ clsInfo <- classInfo className+ effInfo <- effectInfo clsInfo+ tagInfo <- taggedInfo f effInfo+ tagger tagInfo++-- | Generates the effect handling and lifting infrastructure for an effect which+-- has a tag type parameter. It is expected that the tag type parameter is the first+-- type parameter of the effect type class. It is also expected that the names of the+-- effect type class and its methods end with an apostrophe \"'\". If you want more+-- control over the naming convention, use 'makeTaggedEffectWith'.+--+-- In general, this function generates everything that 'makeEffect' does, but also some+-- additional things. Consider the following effect type class:+--+-- @+-- class 'Monad' m => MyEffect' tag a b c m where+-- methodA' :: a -> m ()+-- methodB' :: b -> m ()+-- methodC' :: c -> m ()+-- @+--+-- @'makeTaggedEffect' \'\'MyEffect'@ then generates the following additional things:+--+-- * A type synonym for the untagged version of @MyEffect'@ with the name @MyEffect@+-- (note the missing apostrophe).+-- * Untagged versions of the effect methods, namely @methodA@, @methodB@ and @methodC@+-- (note the missing apostrophes).+-- * An instance of @MyEffect'@ for the type 'Tagger' which does not handle the effect,+-- but simply tags, retags or untags the @MyEffect'@ constraint of a computation.+-- * Three functions @tagMyEffect'@, @retagMyEffect'@ and @untagMyEffect'@ which make+-- use of the 'Tagger' instance.+--+-- As a rule of thumb, whenever you see an apostrophe suffix in the name of a definition+-- somewhere in this library, it has something to do with tags. Most of the time you+-- will use such definitions in combination with the language extension @TypeApplications@,+-- like:+--+-- @+-- ... forall tag ... methodA' @tag ...+-- tagMyEffect' \@\"newTag\" program+-- retagMyEffect' \@\"oldTag\" \@\"newTag\" program+-- untagMyEffect' \@\"erasedTag\" program+-- @+--+-- All the tag-related definitions can also be generated separately (i.e., without the+-- instances generated by 'makeEffect'), see 'makeTagger' and 'makeTaggerWith'.+makeTaggedEffect :: Name -> Q [Dec]+makeTaggedEffect = makeTaggedEffectWith removeApostrophe++-- | Similar to 'makeTaggedEffect', but allows to define a naming convention function+-- for the names of the effect type class and its methods. This function is used to+-- transform the name of a tagged definition (i.e., the type class or its methods) into+-- its untagged counterpart.+--+-- The default naming convention is enforced by 'removeApostrophe', which simply+-- removes the apostrophe \"'\" at the end of a name.+makeTaggedEffectWith :: (String -> Q String) -> Name -> Q [Dec]+makeTaggedEffectWith f className = do+ clsInfo <- classInfo className+ effInfo <- effectInfo clsInfo+ tagInfo <- taggedInfo f effInfo+ hInstance <- handler effInfo+ lInstance <- lifter effInfo+ taggerDecs <- tagger tagInfo+ pure (hInstance : lInstance : taggerDecs)++-- | Similar to 'makeEffect', but only generates the effect type class instance+-- for handling an effect.+makeHandler :: Name -> Q [Dec]+makeHandler className = do+ clsInfo <- classInfo className+ effInfo <- effectInfo clsInfo+ hInstance <- handler effInfo+ pure [hInstance]++-- | Similar to 'makeEffect', but only generates the effect type class instance+-- for lifting an effect.+makeLifter :: Name -> Q [Dec]+makeLifter className = do+ clsInfo <- classInfo className+ effInfo <- effectInfo clsInfo+ lInstance <- lifter effInfo+ pure [lInstance]++tagger :: TaggedInfo -> Q [Dec]+tagger info = do+ taggerFuns <- taggerFunctions info+ untaggedSyn <- untaggedSynonym info+ untaggedFuns <- untaggedFunctions info+ taggerInst <- taggerInstance info+ pure+ $ untaggedSyn+ : taggerInst+ : taggerFuns+ ++ untaggedFuns++handler :: EffectInfo -> Q Dec+handler info = do+ funs <- handlerFunctions info+ instanceD+ ( instanceCxt ''Handle info )+ ( instanceHead (effType info) info )+ ( fmap pure funs )++lifter :: EffectInfo -> Q Dec+lifter info = do+ let+ monad = effMonad info+ context =+ if any (isHigherOrder monad) (effSigs info)+ then ''Control+ else ''Lift+ funs <- lifterFunctions info+ eff <- newName "eff"+ instanceWithOverlapD+ ( Just Overlappable )+ ( instanceCxt context info )+ ( instanceHead (varT eff) info )+ ( fmap pure funs )++taggerFunctions :: TaggedInfo -> Q [Dec]+taggerFunctions info = do+ let params = tgParams info+ tagVar = tgTag info+ effectName = tgEffName info+ nameString = nameBase effectName+ tagFName = mkName ("tag" ++ nameString)+ retagFName = mkName ("retag" ++ nameString)+ untagFName = mkName ("untag" ++ nameString)+ tag <- newName (nameBase $ tyVarName tagVar)+ new <- newName "new"+ tagF <- taggerFunction effectName tagFName Nothing (Just new) params+ retagF <- taggerFunction effectName retagFName (Just tag) (Just new) params+ untagF <- taggerFunction effectName untagFName (Just tag) Nothing params+ pure $+ tagF ++ retagF ++ untagF++taggerFunction :: Name -> Name -> Maybe Name -> Maybe Name -> [TyVarBndr] -> Q [Dec]+taggerFunction baseName funName tag new params = do+ mName <- newName "m"+ aName <- newName "a"+ let m = varT mName+ a = varT aName+ tagParam = maybe [t| G |] varT tag+ newParam = maybe [t| G |] varT new+ tagNames = maybeToList tag ++ maybeToList new+ paramNames = fmap tyVarName params+ paramTypes = fmap (tyVarType . unkindTyVar) params+ forallNames = tagNames ++ paramNames ++ [mName, aName]+ forallTypes = fmap PlainTV forallNames+ effectType = foldl appT (conT baseName) (tagParam : paramTypes)+ funSigType <- [t| ($effectType `Via` Tagger $tagParam $newParam) $m $a -> $m $a |]+ funSig <- sigD funName $ forallT forallTypes (cxt []) (pure funSigType)+ funDef <- [d| $(varP funName) = runTagger . runVia |]+ funInline <- pragInlD funName Inline FunLike AllPhases+ pure (funSig : funInline : funDef)++untaggedSynonym :: TaggedInfo -> Q Dec+untaggedSynonym info = do+ synName <- synonymName info+ tySynD+ ( synName )+ ( params )+ ( foldl appT (conT effectName) (conT ''G : fmap tyVarType params) )+ where+ effectName = tgEffName info+ params = fmap unkindTyVar (tgParams info)++untaggedFunctions :: TaggedInfo -> Q [Dec]+untaggedFunctions info = do+ synName <- synonymName info+ fmap concat $+ forM (tgSigs info)+ $ untaggedFunction (tgNameMap info)+ $ foldl+ ( appT )+ ( conT synName )+ ( fmap (tyVarType . unkindTyVar) $ tgParams info ++ [tgMonad info] )++untaggedFunction :: (String -> Q String) -> Q Type -> Signature -> Q [Dec]+untaggedFunction f effectType sig = do+ let originalName = sigName sig+ signatureBody = pure (unkindType $ sigType sig)+ funName <- mapName f originalName+ funSig <- sigD funName [t| $effectType => $signatureBody |]+ funDef <- [d| $(varP funName) = $(varE originalName) @G |]+ funInline <- pragInlD funName Inline FunLike AllPhases+ pure (funSig : funInline : funDef)++taggerInstance :: TaggedInfo -> Q Dec+taggerInstance info = do+ newTagName <- newName "new"+ let new = varT newTagName+ monadName = tyVarName (tgMonad info)+ m = varT monadName+ tag = tyVarType (tgTag info)+ effectType = conT $ tgEffName info+ paramTypes = fmap tyVarType (tgParams info)+ taggerType = [t| Tagger $tag $new $m |]+ cxtParams = new : paramTypes ++ [m]+ headParams = tag : paramTypes ++ [taggerType]+ funs <-+ fmap concat $+ forM (tgSigs info) $ taggerInstanceFunction new monadName+ instanceD+ ( cxt [foldl appT effectType cxtParams] )+ ( foldl appT effectType headParams )+ ( fmap pure funs )++taggerInstanceFunction :: Q Type -> Name -> Signature -> Q [Dec]+taggerInstanceFunction new monad sig = do+ let typ = sigType sig+ funName = sigName sig+ expr = derive [] [| Tagger |] [| runTagger |] monad typ+ typeAppliedName = varE funName `appTypeE` new+ funDef <- [d| $(varP funName) = $expr $typeAppliedName |]+ funInline <- pragInlD funName Inline FunLike AllPhases+ pure (funInline : funDef)++paramCount :: Type -> Int+paramCount typ =+ case typ of+ ArrowT `AppT` _ `AppT` r -> 1 + paramCount r+ ForallT _ _ t -> paramCount t+ _ -> 0++invalid :: Q Exp+invalid = fail+ $ "Could not generate effect instance because the operation is "+ ++ "invalid for higher-order effects."++handlerFunctions :: EffectInfo -> Q [Dec]+handlerFunctions info =+ fmap concat $+ mapM+ ( function [| Via |] [| runVia |] (effMonad info) (effParams info) )+ ( effSigs info )++lifterFunctions :: EffectInfo -> Q [Dec]+lifterFunctions info =+ let m = effMonad info+ params = effParams info+ in+ fmap concat $+ forM (effSigs info) $ \sig ->+ if isHigherOrder m sig+ then higherFunction m params sig+ else function [| lift |] invalid m params sig++function :: Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]+function f inv monad params sig = do+ let m = tyVarName monad+ funName = sigName sig+ paramTypes = fmap tyVarType params+ typeAppliedName = foldl appTypeE (varE funName) paramTypes+ expr = derive [] f inv m (sigType sig)+ funDef <- [d| $(varP funName) = $expr $typeAppliedName |]+ funInline <- pragInlD funName Inline FunLike AllPhases+ pure (funInline : funDef)++higherFunction :: TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]+higherFunction monad params sig = do+ let m = tyVarName monad+ typ = sigType sig+ funName = sigName sig+ paramTypes = fmap tyVarType params+ restores = restorables False m typ+ expr = derive restores [| id |] [| run . runVia |] m typ+ fParams <- replicateM (paramCount typ) (newName "x") + res <- resultType m typ+ let typeAppliedName = foldl appTypeE (varE funName) paramTypes+ appliedExp = foldl appE expr (typeAppliedName : fmap varE fParams)+ body =+ [| Via $+ (liftWith $ \ $([p|run|]) -> $appliedExp)+ >>= $(traverseExp res) (restoreT . pure)+ |]+ funDef <- funD funName [clause (fmap varP fParams) (normalB body) []]+ funInline <- pragInlD funName Inline FunLike AllPhases+ pure [funDef, funInline]++unkindType :: Type -> Type+unkindType typ =+ case typ of+ -- We could need the following line if we want to preserve foralls+ --ForallT vs ps t -> ForallT (fmap unkindTyVar vs) (fmap unkindType ps) (unkindType t)+ ForallT _ _ t -> unkindType t+ AppT l r -> AppT (unkindType l) (unkindType r)+ SigT t _ -> t+ InfixT l n r -> InfixT (unkindType l) n (unkindType r)+ UInfixT l n r -> UInfixT (unkindType l) n (unkindType r)+ ParensT t -> ParensT (unkindType t)+ other -> other++contains :: Name -> Type -> Bool+contains m typ =+ case typ of+ ForallT _ _ t -> contains m t+ AppT l r -> contains m l || contains m r+ SigT t _ -> contains m t+ VarT n -> n == m+ ConT n -> n == m+ PromotedT n -> n == m+ InfixT l n r -> n == m || contains m l || contains m r+ UInfixT l n r -> n == m || contains m l || contains m r+ ParensT t -> contains m t+ _ -> False++derive :: [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp+derive rs f inv m typ =+ -- TODO: This is missing some cases - see algorithm of DeriveFunctor.+ case typ of+ t | not (contains m t) ->+ [| id |]+ VarT n `AppT` _ | n == m ->+ f+ ArrowT `AppT` arg `AppT` res ->+ let rf = derive rs f inv m res+ af = derive rs inv f m arg+ in if elem arg rs+ then [| \x b -> $rf (((x =<<) . Via . restoreT . pure) b) |]+ else [| \x b -> $rf (x ($af b)) |]+ ForallT _ _ t ->+ derive rs f inv m t+ other -> fail+ $ "Could not generate effect instance because an unknown structure "+ ++ "was encountered: "+ ++ show other++traverseExp :: Type -> Q Exp+traverseExp typ =+ case typ of+ ForallT _ _ t -> traverseExp t+ AppT _ r -> traverseRec r+ SigT t _ -> traverseExp t+ InfixT _ _ r -> traverseRec r+ UInfixT _ _ r -> traverseRec r+ ParensT t -> traverseExp t+ _ -> [| id |]+ where+ traverseRec t = [| traverse . $(traverseExp t) |]
+ src/Control/Effect/Machinery/Tagger.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Machinery.Tagger+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- This module defines an effect handler which handles tagging, retagging and+-- untagging of effects.+-----------------------------------------------------------------------------+module Control.Effect.Machinery.Tagger where++-- base+import Control.Monad.IO.Class (MonadIO)++-- monad-control+import Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl)++-- transformers+import Control.Monad.Trans.Class (MonadTrans)++-- transformers-base+import Control.Monad.Base (MonadBase)++import Control.Effect.Machinery.Default (Default(Default))++-- | This type provides instances for effect type classes in order to enable+-- tagging, retagging and untagging of effects. Whenever this type is used as+-- handler of an effect, the effect previously tagged with @tag@ will be+-- tagged with @new@ instead.+--+-- You usually don\'t interact with this type directly, since the type class+-- instances for this type are generated by the functions found in the module+-- "Control.Effect.Machinery.TH".+newtype Tagger tag new m a =+ Tagger { runTagger :: m a }+ deriving (Applicative, Functor, Monad, MonadIO)+ deriving (MonadTrans, MonadTransControl) via Default+ deriving (MonadBase b, MonadBaseControl b)
+ src/Control/Effect/Machinery/Via.hs view
@@ -0,0 +1,68 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Machinery.Via+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- This module defines the type 'Via' which indicates that a specific effect+-- is handled by a specific monad transformer (also known as effect handler+-- or effect interpreter).+--+-- It also defines the 'G' type, which is the global tag that is used for+-- untagged effects.+-----------------------------------------------------------------------------+module Control.Effect.Machinery.Via+ ( Via(..)+ , G+ ) where++-- base+import Control.Monad.IO.Class (MonadIO)++-- monad-control+import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl,+ MonadTransControl, StM, defaultLiftBaseWith,+ defaultRestoreM,liftBaseWith, restoreM)++-- transformers+import Control.Monad.Trans.Class (MonadTrans)++-- transformers-base+import Control.Monad.Base (MonadBase, liftBase, liftBaseDefault)++import Control.Effect.Machinery.Kind (Effect, Transformer)++-- | This type indicates that an effect (i.e., a type class) @eff@ is handled by+-- a specific monad transformer @t@. The type is a simple wrapper around the+-- monad transformer itself. The whole purpose of this type is to guide the type+-- system to pick the instance of type class @eff@ given by the type @t@, and+-- to delegate all other effects that are not @eff@ to their handlers which are+-- located somewhere further down the monad transformer stack.+newtype Via (eff :: Effect) (t :: Transformer) m a =+ Via { runVia :: t m a }+ deriving (Applicative, Functor, Monad, MonadIO)+ deriving (MonadTrans, MonadTransControl)++instance (Monad (t m), MonadBase b m, MonadTrans t) => MonadBase b (Via eff t m) where+ liftBase = liftBaseDefault+ {-# INLINE liftBase #-}++instance (Monad (t m), MonadBaseControl b m, MonadTransControl t) => MonadBaseControl b (Via eff t m) where+ type StM (Via eff t m) a = ComposeSt t m a+ liftBaseWith = defaultLiftBaseWith+ {-# INLINE liftBaseWith #-}+ restoreM = defaultRestoreM+ {-# INLINE restoreM #-}++-- | This type is used as tag for all untagged effects. In order words, every+-- effect is tagged, even untagged ones, but all the untagged ones simply have+-- the same tag @G@ (short for \"Global\", because you can view tags as some+-- kind of namespace mechanism, and all untagged effects live in the same+-- global namespace).+--+-- If you don\'t want to use tagged effects (i.e., you write effect type classes+-- without a tag type parameter), you can ignore this type completely.+data G
+ src/Control/Effect/Map.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Map+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- The map effect for modeling a mutable collection of key-value pairs.+--+-- Lazy and strict interpretations of the effect are available here:+-- "Control.Effect.Map.Lazy" and "Control.Effect.Map.Strict".+-----------------------------------------------------------------------------+module Control.Effect.Map+ ( -- * Tagged Map Effect+ Map'(..)+ -- * Untagged Map Effect+ -- | If you don't require disambiguation of multiple map effects+ -- (i.e., you only have one map effect in your monadic context),+ -- it is recommended to always use the untagged map effect.+ , Map+ , clear+ , lookup+ , update+ -- * Convenience Functions+ -- | If you don't require disambiguation of multiple map effects+ -- (i.e., you only have one map effect in your monadic context),+ -- it is recommended to always use the untagged functions.+ , delete'+ , delete+ , exists'+ , exists+ , insert'+ , insert+ , modify'+ , modify+ -- * Tagging and Untagging+ -- | Conversion functions between the tagged and untagged map effect,+ -- usually used in combination with type applications, like:+ --+ -- @+ -- 'tagMap'' \@\"newTag\" program+ -- 'retagMap'' \@\"oldTag\" \@\"newTag\" program+ -- 'untagMap'' \@\"erasedTag\" program+ -- @+ -- + , tagMap'+ , retagMap'+ , untagMap'+ ) where++-- base+import Data.Maybe (isJust)+import Prelude hiding (lookup)++import Control.Effect.Machinery (G, Tagger(Tagger), makeTaggedEffect)++-- | An effect that adds a mutable collection of key-value pairs to a given computation.+class Monad m => Map' tag k v m | tag m -> k v where+ -- | Deletes all key-value pairs from the map.+ clear' :: m ()+ -- | Searches for a value that corresponds to a given key.+ -- Returns 'Nothing' if the key cannot be found.+ lookup' :: k -> m (Maybe v)+ -- | Updates the value that corresponds to a given key.+ -- Passing 'Nothing' as the updated value removes the key-value pair from the map.+ update' :: k -> Maybe v -> m ()++makeTaggedEffect ''Map'++-- | Deletes a key and its corresponding value from the map.+delete' :: forall tag k v m. Map' tag k v m => k -> m ()+delete' k = update' @tag k Nothing+{-# INLINE delete' #-}++-- | The untagged version of 'delete''.+delete :: Map k v m => k -> m ()+delete = delete' @G+{-# INLINE delete #-}++-- | Checks if the map contains a given key.+exists' :: forall tag k v m. Map' tag k v m => k -> m Bool+exists' = fmap isJust . lookup' @tag+{-# INLINE exists' #-}++-- | The untagged version of 'exists''.+exists :: Map k v m => k -> m Bool+exists = exists' @G+{-# INLINE exists #-}++-- | Inserts a new key-value pair into the map. If the key is already present+-- in the map, the associated value is replaced with the new value.+insert' :: forall tag k v m. Map' tag k v m => k -> v -> m ()+insert' k = update' @tag k . Just+{-# INLINE insert' #-}++-- | The untagged version of 'insert''.+insert :: Map k v m => k -> v -> m ()+insert = insert' @G+{-# INLINE insert #-}++-- | Updates the value that corresponds to a given key.+-- If the key cannot be found, a corresponding default value is assumed.+modify' :: forall tag k v m. Map' tag k v m+ => v -- ^ The default value that is assumed if the key is missing.+ -> (v -> v) -- ^ The function for updating the value. This function is+ -- also applied to the default value if the key is missing.+ -> k -- ^ The key whose corresponding value is updated.+ -> m () -- ^ The operation produces no value.+modify' fallback f k = do+ maybeVal <- lookup' @tag k+ case maybeVal of+ Just v -> insert' @tag k (f v)+ Nothing -> insert' @tag k (f fallback)+{-# INLINE modify' #-}++-- | The untagged version of 'modify''.+modify :: Map k v m => v -> (v -> v) -> k -> m ()+modify = modify' @G+{-# INLINE modify #-}
+ src/Control/Effect/Map/Lazy.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Map.Lazy+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- Lazy interpretations of the 'Map'' effect.+--+-- If you don't require disambiguation of multiple map effects+-- (i.e., you only have one map effect in your monadic context),+-- you usually need the untagged interpretations.+-----------------------------------------------------------------------------+module Control.Effect.Map.Lazy+ ( -- * Interpreter Type+ LazyMap+ -- * Tagged Interpretations+ , runMap'+ -- * Untagged Interpretations+ , runMap+ ) where++-- containers+import qualified Data.Map.Lazy as M++-- transformers+import qualified Control.Monad.Trans.State.Lazy as S++import Control.Effect.Machinery+import Control.Effect.Map (Map, Map', clear', lookup', update')++-- | The lazy interpreter of the map effect. This type implements the+-- 'Map'' type class in a lazy manner.+--+-- When interpreting the effect, you usually don\'t interact with this type directly,+-- but instead use one of its corresponding interpretation functions.+newtype LazyMap k v m a =+ LazyMap { runLazyMap :: S.StateT (M.Map k v) m a }+ deriving (Applicative, Functor, Monad, MonadIO)+ deriving (MonadTrans, MonadTransControl)+ deriving (MonadBase b, MonadBaseControl b)++instance (Monad m, Ord k) => Map' tag k v (LazyMap k v m) where+ clear' = LazyMap $ S.put M.empty+ {-# INLINE clear' #-}+ lookup' = LazyMap . S.gets . M.lookup+ {-# INLINE lookup' #-}+ update' k mv = LazyMap $ S.modify (M.alter (const mv) k)+ {-# INLINE update' #-}++-- | Runs the map effect, initialized with an empty map.+runMap' :: forall tag k v m a. Monad m+ => (Map' tag k v `Via` LazyMap k v) m a -- ^ The program whose map effect should be handled.+ -> m a -- ^ The program with its map effect handled.+runMap' = flip S.evalStateT M.empty . runLazyMap . runVia+{-# INLINE runMap' #-}++-- | The untagged version of 'runMap''.+runMap :: Monad m => (Map k v `Via` LazyMap k v) m a -> m a+runMap = runMap' @G+{-# INLINE runMap #-}
+ src/Control/Effect/Map/Strict.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Map.Strict+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- Strict interpretations of the 'Map'' effect.+--+-- If you don't require disambiguation of multiple map effects+-- (i.e., you only have one map effect in your monadic context),+-- you usually need the untagged interpretations.+-----------------------------------------------------------------------------+module Control.Effect.Map.Strict+ ( -- * Interpreter Type+ StrictMap+ -- * Tagged Interpretations+ , runMap'+ -- * Untagged Interpretations+ , runMap+ ) where++-- containers+import qualified Data.Map.Strict as M++-- transformers+import qualified Control.Monad.Trans.State.Strict as S++import Control.Effect.Machinery+import Control.Effect.Map (Map, Map', clear', lookup', update')++-- | The strict interpreter of the map effect. This type implements the+-- 'Map'' type class in a strict manner.+--+-- When interpreting the effect, you usually don\'t interact with this type directly,+-- but instead use one of its corresponding interpretation functions.+newtype StrictMap k v m a =+ StrictMap { runStrictMap :: S.StateT (M.Map k v) m a }+ deriving (Applicative, Functor, Monad, MonadIO)+ deriving (MonadTrans, MonadTransControl)+ deriving (MonadBase b, MonadBaseControl b)++instance (Monad m, Ord k) => Map' tag k v (StrictMap k v m) where+ clear' = StrictMap $ S.put M.empty+ {-# INLINE clear' #-}+ lookup' = StrictMap . S.gets . M.lookup+ {-# INLINE lookup' #-}+ update' k mv = StrictMap $ S.modify (M.alter (const mv) k)+ {-# INLINE update' #-}++-- | Runs the map effect, initialized with an empty map.+runMap' :: forall tag k v m a. Monad m+ => (Map' tag k v `Via` StrictMap k v) m a -- ^ The program whose map effect should be handled.+ -> m a -- ^ The program with its map effect handled.+runMap' = flip S.evalStateT M.empty . runStrictMap . runVia+{-# INLINE runMap' #-}++-- | The untagged version of 'runMap''.+runMap :: Monad m => (Map k v `Via` StrictMap k v) m a -> m a+runMap = runMap' @G+{-# INLINE runMap #-}
+ src/Control/Effect/RWS.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.RWS+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- The effect that combines the reader, writer and state effect, similar to the+-- @MonadRWS@ type class from the @mtl@ library.+--+-- Lazy and strict interpretations of the effect are available here:+-- "Control.Effect.RWS.Lazy" and "Control.Effect.RWS.Strict".+-----------------------------------------------------------------------------+module Control.Effect.RWS+ ( -- * Tagged RWS Effect+ RWS'(..)+ -- * Untagged RWS Effect+ -- | If you don't require disambiguation of multiple RWS effects+ -- (i.e., you only have one RWS effect in your monadic context),+ -- it is recommended to always use the untagged RWS effect.+ , RWS+ , ask+ , local+ , tell+ , listen+ , censor+ , get+ , put+ -- * Convenience Functions+ -- ** Reader Convenience+ -- | If you don't require disambiguation of multiple RWS effects+ -- (i.e., you only have one RWS effect in your monadic context),+ -- it is recommended to always use the untagged functions.+ , asks'+ , asks+ -- ** Writer Convenience+ -- | If you don't require disambiguation of multiple RWS effects+ -- (i.e., you only have one RWS effect in your monadic context),+ -- it is recommended to always use the untagged functions.+ , listens'+ , listens+ -- ** State Convenience+ -- | If you don't require disambiguation of multiple RWS effects+ -- (i.e., you only have one RWS effect in your monadic context),+ -- it is recommended to always use the untagged functions.+ , gets'+ , gets+ , modify'+ , modify+ , modifyStrict'+ , modifyStrict+ -- * Interpretations+ , Separation(..)+ , runSeparatedRWS'+ , runSeparatedRWS+ -- * Tagging and Untagging+ -- | Conversion functions between the tagged and untagged RWS effect,+ -- usually used in combination with type applications, like:+ --+ -- @+ -- 'tagRWS'' \@\"newTag\" program+ -- 'retagRWS'' \@\"oldTag\" \@\"newTag\" program+ -- 'untagRWS'' \@\"erasedTag\" program+ -- @+ -- + , tagRWS'+ , retagRWS'+ , untagRWS'+ ) where++-- base+import Data.Coerce (coerce)+import Data.Tuple (swap)++-- transformers+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.CPS as Strict++import qualified Control.Effect.Reader as R+import qualified Control.Effect.State as S+import qualified Control.Effect.Writer as W++import Control.Effect.Machinery++-- | An effect that adds the following features to a given computation:+--+-- * (R) an immutable environment (the \"reader\" part)+-- * (W) a write-only, accumulated output (the \"writer\" part)+-- * (S) a mutable state (the \"state\" part)+class Monad m => RWS' tag r w s m | tag m -> r w s where+ -- | Gets the environment.+ ask' :: m r+ + -- | Executes a sub-computation in a modified environment.+ local' :: (r -> r) -- ^ The function to modify the environment.+ -> m a -- ^ The sub-computation to run in the modified environment.+ -> m a -- ^ The result of the sub-computation.++ -- | Produces the output @w@. In other words, @w@ is appended to the accumulated output.+ tell' :: w -> m ()+ + -- | Executes a sub-computation and appends @w@ to the accumulated output.+ listen' :: m a -> m (w, a)+ + -- | Executes a sub-computation and applies the function to its output.+ censor' :: (w -> w) -- ^ The function which is applied to the output.+ -> m a -- ^ The sub-computation which produces the modified output.+ -> m a -- ^ The result of the sub-computation.+ + -- | Gets the current state.+ get' :: m s+ + -- | Replaces the state with a new value.+ put' :: s -> m ()++makeTaggedEffect ''RWS'++instance (Monad m, Monoid w) => RWS' tag r w s (Lazy.RWST r w s m) where+ ask' = Lazy.ask+ {-# INLINE ask' #-}+ local' = Lazy.local+ {-# INLINE local' #-}+ tell' = Lazy.tell+ {-# INLINE tell' #-}+ listen' = fmap swap . Lazy.listen+ {-# INLINE listen' #-}+ censor' = Lazy.censor+ {-# INLINE censor' #-}+ get' = Lazy.get+ {-# INLINE get' #-}+ put' = Lazy.put+ {-# INLINE put' #-}++instance (Monad m, Monoid w) => RWS' tag r w s (Strict.RWST r w s m) where+ ask' = Strict.ask+ {-# INLINE ask' #-}+ local' = Strict.local+ {-# INLINE local' #-}+ tell' = Strict.tell+ {-# INLINE tell' #-}+ listen' = fmap swap . Strict.listen+ {-# INLINE listen' #-}+ censor' = Strict.censor+ {-# INLINE censor' #-}+ get' = Strict.get+ {-# INLINE get' #-}+ put' = Strict.put+ {-# INLINE put' #-}++-- | Gets a specific component of the environment, using the provided projection function.+asks' :: forall tag r w s m a. RWS' tag r w s m+ => (r -> a) -- ^ The projection function to apply to the environment.+ -> m a -- ^ The result of the projection.+asks' = flip fmap (ask' @tag)+{-# INLINE asks' #-}++-- | The untagged version of 'asks''.+asks :: RWS r w s m => (r -> a) -> m a+asks = asks' @G+{-# INLINE asks #-}++-- | Executes a sub-computation and applies the function to its output, thus adding+-- an additional value to the result of the sub-computation.+listens' :: forall tag r w s b m a. RWS' tag r w s m+ => (w -> b) -- ^ The function which is applied to the output.+ -> m a -- ^ The sub-computation which produces the modified output.+ -> m (b, a) -- ^ The result of the sub-computation, including the modified output.+listens' f action = do+ ~(w, a) <- listen' @tag action+ pure (f w, a)+{-# INLINE listens' #-}++-- | The untagged version of 'listens''.+listens :: RWS r w s m => (w -> b) -> m a -> m (b, a)+listens = listens' @G+{-# INLINE listens #-}++-- | Gets a specific component of the state, using the provided projection function.+gets' :: forall tag r w s m a. RWS' tag r w s m => (s -> a) -> m a+gets' f = fmap f (get' @tag)+{-# INLINE gets' #-}++-- | The untagged version of 'gets''.+gets :: RWS r w s m => (s -> a) -> m a+gets f = fmap f get+{-# INLINE gets #-}++-- | Modifies the state, using the provided function.+modify' :: forall tag r w s m. RWS' tag r w s m => (s -> s) -> m ()+modify' f = do+ s <- get' @tag+ put' @tag (f s)+{-# INLINE modify' #-}++-- | The untagged version of 'modify''.+modify :: RWS r w s m => (s -> s) -> m ()+modify = modify' @G+{-# INLINE modify #-}++-- | Modifies the state, using the provided function.+-- The computation is strict in the new state.+modifyStrict' :: forall tag r w s m. RWS' tag r w s m => (s -> s) -> m ()+modifyStrict' f = do+ s <- get' @tag+ put' @tag $! f s+{-# INLINE modifyStrict' #-}++-- | The untagged version of 'modifyStrict''.+modifyStrict :: RWS r w s m => (s -> s) -> m ()+modifyStrict = modifyStrict' @G+{-# INLINE modifyStrict #-}++-- | The separation interpreter of the RWS effect. This type implements the 'RWS''+-- type class by splitting the effect into separate 'R.Reader'', 'W.Writer'' and+-- 'S.State'' effects which can then be interpreted individually.+--+-- When interpreting the effect, you usually don\'t interact with this type directly,+-- but instead use one of its corresponding interpretation functions.+newtype Separation m a =+ Separation { runSeparation :: m a }+ deriving (Applicative, Functor, Monad, MonadIO)+ deriving (MonadTrans, MonadTransControl) via Default+ deriving (MonadBase b, MonadBaseControl b)++instance (R.Reader' tag r m, W.Writer' tag w m, S.State' tag s m) => RWS' tag r w s (Separation m) where+ ask' = Separation (R.ask' @tag)+ {-# INLINE ask' #-}+ local' f = Separation . R.local' @tag f . runSeparation+ {-# INLINE local' #-}+ tell' = Separation . W.tell' @tag+ {-# INLINE tell' #-}+ listen' = Separation . W.listen' @tag . runSeparation+ {-# INLINE listen' #-}+ censor' f = Separation . W.censor' @tag f . runSeparation+ {-# INLINE censor' #-}+ get' = Separation (S.get' @tag)+ {-# INLINE get' #-}+ put' = Separation . S.put' @tag+ {-# INLINE put' #-}++-- | Runs the RWS effect via separation.+runSeparatedRWS' :: (RWS' tag r w s `Via` Separation) m a -- ^ The program whose RWS effect should be handled.+ -> m a -- ^ The program with its RWS effect handled.+runSeparatedRWS' = coerce+{-# INLINE runSeparatedRWS' #-}++-- | The untagged version of 'runSeparatedRWS''.+runSeparatedRWS :: (RWS r w s `Via` Separation) m a -> m a+runSeparatedRWS = coerce+{-# INLINE runSeparatedRWS #-}
+ src/Control/Effect/RWS/Lazy.hs view
@@ -0,0 +1,82 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.RWS.Lazy+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- Lazy interpretations of the 'RWS'' effect.+--+-- If you don't require disambiguation of multiple RWS effects+-- (i.e., you only have one RWS effect in your monadic context),+-- you usually need the untagged interpretations.+-----------------------------------------------------------------------------+module Control.Effect.RWS.Lazy+ ( -- * Tagged Interpretations+ evalRWS'+ , execRWS'+ , runRWS'+ -- * Untagged Interpretations+ , evalRWS+ , execRWS+ , runRWS+ ) where++-- transformers+import Control.Monad.Trans.RWS.Lazy (RWST, runRWST)++import Control.Effect.Machinery (G, Via, runVia)+import Control.Effect.RWS (RWS, RWS')++-- | Runs the RWS effect and discards the final state.+evalRWS' :: forall tag r w s m a. Functor m+ => r -- ^ The initial environment.+ -> s -- ^ The initial state.+ -> (RWS' tag r w s `Via` RWST r w s) m a -- ^ The program whose RWS effect should be handled.+ -> m (w, a) -- ^ The program with its RWS effect handled, producing the final+ -- output @w@ and the result @a@.+evalRWS' r s = fmap reorder . (\m -> runRWST m r s) . runVia+ where+ reorder (a, _, w) = (w, a)+{-# INLINE evalRWS' #-}++-- | The untagged version of 'evalRWS''.+evalRWS :: Functor m => r -> s -> (RWS r w s `Via` RWST r w s) m a -> m (w, a)+evalRWS = evalRWS' @G+{-# INLINE evalRWS #-}++-- | Runs the RWS effect and discards the result of the interpreted program.+execRWS' :: forall tag r w s m a. Functor m+ => r -- ^ The initial environment.+ -> s -- ^ The initial state.+ -> (RWS' tag r w s `Via` RWST r w s) m a -- ^ The program whose RWS effect should be handled.+ -> m (w, s) -- ^ The program with its RWS effect handled, producing the final+ -- output @w@ and the final state @s@.+execRWS' r s = fmap reorder . (\m -> runRWST m r s) . runVia+ where+ reorder (_, s', w) = (w, s')+{-# INLINE execRWS' #-}++-- | The untagged version of 'execRWS''.+execRWS :: Functor m => r -> s -> (RWS r w s `Via` RWST r w s) m a -> m (w, s)+execRWS = execRWS' @G+{-# INLINE execRWS #-}++-- | Runs the RWS effect and returns the final output, the final state and the result of the interpreted program.+runRWS' :: forall tag r w s m a. Functor m+ => r -- ^ The initial environment.+ -> s -- ^ The initial state.+ -> (RWS' tag r w s `Via` RWST r w s) m a -- ^ The program whose RWS effect should be handled.+ -> m (w, s, a) -- ^ The program with its RWS effect handled, producing the final+ -- output @w@, the final state @s@ and the result @a@.+runRWS' r s = fmap reorder . (\m -> runRWST m r s) . runVia+ where+ reorder (a, s', w) = (w, s', a)+{-# INLINE runRWS' #-}++-- | The untagged version of 'runRWS''.+runRWS :: Functor m => r -> s -> (RWS r w s `Via` RWST r w s) m a -> m (w, s, a)+runRWS = runRWS' @G+{-# INLINE runRWS #-}
+ src/Control/Effect/RWS/Strict.hs view
@@ -0,0 +1,121 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.RWS.Strict+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- Strict interpretations of the 'RWS'' effect.+--+-- If you don't require disambiguation of multiple RWS effects+-- (i.e., you only have one RWS effect in your monadic context),+-- you usually need the untagged interpretations.+-----------------------------------------------------------------------------+module Control.Effect.RWS.Strict+ ( -- * Interpreter Type+ RWST+ -- * Tagged Interpretations+ , evalRWS'+ , execRWS'+ , runRWS'+ -- * Untagged Interpretations+ , evalRWS+ , execRWS+ , runRWS+ ) where++-- base+import Control.Monad (liftM)+import Data.Coerce (coerce)++-- transformers+import qualified Control.Monad.Trans.RWS.CPS as RWS++import Control.Effect.Machinery+import Control.Effect.RWS (RWS, RWS')++-- This is necessary until the writer CPS instances land in monad-control.+-- See: https://github.com/basvandijk/monad-control/pull/51+-- | The strict interpreter of the RWS effect. This type implements the+-- 'RWS'' type class in a strict manner.+--+-- When interpreting the effect, you usually don\'t interact with this type directly,+-- but instead use one of its corresponding interpretation functions.+newtype RWST r w s m a =+ RWST { runRWST :: RWS.RWST r w s m a }+ deriving (Applicative, Functor, Monad, MonadIO)+ deriving (MonadTrans)+ deriving (RWS' tag r w s)++instance MonadBase b m => MonadBase b (RWST r w s m) where+ liftBase = liftBaseDefault+ {-# INLINE liftBase #-}++instance (MonadBaseControl b m, Monoid w) => MonadBaseControl b (RWST r w s m) where+ type StM (RWST r w s m) a = ComposeSt (RWST r w s) m a+ liftBaseWith = defaultLiftBaseWith+ {-# INLINE liftBaseWith #-}+ restoreM = defaultRestoreM+ {-# INLINE restoreM #-}++instance Monoid w => MonadTransControl (RWST r w s) where+ type StT (RWST r w s) a = (a, s, w)+ liftWith f = RWST . RWS.rwsT $+ \r s -> liftM ( \x -> (x, s, mempty) )+ ( f $ \t -> (RWS.runRWST . runRWST) t r s )+ {-# INLINABLE liftWith #-}+ restoreT mSt = RWST . RWS.rwsT $ \_ _ -> mSt+ {-# INLINABLE restoreT #-}++-- | Runs the RWS effect and discards the final state.+evalRWS' :: forall tag r w s m a. (Functor m, Monoid w)+ => r -- ^ The initial environment.+ -> s -- ^ The initial state.+ -> (RWS' tag r w s `Via` RWST r w s) m a -- ^ The program whose RWS effect should be handled.+ -> m (w, a) -- ^ The program with its RWS effect handled, producing the final+ -- output @w@ and the result @a@.+evalRWS' r s = fmap reorder . (\m -> RWS.runRWST m r s) . coerce+ where+ reorder (a, _, w) = (w, a)+{-# INLINE evalRWS' #-}++-- | The untagged version of 'evalRWS''.+evalRWS :: (Functor m, Monoid w) => r -> s -> (RWS r w s `Via` RWST r w s) m a -> m (w, a)+evalRWS = evalRWS' @G+{-# INLINE evalRWS #-}++-- | Runs the RWS effect and discards the result of the interpreted program.+execRWS' :: forall tag r w s m a. (Functor m, Monoid w)+ => r -- ^ The initial environment.+ -> s -- ^ The initial state.+ -> (RWS' tag r w s `Via` RWST r w s) m a -- ^ The program whose RWS effect should be handled.+ -> m (w, s) -- ^ The program with its RWS effect handled, producing the final+ -- output @w@ and the final state @s@.+execRWS' r s = fmap reorder . (\m -> RWS.runRWST m r s) . coerce+ where+ reorder (_, s', w) = (w, s')+{-# INLINE execRWS' #-}++-- | The untagged version of 'execRWS''.+execRWS :: (Functor m, Monoid w) => r -> s -> (RWS r w s `Via` RWST r w s) m a -> m (w, s)+execRWS = execRWS' @G+{-# INLINE execRWS #-}++-- | Runs the RWS effect and returns the final output, the final state and the result of the interpreted program.+runRWS' :: forall tag r w s m a. (Functor m, Monoid w)+ => r -- ^ The initial environment.+ -> s -- ^ The initial state.+ -> (RWS' tag r w s `Via` RWST r w s) m a -- ^ The program whose RWS effect should be handled.+ -> m (w, s, a) -- ^ The program with its RWS effect handled, producing the final+ -- output @w@, the final state @s@ and the result @a@.+runRWS' r s = fmap reorder . (\m -> RWS.runRWST m r s) . coerce+ where+ reorder (a, s', w) = (w, s', a)+{-# INLINE runRWS' #-}++-- | The untagged version of 'runRWS''.+runRWS :: (Functor m, Monoid w) => r -> s -> (RWS r w s `Via` RWST r w s) m a -> m (w, s, a)+runRWS = runRWS' @G+{-# INLINE runRWS #-}
+ src/Control/Effect/Reader.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Reader+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- The reader effect, similar to the @MonadReader@ type class from the @mtl@+-- library.+-----------------------------------------------------------------------------+module Control.Effect.Reader+ ( -- * Tagged Reader Effect+ Reader'(..)+ -- * Untagged Reader Effect+ -- | If you don't require disambiguation of multiple reader effects+ -- (i.e., you only have one reader effect in your monadic context),+ -- it is recommended to always use the untagged reader effect.+ , Reader+ , ask+ , local+ , reader+ -- * Convenience Functions+ -- | If you don't require disambiguation of multiple reader effects+ -- (i.e., you only have one reader effect in your monadic context),+ -- it is recommended to always use the untagged functions.+ , asks'+ , asks+ -- * Interpretations+ , runReader'+ , runReader+ -- * Tagging and Untagging+ -- | Conversion functions between the tagged and untagged reader effect,+ -- usually used in combination with type applications, like:+ --+ -- @+ -- 'tagReader'' \@\"newTag\" program+ -- 'retagReader'' \@\"oldTag\" \@\"newTag\" program+ -- 'untagReader'' \@\"erasedTag\" program+ -- @+ -- + , tagReader'+ , retagReader'+ , untagReader'+ ) where++-- transformers+import qualified Control.Monad.Trans.Reader as R++import Control.Effect.Machinery (G, Tagger(Tagger), Via, makeTaggedEffect, runVia)++-- | An effect that adds an immutable state (i.e., an \"environment\") to a given+-- computation. The effect allows to read values from the environment, pass values+-- from function to function, and execute sub-computations in a modified environment.+class Monad m => Reader' tag r m | tag m -> r where+ {-# MINIMAL (ask' | reader'), local' #-}+ + -- | Gets the environment.+ ask' :: m r+ ask' = reader' @tag id+ {-# INLINE ask' #-}+ + -- | Executes a sub-computation in a modified environment.+ local' :: (r -> r) -- ^ The function to modify the environment.+ -> m a -- ^ The sub-computation to run in the modified environment.+ -> m a -- ^ The result of the sub-computation.+ + -- | Gets a specific component of the environment, using the provided projection function.+ reader' :: (r -> a) -- ^ The projection function to apply to the environment.+ -> m a -- ^ The result of the projection.+ reader' f = do+ r <- ask' @tag+ pure (f r)+ {-# INLINE reader' #-}++makeTaggedEffect ''Reader'++instance Monad m => Reader' tag r (R.ReaderT r m) where+ ask' = R.ask+ {-# INLINE ask' #-}+ local' = R.local+ {-# INLINE local' #-}+ reader' = R.reader+ {-# INLINE reader' #-}++-- | Gets a specific component of the environment, using the provided projection function.+asks' :: forall tag r m a. Reader' tag r m+ => (r -> a) -- ^ The projection function to apply to the environment.+ -> m a -- ^ The result of the projection.+asks' = reader' @tag+{-# INLINE asks' #-}++-- | The untagged version of 'asks''.+asks :: Reader r m => (r -> a) -> m a+asks = asks' @G+{-# INLINE asks #-}++-- | Runs the reader effect.+runReader' :: forall tag r m a. r -- ^ The initial environment.+ -> (Reader' tag r `Via` R.ReaderT r) m a -- ^ The program whose reader effect should be handled.+ -> m a -- ^ The program with its reader effect handled.+runReader' r = flip R.runReaderT r . runVia+{-# INLINE runReader' #-}++-- | The untagged version of 'runReader''.+runReader :: r -> (Reader r `Via` R.ReaderT r) m a -> m a+runReader = runReader' @G+{-# INLINE runReader #-}
+ src/Control/Effect/Resource.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Resource+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- The resource effect allows a computation to allocate resources which are+-- guaranteed to be released after their usage.+-----------------------------------------------------------------------------+module Control.Effect.Resource+ ( -- * Tagged Resource Effect+ Resource'(..)+ -- * Untagged Resource Effect+ -- | If you don't require disambiguation of multiple resource effects+ -- (i.e., you only have one resource effect in your monadic context),+ -- it is recommended to always use the untagged resource effect.+ , Resource+ , bracket+ , bracketOnError+ -- * Convenience Functions+ -- | If you don't require disambiguation of multiple resource effects+ -- (i.e., you only have one resource effect in your monadic context),+ -- it is recommended to always use the untagged functions.+ , finally'+ , finally+ , onException'+ , onException+ -- * Interpretations+ , LowerIO+ , runResourceIO'+ , runResourceIO+ -- * Tagging and Untagging+ -- | Conversion functions between the tagged and untagged resource effect,+ -- usually used in combination with type applications, like:+ --+ -- @+ -- 'tagResource'' \@\"newTag\" program+ -- 'retagResource'' \@\"oldTag\" \@\"newTag\" program+ -- 'untagResource'' \@\"erasedTag\" program+ -- @+ -- + , tagResource'+ , retagResource'+ , untagResource'+ ) where++-- base+import qualified Control.Exception as IO+import Data.Coerce (coerce)++import Control.Effect.Machinery++-- | An effect that allows a computation to allocate resources which are+-- guaranteed to be released after their usage.+class Monad m => Resource' tag m where+ -- | Acquire a resource, use it, and then release the resource after usage.+ bracket' :: m a -- ^ The computation which acquires the resource.+ -> (a -> m c) -- ^ The computation which releases the resource.+ -> (a -> m b) -- ^ The computation which uses the resource.+ -> m b -- ^ The result of the computation which used the resource.++ -- | Like 'bracket'', but only performs the release computation if the usage+ -- computation throws an exception.+ bracketOnError' :: m a -- ^ The computation which acquires the resource.+ -> (a -> m c) -- ^ The computation which releases the resource.+ -> (a -> m b) -- ^ The computation which uses the resource.+ -> m b -- ^ The result of the computation which used the resource.++makeTaggedEffect ''Resource'++-- | A simpler version of 'bracket'' where one computation is guaranteed to+-- run after another.+finally' :: forall tag m a b. Resource' tag m+ => m a -- ^ The computation to run.+ -> m b -- ^ The computation to run afterwards, even if the first+ -- computation throws an exception.+ -> m a -- ^ The result of the first computation.+finally' use free =+ bracket' @tag (pure ()) (pure free) (const use)+{-# INLINE finally' #-}++-- | The untagged version of 'finally''.+finally :: Resource m => m a -> m b -> m a+finally = finally' @G+{-# INLINE finally #-}++-- | A simpler version of 'bracketOnError'' where one computation is guaranteed+-- to run after another in case the first computation throws an exception.+onException' :: forall tag m a b. Resource' tag m+ => m a -- ^ The computation to run.+ -> m b -- ^ The computation to run afterwards, only if the first+ -- computation throws an exception.+ -> m a -- ^ The result of the first computation.+onException' use free =+ bracketOnError' @tag (pure ()) (const free) (const use)+{-# INLINE onException' #-}++-- | The untagged version of 'onException''.+onException :: Resource m => m a -> m b -> m a+onException = onException' @G+{-# INLINE onException #-}++-- | The IO-based interpreter of the resource effect. This type implements the+-- 'Resource'' type class by using 'IO.bracket', thus requiring 'IO' at the bottom+-- of the monad transformer stack.+--+-- When interpreting the effect, you usually don\'t interact with this type directly,+-- but instead use one of its corresponding interpretation functions.+newtype LowerIO m a =+ LowerIO { _runLowerIO :: m a }+ deriving (Applicative, Functor, Monad, MonadIO)+ deriving (MonadTrans, MonadTransControl) via Default+ deriving (MonadBase b, MonadBaseControl b)++instance MonadBaseControl IO m => Resource' tag (LowerIO m) where+ bracket' alloc free use =+ control $ \run ->+ IO.bracket+ ( run alloc )+ ( \a -> run (restoreM a >>= free) )+ ( \a -> run (restoreM a >>= use) )+ {-# INLINABLE bracket' #-}+ bracketOnError' alloc free use =+ control $ \run ->+ IO.bracketOnError+ ( run alloc )+ ( \a -> run (restoreM a >>= free) )+ ( \a -> run (restoreM a >>= use) )+ {-# INLINABLE bracketOnError' #-} ++-- | Runs the resource effect using 'IO.bracket'.+runResourceIO' :: (Resource' tag `Via` LowerIO) m a -> m a+runResourceIO' = coerce+{-# INLINE runResourceIO' #-}++-- | The untagged version of 'runResourceIO''.+runResourceIO :: (Resource `Via` LowerIO) m a -> m a+runResourceIO = coerce+{-# INLINE runResourceIO #-}
+ src/Control/Effect/State.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.State+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- The state effect, similar to the @MonadState@ type class from the @mtl@+-- library.+--+-- Lazy and strict interpretations of the effect are available here:+-- "Control.Effect.State.Lazy" and "Control.Effect.State.Strict".+-----------------------------------------------------------------------------+module Control.Effect.State+ ( -- * Tagged State Effect+ State'(..)+ -- * Untagged State Effect+ -- | If you don't require disambiguation of multiple state effects+ -- (i.e., you only have one state effect in your monadic context),+ -- it is recommended to always use the untagged state effect.+ , State+ , get+ , put+ , state+ -- * Convenience Functions+ -- | If you don't require disambiguation of multiple state effects+ -- (i.e., you only have one state effect in your monadic context),+ -- it is recommended to always use the untagged functions.+ , gets'+ , gets+ , modify'+ , modify+ , modifyStrict'+ , modifyStrict+ -- * Tagging and Untagging+ -- | Conversion functions between the tagged and untagged state effect,+ -- usually used in combination with type applications, like:+ --+ -- @+ -- 'tagState'' \@\"newTag\" program+ -- 'retagState'' \@\"oldTag\" \@\"newTag\" program+ -- 'untagState'' \@\"erasedTag\" program+ -- @+ -- + , tagState'+ , retagState'+ , untagState'+ ) where++-- base+import Data.Tuple (swap)++-- transformers+import qualified Control.Monad.Trans.State.Lazy as L+import qualified Control.Monad.Trans.State.Strict as S++import Control.Effect.Machinery (G, Tagger(Tagger), makeTaggedEffect)++-- | An effect that adds a mutable state to a given computation.+class Monad m => State' tag s m | tag m -> s where+ {-# MINIMAL get', put' | state' #-}+ + -- | Gets the current state.+ get' :: m s+ get' = state' @tag (\s -> (s, s))+ {-# INLINE get' #-}+ + -- | Replaces the state with a new value.+ put' :: s -> m ()+ put' s = state' @tag (\_ -> (s, ()))+ {-# INLINE put' #-}+ + -- | Updates the state and produces a value based on the current state.+ state' :: (s -> (s, a)) -> m a+ state' f = do+ s <- get' @tag+ let ~(s', a) = f s+ put' @tag s'+ pure a+ {-# INLINE state' #-}++makeTaggedEffect ''State'++instance Monad m => State' tag s (L.StateT s m) where+ get' = L.get+ {-# INLINE get' #-}+ put' = L.put+ {-# INLINE put' #-}+ state' = L.state . fmap swap+ {-# INLINE state' #-}++instance Monad m => State' tag s (S.StateT s m) where+ get' = S.get+ {-# INLINE get' #-}+ put' = S.put+ {-# INLINE put' #-}+ state' = S.state . fmap swap+ {-# INLINE state' #-}++-- | Gets a specific component of the state, using the provided projection function.+gets' :: forall tag s m a. State' tag s m => (s -> a) -> m a+gets' f = fmap f (get' @tag)+{-# INLINE gets' #-}++-- | The untagged version of 'gets''.+gets :: State s m => (s -> a) -> m a+gets = gets' @G+{-# INLINE gets #-}++-- | Modifies the state, using the provided function.+modify' :: forall tag s m. State' tag s m => (s -> s) -> m ()+modify' f = do+ s <- get' @tag+ put' @tag (f s)+{-# INLINE modify' #-}++-- | The untagged version of 'modify''.+modify :: State s m => (s -> s) -> m ()+modify = modify' @G+{-# INLINE modify #-}++-- | Modifies the state, using the provided function.+-- The computation is strict in the new state.+modifyStrict' :: forall tag s m. State' tag s m => (s -> s) -> m ()+modifyStrict' f = do+ s <- get' @tag+ put' @tag $! f s+{-# INLINE modifyStrict' #-}++-- | The untagged version of 'modifyStrict''.+modifyStrict :: State s m => (s -> s) -> m ()+modifyStrict = modifyStrict' @G+{-# INLINE modifyStrict #-}
+ src/Control/Effect/State/Lazy.hs view
@@ -0,0 +1,73 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.State.Lazy+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- Lazy interpretations of the 'State'' effect.+--+-- If you don't require disambiguation of multiple state effects+-- (i.e., you only have one state effect in your monadic context),+-- you usually need the untagged interpretations.+-----------------------------------------------------------------------------+module Control.Effect.State.Lazy+ ( -- * Tagged Interpretations+ evalState'+ , execState'+ , runState'+ -- * Untagged Interpretations+ , evalState+ , execState+ , runState+ ) where++-- base+import Data.Tuple (swap)++-- transformers+import Control.Monad.Trans.State.Lazy (StateT, runStateT)++import Control.Effect.State (State, State')+import Control.Effect.Machinery (G, Via, runVia)++-- | Runs the state effect and discards the final state.+evalState' :: forall tag s m a. Functor m+ => s -- ^ The initial state.+ -> (State' tag s `Via` StateT s) m a -- ^ The program whose state effect should be handled.+ -> m a -- ^ The program with its state effect handled.+evalState' s = fmap fst . flip runStateT s . runVia+{-# INLINE evalState' #-}++-- | The untagged version of 'evalState''.+evalState :: Functor m => s -> (State s `Via` StateT s) m a -> m a+evalState = evalState' @G+{-# INLINE evalState #-}++-- | Runs the state effect and discards the result of the interpreted program.+execState' :: forall tag s m a. Functor m+ => s -- ^ The initial state.+ -> (State' tag s `Via` StateT s) m a -- ^ The program whose state effect should be handled.+ -> m s -- ^ The program with its state effect handled, producing the final state @s@.+execState' s = fmap snd . flip runStateT s . runVia+{-# INLINE execState' #-}++-- | The untagged version of 'execState''.+execState :: Functor m => s -> (State s `Via` StateT s) m a -> m s+execState = execState' @G+{-# INLINE execState #-}++-- | Runs the state effect and returns both the final state and the result of the interpreted program.+runState' :: forall tag s m a. Functor m+ => s -- ^ The initial state.+ -> (State' tag s `Via` StateT s) m a -- ^ The program whose state effect should be handled.+ -> m (s, a) -- ^ The program with its state effect handled, producing the final state @s@ and the result @a@.+runState' s = fmap swap . flip runStateT s . runVia+{-# INLINE runState' #-}++-- | The untagged version of 'runState''.+runState :: Functor m => s -> (State s `Via` StateT s) m a -> m (s, a)+runState = runState' @G+{-# INLINE runState #-}
+ src/Control/Effect/State/Strict.hs view
@@ -0,0 +1,73 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.State.Strict+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- Strict interpretations of the 'State'' effect.+--+-- If you don't require disambiguation of multiple state effects+-- (i.e., you only have one state effect in your monadic context),+-- you usually need the untagged interpretations.+-----------------------------------------------------------------------------+module Control.Effect.State.Strict+ ( -- * Tagged Interpretations+ evalState'+ , execState'+ , runState'+ -- * Untagged Interpretations+ , evalState+ , execState+ , runState+ ) where++-- base+import Data.Tuple (swap)++-- transformers+import Control.Monad.Trans.State.Strict (StateT, runStateT)++import Control.Effect.State (State, State')+import Control.Effect.Machinery (G, Via, runVia)++-- | Runs the state effect and discards the final state.+evalState' :: forall tag s m a. Functor m+ => s -- ^ The initial state.+ -> (State' tag s `Via` StateT s) m a -- ^ The program whose state effect should be handled.+ -> m a -- ^ The program with its state effect handled.+evalState' s = fmap fst . flip runStateT s . runVia+{-# INLINE evalState' #-}++-- | The untagged version of 'evalState''.+evalState :: Functor m => s -> (State s `Via` StateT s) m a -> m a+evalState = evalState' @G+{-# INLINE evalState #-}++-- | Runs the state effect and returns the final state.+execState' :: forall tag s m a. Functor m+ => s -- ^ The initial state.+ -> (State' tag s `Via` StateT s) m a -- ^ The program whose state effect should be handled.+ -> m s -- ^ The program with its state effect handled, producing the final state @s@.+execState' s = fmap snd . flip runStateT s . runVia+{-# INLINE execState' #-}++-- | The untagged version of 'execState''.+execState :: Functor m => s -> (State s `Via` StateT s) m a -> m s+execState = execState' @G+{-# INLINE execState #-}++-- | Runs the state effect and returns both the final state and the result of the interpreted program.+runState' :: forall tag s m a. Functor m+ => s -- ^ The initial state.+ -> (State' tag s `Via` StateT s) m a -- ^ The program whose state effect should be handled.+ -> m (s, a) -- ^ The program with its state effect handled, producing the final state @s@ and the result @a@.+runState' s = fmap swap . flip runStateT s . runVia+{-# INLINE runState' #-}++-- | The untagged version of 'runState''.+runState :: Functor m => s -> (State s `Via` StateT s) m a -> m (s, a)+runState = runState' @G+{-# INLINE runState #-}
+ src/Control/Effect/Writer.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Writer+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- The writer effect, similar to the @MonadWriter@ type class from the @mtl@+-- library.+--+-- Lazy and strict interpretations of the effect are available here:+-- "Control.Effect.Writer.Lazy" and "Control.Effect.Writer.Strict".+-----------------------------------------------------------------------------+module Control.Effect.Writer+ ( -- * Tagged Writer Effect+ Writer'(..)+ -- * Untagged Writer Effect+ -- | If you don't require disambiguation of multiple writer effects+ -- (i.e., you only have one writer effect in your monadic context),+ -- it is recommended to always use the untagged writer effect.+ , Writer+ , tell+ , listen+ , censor+ -- * Convenience Functions+ -- | If you don't require disambiguation of multiple writer effects+ -- (i.e., you only have one writer effect in your monadic context),+ -- it is recommended to always use the untagged functions.+ , listens'+ , listens+ -- * Tagging and Untagging+ -- | Conversion functions between the tagged and untagged writer effect,+ -- usually used in combination with type applications, like:+ --+ -- @+ -- 'tagWriter'' \@\"newTag\" program+ -- 'retagWriter'' \@\"oldTag\" \@\"newTag\" program+ -- 'untagWriter'' \@\"erasedTag\" program+ -- @+ -- + , tagWriter'+ , retagWriter'+ , untagWriter'+ ) where++-- base+import Data.Tuple (swap)++-- transformers+import qualified Control.Monad.Trans.Writer.Lazy as L+import qualified Control.Monad.Trans.Writer.CPS as S++import Control.Effect.Machinery (G, Tagger(Tagger), makeTaggedEffect)++-- | An effect that adds a write-only, accumulated output to a given computation.+class Monad m => Writer' tag w m | tag m -> w where+ -- | Produces the output @w@. In other words, @w@ is appended to the accumulated output.+ tell' :: w -> m ()+ -- | Executes a sub-computation and appends @w@ to the accumulated output.+ listen' :: m a -> m (w, a)+ -- | Executes a sub-computation and applies the function to its output.+ censor' :: (w -> w) -- ^ The function which is applied to the output.+ -> m a -- ^ The sub-computation which produces the modified output.+ -> m a -- ^ The result of the sub-computation.++makeTaggedEffect ''Writer'++instance (Monad m, Monoid w) => Writer' tag w (L.WriterT w m) where+ tell' = L.tell+ {-# INLINE tell' #-}+ listen' = fmap swap . L.listen+ {-# INLINE listen' #-}+ censor' = L.censor+ {-# INLINE censor' #-}++instance (Monad m, Monoid w) => Writer' tag w (S.WriterT w m) where+ tell' = S.tell+ {-# INLINE tell' #-}+ listen' = fmap swap . S.listen+ {-# INLINE listen' #-}+ censor' = S.censor+ {-# INLINE censor' #-}++-- | Executes a sub-computation and applies the function to its output, thus adding+-- an additional value to the result of the sub-computation.+listens' :: forall tag w b m a. Writer' tag w m+ => (w -> b) -- ^ The function which is applied to the output.+ -> m a -- ^ The sub-computation which produces the modified output.+ -> m (b, a) -- ^ The result of the sub-computation, including the modified output.+listens' f action = do+ ~(w, a) <- listen' @tag action+ pure (f w, a)+{-# INLINE listens' #-}++-- | The untagged version of 'listens''.+listens :: Writer w m => (w -> b) -> m a -> m (b, a)+listens = listens' @G+{-# INLINE listens #-}
+ src/Control/Effect/Writer/Lazy.hs view
@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Writer.Lazy+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- Lazy interpretations of the 'Writer'' effect.+--+-- If you don't require disambiguation of multiple writer effects+-- (i.e., you only have one writer effect in your monadic context),+-- you usually need the untagged interpretations.+-----------------------------------------------------------------------------+module Control.Effect.Writer.Lazy+ ( -- * Tagged Interpretations+ execWriter'+ , runWriter'+ -- * Untagged Interpretations+ , execWriter+ , runWriter+ ) where++-- base+import Data.Tuple (swap)++-- transformers+import Control.Monad.Trans.Writer.Lazy (WriterT, execWriterT, runWriterT)++import Control.Effect.Writer (Writer, Writer')+import Control.Effect.Machinery (G, Via, runVia)++-- | Runs the writer effect and returns the final output.+execWriter' :: forall tag w m a. Monad m+ => (Writer' tag w `Via` WriterT w) m a -- ^ The program whose writer effect should be handled.+ -> m w -- ^ The program with its writer effect handled, producing the final output @w@.+execWriter' = execWriterT . runVia+{-# INLINE execWriter' #-}++-- | The untagged version of 'execWriter''.+execWriter :: Monad m => (Writer w `Via` WriterT w) m a -> m w+execWriter = execWriter' @G+{-# INLINE execWriter #-}++-- | Runs the writer effect and returns both the final output and the result of the interpreted program.+runWriter' :: forall tag w m a. Functor m+ => (Writer' tag w `Via` WriterT w) m a -- ^ The program whose writer effect should be handled.+ -> m (w, a) -- ^ The program with its writer effect handled, producing the final output @w@ and the result @a@.+runWriter' = fmap swap . runWriterT . runVia+{-# INLINE runWriter' #-}++-- | The untagged version of 'runWriter''.+runWriter :: Functor m => (Writer w `Via` WriterT w) m a -> m (w, a)+runWriter = runWriter' @G+{-# INLINE runWriter #-}
+ src/Control/Effect/Writer/Strict.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Effect.Writer.Strict+-- Copyright : (c) Michael Szvetits, 2020+-- License : BSD3 (see the file LICENSE)+-- Maintainer : typedbyte@qualified.name+-- Stability : stable+-- Portability : portable+--+-- Strict interpretations of the 'Writer'' effect.+--+-- If you don't require disambiguation of multiple writer effects+-- (i.e., you only have one writer effect in your monadic context),+-- you usually need the untagged interpretations.+-----------------------------------------------------------------------------+module Control.Effect.Writer.Strict+ ( -- * Interpreter Type+ WriterT+ -- * Tagged Interpretations+ , execWriter'+ , runWriter'+ -- * Untagged Interpretations+ , execWriter+ , runWriter+ ) where++-- base+import Control.Monad (liftM)+import Data.Coerce (coerce)+import Data.Tuple (swap)++-- transformers+import qualified Control.Monad.Trans.Writer.CPS as W++import Control.Effect.Machinery+import Control.Effect.Writer (Writer, Writer')++-- This is necessary until the writer CPS instance land in monad-control.+-- See: https://github.com/basvandijk/monad-control/pull/51+-- | The strict interpreter of the writer effect. This type implements the+-- 'Writer'' type class in a strict manner.+--+-- When interpreting the effect, you usually don\'t interact with this type directly,+-- but instead use one of its corresponding interpretation functions.+newtype WriterT w m a =+ WriterT { runWriterT :: W.WriterT w m a }+ deriving (Applicative, Functor, Monad, MonadIO)+ deriving (MonadTrans)+ deriving (Writer' tag w)++instance MonadBase b m => MonadBase b (WriterT w m) where+ liftBase = liftBaseDefault+ {-# INLINE liftBase #-}++instance (MonadBaseControl b m, Monoid w) => MonadBaseControl b (WriterT w m) where+ type StM (WriterT w m) a = ComposeSt (WriterT w) m a+ liftBaseWith = defaultLiftBaseWith+ {-# INLINE liftBaseWith #-}+ restoreM = defaultRestoreM+ {-# INLINE restoreM #-}++instance Monoid w => MonadTransControl (WriterT w) where+ type StT (WriterT w) a = (a, w)+ liftWith f = WriterT . W.writerT $+ liftM ( \x -> (x, mempty) )+ ( f $ W.runWriterT . runWriterT )+ {-# INLINABLE liftWith #-}+ restoreT = WriterT . W.writerT+ {-# INLINABLE restoreT #-}++-- | Runs the writer effect and returns the final output.+execWriter' :: forall tag w m a. (Monad m, Monoid w)+ => (Writer' tag w `Via` WriterT w) m a -- ^ The program whose writer effect should be handled.+ -> m w -- ^ The program with its writer effect handled, producing the final output @w@.+execWriter' = W.execWriterT . coerce+{-# INLINE execWriter' #-}++-- | The untagged version of 'execWriter''.+execWriter :: (Monad m, Monoid w) => (Writer w `Via` WriterT w) m a -> m w+execWriter = execWriter' @G+{-# INLINE execWriter #-}++-- | Runs the writer effect and returns both the final output and the result of the interpreted program.+runWriter' :: forall tag w m a. (Functor m, Monoid w)+ => (Writer' tag w `Via` WriterT w) m a -- ^ The program whose writer effect should be handled.+ -> m (w, a) -- ^ The program with its writer effect handled, producing the final output @w@ and the result @a@.+runWriter' = fmap swap . W.runWriterT . coerce+{-# INLINE runWriter' #-}++-- | The untagged version of 'runWriter''.+runWriter :: (Functor m, Monoid w) => (Writer w `Via` WriterT w) m a -> m (w, a)+runWriter = runWriter' @G+{-# INLINE runWriter #-}