diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,4 +2,9 @@ ## 0.1.0.0 (2020-07-17) -* Initial release +* Initial release + +## 0.2.0.0 (2020-07-29) + +* Lifted the restriction that one handler can exactly handle one effect. Handlers can now handle multiple effects. +* Effects whose definitions refer to other effects (see the RWS effect, for example) are now possible to implement, but only manually for now (i.e., no code generation). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -282,12 +282,7 @@ ## 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 - ... - ``` +* `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. They are explained in the documentation of the module `Control.Effect.Machinery.TH`. +* Effect type classes that are based on other effect type classes (like `RWS`) are possible, but cannot be used with the provided code generation infrastructure yet (not to be confused with writing an effect *handler* based on other effects, which is possible). * The performance should be `mtl`-like, but this has not been verified yet. * The library needs some tests. diff --git a/effet.cabal b/effet.cabal --- a/effet.cabal +++ b/effet.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 5e1b55b6a5d186ec023537858ae4098ce19caa92be7cc2d07e60ea0630e75011 +-- hash: 397bba600623b58701020a4ec01a2dff5e707d155f8f98e84f63423537604919 name: effet -version: 0.1.0.0 +version: 0.2.0.0 synopsis: An Effect System based on Type Classes description: Please see the README on GitHub at category: Control @@ -34,7 +34,6 @@ 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 diff --git a/src/Control/Effect/Cont.hs b/src/Control/Effect/Cont.hs --- a/src/Control/Effect/Cont.hs +++ b/src/Control/Effect/Cont.hs @@ -65,9 +65,10 @@ callCC' :: ((a -> m b) -> m a) -> m a makeHandler ''Cont' +makeFinder ''Cont' makeTagger ''Cont' -instance {-# OVERLAPPABLE #-} Control (Cont' tag) t m => Cont' tag (Via eff t m) where +instance Control (Cont' tag) t m => Cont' tag (EachVia '[] t m) where callCC' f = liftWith ( \run -> callCC' @tag $ \c -> run . f $ diff --git a/src/Control/Effect/Error.hs b/src/Control/Effect/Error.hs --- a/src/Control/Effect/Error.hs +++ b/src/Control/Effect/Error.hs @@ -51,7 +51,7 @@ -- transformers import Control.Monad.Trans.Except (ExceptT(ExceptT), catchE, throwE) -import Control.Effect.Machinery (G, Tagger(Tagger), Via(Via), makeTaggedEffect) +import Control.Effect.Machinery -- | An effect that equips a computation with the ability to throw and catch -- exceptions. diff --git a/src/Control/Effect/Machinery.hs b/src/Control/Effect/Machinery.hs --- a/src/Control/Effect/Machinery.hs +++ b/src/Control/Effect/Machinery.hs @@ -14,7 +14,6 @@ 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 @@ -41,7 +40,6 @@ 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 diff --git a/src/Control/Effect/Machinery/Kind.hs b/src/Control/Effect/Machinery/Kind.hs deleted file mode 100644 --- a/src/Control/Effect/Machinery/Kind.hs +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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) diff --git a/src/Control/Effect/Machinery/TH.hs b/src/Control/Effect/Machinery/TH.hs --- a/src/Control/Effect/Machinery/TH.hs +++ b/src/Control/Effect/Machinery/TH.hs @@ -15,18 +15,23 @@ ( -- * Common Generators makeEffect , makeHandler + , makeFinder , makeLifter -- * Tag-based Generators , makeTaggedEffect , makeTaggedEffectWith , makeTagger , makeTaggerWith + -- * Lifting Convenience + , liftL + , runL -- * Naming Convention , removeApostrophe ) where -- base import Control.Monad (forM, replicateM) +import Data.Coerce (coerce) import Data.List (isSuffixOf) import Data.Maybe (maybeToList) @@ -40,9 +45,9 @@ -- 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) +import Control.Effect.Machinery.Via (Control, EachVia, Find, G, Handle, Lift, + Via, runVia) data ClassInfo = ClassInfo { clsCxt :: Cxt @@ -212,6 +217,16 @@ ++ "' is not a type class, but the following instead: " ++ show other +instanceFinderCxt :: Name -> Name -> EffectInfo -> Q Cxt +instanceFinderCxt name effs info = cxt + [ + conT name + `appT` effType info + `appT` varT effs + `appT` varT (effTrafoName info) + `appT` tyVarType (effMonad info) + ] + instanceCxt :: Name -> EffectInfo -> Q Cxt instanceCxt name info = cxt [ @@ -222,11 +237,11 @@ ] instanceHead :: Q Type -> EffectInfo -> Q Type -instanceHead eff info = +instanceHead effs info = effType info `appT` ( - conT ''Via - `appT` eff + conT ''EachVia + `appT` effs `appT` varT (effTrafoName info) `appT` tyVarType (effMonad info) ) @@ -242,26 +257,42 @@ -- ... -- @ -- --- @makeEffect ''MyEffect@ then generates two instances for this effect type +-- @makeEffect ''MyEffect@ then generates three 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 'Handle' (MyEffect a b c) t m => MyEffect a b c ('EachVia' (MyEffect a b c : effs) t m) where -- ... -- --- instance {-\# OVERLAPPABLE \#-} 'Lift'/'Control' (MyEffect a b c) t m => MyEffect a b c ('Via' eff t m) where +-- instance {-\# OVERLAPPABLE \#-} 'Find' (MyEffect a b c) effs t m => MyEffect a b c ('EachVia' (other : effs) t m) where -- ... +-- +-- instance 'Lift'/'Control' (MyEffect a b c) t m => MyEffect a b c ('EachVia' \'[] 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'. +-- The first instance indicates that @MyEffect@ was found at the head of the type +-- level list of effects to be handled, so @MyEffect@ is delegated to @t@. +-- +-- The second instance indicates that @MyEffect@ was not found at the head of the +-- type level list of effects to be handled, so we must find @MyEffect@ in the tail @effs@ +-- of the type level list. +-- +-- The third instance indicates that @MyEffect@ could not be found in the type level +-- list of effects to be handled, so the effect must be delegated further down the monad +-- transformer stack in order to find its corresponding effect handler. +-- +-- Without @TemplateHaskell@, you have to write these three instances by hand. These +-- instances can also be generated separately, see 'makeHandler', 'makeFinder' and +-- 'makeLifter'. makeEffect :: Name -> Q [Dec] makeEffect className = do clsInfo <- classInfo className effInfo <- effectInfo clsInfo hInstance <- handler effInfo + fInstance <- finder effInfo lInstance <- lifter effInfo - pure [hInstance, lInstance] + pure [hInstance, fInstance, lInstance] -- | Similar to 'makeTaggedEffect', but only generates the tag-related definitions. makeTagger :: Name -> Q [Dec] @@ -332,9 +363,10 @@ effInfo <- effectInfo clsInfo tagInfo <- taggedInfo f effInfo hInstance <- handler effInfo + fInstance <- finder effInfo lInstance <- lifter effInfo taggerDecs <- tagger tagInfo - pure (hInstance : lInstance : taggerDecs) + pure (hInstance : fInstance : lInstance : taggerDecs) -- | Similar to 'makeEffect', but only generates the effect type class instance -- for handling an effect. @@ -346,6 +378,17 @@ pure [hInstance] -- | Similar to 'makeEffect', but only generates the effect type class instance +-- for finding the effect in the tail of the type level list. +-- +-- @since 0.2.0.0 +makeFinder :: Name -> Q [Dec] +makeFinder className = do + clsInfo <- classInfo className + effInfo <- effectInfo clsInfo + fInstance <- finder effInfo + pure [fInstance] + +-- | Similar to 'makeEffect', but only generates the effect type class instance -- for lifting an effect. makeLifter :: Name -> Q [Dec] makeLifter className = do @@ -369,11 +412,23 @@ handler :: EffectInfo -> Q Dec handler info = do funs <- handlerFunctions info + effs <- newName "effs" instanceD ( instanceCxt ''Handle info ) - ( instanceHead (effType info) info ) + ( instanceHead (promotedConsT `appT` effType info `appT` varT effs) info ) ( fmap pure funs ) +finder :: EffectInfo -> Q Dec +finder info = do + funs <- finderFunctions info + other <- newName "other" + effs <- newName "effs" + instanceWithOverlapD + ( Just Overlappable ) + ( instanceFinderCxt ''Find effs info ) + ( instanceHead (promotedConsT `appT` varT other `appT` varT effs) info ) + ( fmap pure funs ) + lifter :: EffectInfo -> Q Dec lifter info = do let @@ -383,11 +438,9 @@ then ''Control else ''Lift funs <- lifterFunctions info - eff <- newName "eff" - instanceWithOverlapD - ( Just Overlappable ) + instanceD ( instanceCxt context info ) - ( instanceHead (varT eff) info ) + ( instanceHead promotedNilT info ) ( fmap pure funs ) taggerFunctions :: TaggedInfo -> Q [Dec] @@ -505,9 +558,36 @@ handlerFunctions info = fmap concat $ mapM - ( function [| Via |] [| runVia |] (effMonad info) (effParams info) ) + ( function [| EachVia |] [| runVia |] (effMonad info) (effParams info) ) ( effSigs info ) +-- | Adds an effect @eff@ to the type level list of effects that need to be +-- handled by the transformer @t@. From a structural point of view, this is +-- analogous to @lift@ in the @mtl@ ecosystem. This function comes in handy +-- when writing the 'Find'-based instance of an effect by hand. +-- +-- @since 0.2.0.0 +liftL :: EachVia effs t m a -> EachVia (eff : effs) t m a +liftL = coerce +{-# INLINE liftL #-} + +-- | Removes an effect @eff@ from the type level list of effects that need to be +-- handled by the transformer @t@. From a structural point of view, this is +-- analogous to the @run...@ functions in the @mtl@ ecosystem. This function +-- comes in handy when writing the 'Find'-based instance of an effect by hand. +-- +-- @since 0.2.0.0 +runL :: EachVia (eff : effs) t m a -> EachVia effs t m a +runL = coerce +{-# INLINE runL #-} + +finderFunctions :: EffectInfo -> Q [Dec] +finderFunctions info = + fmap concat $ + mapM + ( function [| liftL |] [| runL |] (effMonad info) (effParams info) ) + ( effSigs info ) + lifterFunctions :: EffectInfo -> Q [Dec] lifterFunctions info = let m = effMonad info @@ -543,7 +623,7 @@ let typeAppliedName = foldl appTypeE (varE funName) paramTypes appliedExp = foldl appE expr (typeAppliedName : fmap varE fParams) body = - [| Via $ + [| EachVia $ (liftWith $ \ $([p|run|]) -> $appliedExp) >>= $(traverseExp res) (restoreT . pure) |] @@ -590,7 +670,7 @@ 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) |] + then [| \x b -> $rf (((x =<<) . EachVia . restoreT . pure) b) |] else [| \x b -> $rf (x ($af b)) |] ForallT _ _ t -> derive rs f inv m t diff --git a/src/Control/Effect/Machinery/Via.hs b/src/Control/Effect/Machinery/Via.hs --- a/src/Control/Effect/Machinery/Via.hs +++ b/src/Control/Effect/Machinery/Via.hs @@ -7,20 +7,35 @@ -- 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). +-- This module defines the types 'EachVia' and its corresponding type synonym +-- 'Via' which indicate that specific effects are 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. +-- +-- Last but not least, it 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.Via - ( Via(..) + ( -- * Core Types + EachVia(..) + , Via , G + -- * Constraint Synonyms and Kinds + , SomeMonad + , Effect + , Transformer + , Handle + , Find + , Lift + , Control ) where -- base import Control.Monad.IO.Class (MonadIO) +import Data.Kind (Constraint, Type) -- monad-control import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl, @@ -33,30 +48,36 @@ -- 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 +-- | This type indicates that the effects (i.e., type classes) @effs@ are 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 +-- system to pick the instances of type classes @effs@ given by the type @t@, and +-- to delegate all other effects that are not in @effs@ 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 } +-- +-- @since 0.2.0.0 +newtype EachVia (effs :: [Effect]) (t :: Transformer) m a = + EachVia { 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 +instance (Monad (t m), MonadBase b m, MonadTrans t) => MonadBase b (EachVia effs 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 +instance (Monad (t m), MonadBaseControl b m, MonadTransControl t) => MonadBaseControl b (EachVia effs t m) where + type StM (EachVia effs t m) a = ComposeSt t m a liftBaseWith = defaultLiftBaseWith {-# INLINE liftBaseWith #-} restoreM = defaultRestoreM {-# INLINE restoreM #-} +-- | This type synonym can be used to indicate that a single effect @eff@ is +-- handled by a specific monad transformer @t@. +-- +-- @since 0.2.0.0 +type Via eff t m a = EachVia '[eff] t m a + -- | 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 @@ -66,3 +87,55 @@ -- 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 + +-- | 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 type synonym indicates that an effect @eff@ is not at the head of the +-- type level list of effects to be handled, so the effect must be found further +-- down in the tail @effs@. +-- +-- @since 0.2.0.0 +type Find eff effs t m = (Monad (t m), eff (EachVia effs 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) diff --git a/src/Control/Effect/Map.hs b/src/Control/Effect/Map.hs --- a/src/Control/Effect/Map.hs +++ b/src/Control/Effect/Map.hs @@ -55,7 +55,7 @@ import Data.Maybe (isJust) import Prelude hiding (lookup) -import Control.Effect.Machinery (G, Tagger(Tagger), makeTaggedEffect) +import Control.Effect.Machinery -- | 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 diff --git a/src/Control/Effect/RWS.hs b/src/Control/Effect/RWS.hs --- a/src/Control/Effect/RWS.hs +++ b/src/Control/Effect/RWS.hs @@ -16,47 +16,18 @@ ----------------------------------------------------------------------------- module Control.Effect.RWS ( -- * Tagged RWS Effect - RWS'(..) + 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(..) + , Separation , runSeparatedRWS' , runSeparatedRWS -- * Tagging and Untagging + , Tagger -- | Conversion functions between the tagged and untagged RWS effect, -- usually used in combination with type applications, like: -- @@ -73,145 +44,41 @@ -- 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.Monad.Trans.RWS.Lazy as Lazy 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 +import Control.Effect.Machinery hiding (Tagger) -- | 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' #-} +-- +-- @since 0.2.0.0 +class (R.Reader' tag r m, W.Writer' tag w m, S.State' tag s m) => RWS' tag r w s m | tag m -> r w s --- | The untagged version of 'gets''. -gets :: RWS r w s m => (s -> a) -> m a -gets f = fmap f get -{-# INLINE gets #-} +type RWS r w s = RWS' G r w s --- | 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' #-} +instance ( Monad (t m), + R.Reader' tag r (EachVia effs t m), + W.Writer' tag w (EachVia effs t m), + S.State' tag s (EachVia effs t m) + ) => RWS' tag r w s (EachVia (RWS' tag r w s : effs) t m) --- | The untagged version of 'modify''. -modify :: RWS r w s m => (s -> s) -> m () -modify = modify' @G -{-# INLINE modify #-} +instance {-# OVERLAPPABLE #-} + Find (RWS' tag r w s) effs t m => RWS' tag r w s (EachVia (other : effs) t m) --- | 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' #-} +instance Control (RWS' tag r w s) t m => RWS' tag r w s (EachVia '[] t m) --- | The untagged version of 'modifyStrict''. -modifyStrict :: RWS r w s m => (s -> s) -> m () -modifyStrict = modifyStrict' @G -{-# INLINE modifyStrict #-} +instance (Monad m, Monoid w) => RWS' tag r w s (Lazy.RWST r w s m) +instance (Monad m, Monoid w) => RWS' tag r w s (Strict.RWST r w s m) -- | 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 @@ -220,34 +87,76 @@ -- 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 } + Separation { _runSeparation :: m a } deriving (Applicative, Functor, Monad, MonadIO) deriving (MonadTrans, MonadTransControl) via Default deriving (MonadBase b, MonadBaseControl b) + deriving (R.Reader' tag r, W.Writer' tag w, S.State' tag s) -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) +instance (R.Reader' tag r m, W.Writer' tag w m, S.State' tag s m) => RWS' tag r w s (Separation m) + +-- | Runs the RWS effect via separation. +runSeparatedRWS' + :: ('[RWS' tag r w s, R.Reader' tag r, W.Writer' tag w, S.State' tag s] `EachVia` 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, R.Reader r, W.Writer w, S.State s] `EachVia` Separation) m a -> m a +runSeparatedRWS = coerce +{-# INLINE runSeparatedRWS #-} + +-- | The tagging interpreter of the RWS effect. This type implements the +-- 'RWS'' type class by tagging\/retagging\/untagging its reader, writer and state +-- components. +-- +-- When interpreting the effect, you usually don\'t interact with this type directly, +-- but instead use one of its corresponding interpretation functions. +-- +-- @since 0.2.0.0 +newtype Tagger tag new m a = + Tagger { runRWSTagger :: m a } + deriving (Applicative, Functor, Monad, MonadIO) + deriving (MonadTrans, MonadTransControl) via Default + deriving (MonadBase b, MonadBaseControl b) + +instance RWS' new r w s m => RWS' tag r w s (Tagger tag new m) + +instance RWS' new r w s m => R.Reader' tag r (Tagger tag new m) where + ask' = Tagger (R.ask' @new) {-# INLINE ask' #-} - local' f = Separation . R.local' @tag f . runSeparation + local' f m = Tagger (R.local' @new f (runRWSTagger m)) {-# INLINE local' #-} - tell' = Separation . W.tell' @tag + reader' f = Tagger (R.reader' @new f) + {-# INLINE reader' #-} + +instance RWS' new r w s m => W.Writer' tag w (Tagger tag new m) where + tell' w = Tagger (W.tell' @new w) {-# INLINE tell' #-} - listen' = Separation . W.listen' @tag . runSeparation + listen' m = Tagger (W.listen' @new (runRWSTagger m)) {-# INLINE listen' #-} - censor' f = Separation . W.censor' @tag f . runSeparation + censor' f m = Tagger (W.censor' @new f (runRWSTagger m)) {-# INLINE censor' #-} - get' = Separation (S.get' @tag) + +instance RWS' new r w s m => S.State' tag s (Tagger tag new m) where + get' = Tagger (S.get' @new) {-# INLINE get' #-} - put' = Separation . S.put' @tag + put' s = Tagger (S.put' @new s) {-# INLINE put' #-} + state' f = Tagger (S.state' @new f) + {-# INLINE state' #-} --- | 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' #-} +tagRWS' :: forall new r w s m a. ('[RWS' G r w s, R.Reader' G r, W.Writer' G w, S.State' G s] `EachVia` Tagger G new) m a -> m a +tagRWS' = coerce +{-# INLINE tagRWS' #-} --- | The untagged version of 'runSeparatedRWS''. -runSeparatedRWS :: (RWS r w s `Via` Separation) m a -> m a -runSeparatedRWS = coerce -{-# INLINE runSeparatedRWS #-} +retagRWS' :: forall tag new r w s m a. ('[RWS' tag r w s, R.Reader' tag r, W.Writer' tag w, S.State' tag s] `EachVia` Tagger tag new) m a -> m a +retagRWS' = coerce +{-# INLINE retagRWS' #-} + +untagRWS' :: forall tag r w s m a. ('[RWS' tag r w s, R.Reader' tag r, W.Writer' tag w, S.State' tag s] `EachVia` Tagger tag G) m a -> m a +untagRWS' = coerce +{-# INLINE untagRWS' #-} diff --git a/src/Control/Effect/RWS/Lazy.hs b/src/Control/Effect/RWS/Lazy.hs --- a/src/Control/Effect/RWS/Lazy.hs +++ b/src/Control/Effect/RWS/Lazy.hs @@ -27,56 +27,75 @@ -- transformers import Control.Monad.Trans.RWS.Lazy (RWST, runRWST) -import Control.Effect.Machinery (G, Via, runVia) +import Control.Effect.Machinery (EachVia, G, runVia) +import Control.Effect.Reader (Reader, Reader') import Control.Effect.RWS (RWS, RWS') +import Control.Effect.State (State, State') +import Control.Effect.Writer (Writer, Writer') -- | 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' + :: forall tag r w s m a. Functor m + => r + -- ^ The initial environment. + -> s + -- ^ The initial state. + -> ('[RWS' tag r w s, Reader' tag r, Writer' tag w, State' tag s] `EachVia` 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 :: Functor m => r -> s -> ('[RWS r w s, Reader r, Writer w, State s] `EachVia` 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' + :: forall tag r w s m a. Functor m + => r + -- ^ The initial environment. + -> s + -- ^ The initial state. + -> ('[RWS' tag r w s, Reader' tag r, Writer' tag w, State' tag s] `EachVia` 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 :: Functor m => r -> s -> ('[RWS r w s, Reader r, Writer w, State s] `EachVia` 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@. +-- | 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, Reader' tag r, Writer' tag w, State' tag s] `EachVia` 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 :: Functor m => r -> s -> ('[RWS r w s, Reader r, Writer w, State s] `EachVia` RWST r w s) m a -> m (w, s, a) runRWS = runRWS' @G {-# INLINE runRWS #-} diff --git a/src/Control/Effect/RWS/Strict.hs b/src/Control/Effect/RWS/Strict.hs --- a/src/Control/Effect/RWS/Strict.hs +++ b/src/Control/Effect/RWS/Strict.hs @@ -34,7 +34,10 @@ import qualified Control.Monad.Trans.RWS.CPS as RWS import Control.Effect.Machinery -import Control.Effect.RWS (RWS, RWS') +import Control.Effect.Reader (Reader, Reader') +import Control.Effect.RWS (RWS, RWS') +import Control.Effect.State (State, State') +import Control.Effect.Writer (Writer, Writer') -- This is necessary until the writer CPS instances land in monad-control. -- See: https://github.com/basvandijk/monad-control/pull/51 @@ -47,7 +50,7 @@ RWST { runRWST :: RWS.RWST r w s m a } deriving (Applicative, Functor, Monad, MonadIO) deriving (MonadTrans) - deriving (RWS' tag r w s) + deriving (RWS' tag r w s, Reader' tag r, Writer' tag w, State' tag s) instance MonadBase b m => MonadBase b (RWST r w s m) where liftBase = liftBaseDefault @@ -70,52 +73,67 @@ {-# 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' + :: forall tag r w s m a. (Functor m, Monoid w) + => r + -- ^ The initial environment. + -> s + -- ^ The initial state. + -> ('[RWS' tag r w s, Reader' tag r, Writer' tag w, State' tag s] `EachVia` 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 :: (Functor m, Monoid w) => r -> s -> ('[RWS r w s, Reader r, Writer w, State s] `EachVia` 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' + :: forall tag r w s m a. (Functor m, Monoid w) + => r + -- ^ The initial environment. + -> s + -- ^ The initial state. + -> ('[RWS' tag r w s, Reader' tag r, Writer' tag w, State' tag s] `EachVia` 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 :: (Functor m, Monoid w) => r -> s -> ('[RWS r w s, Reader r, Writer w, State s] `EachVia` 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' + :: forall tag r w s m a. (Functor m, Monoid w) + => r + -- ^ The initial environment. + -> s + -- ^ The initial state. + -> ('[RWS' tag r w s, Reader' tag r, Writer' tag w, State' tag s] `EachVia` 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 :: (Functor m, Monoid w) => r -> s -> ('[RWS r w s, Reader r, Writer w, State s] `EachVia` RWST r w s) m a -> m (w, s, a) runRWS = runRWS' @G {-# INLINE runRWS #-} diff --git a/src/Control/Effect/Reader.hs b/src/Control/Effect/Reader.hs --- a/src/Control/Effect/Reader.hs +++ b/src/Control/Effect/Reader.hs @@ -47,9 +47,11 @@ ) where -- transformers -import qualified Control.Monad.Trans.Reader as R +import qualified Control.Monad.Trans.Reader as R +import qualified Control.Monad.Trans.RWS.CPS as Strict +import qualified Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Effect.Machinery (G, Tagger(Tagger), Via, makeTaggedEffect, runVia) +import Control.Effect.Machinery -- | 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 @@ -83,6 +85,22 @@ local' = R.local {-# INLINE local' #-} reader' = R.reader + {-# INLINE reader' #-} + +instance (Monad m, Monoid w) => Reader' tag r (Lazy.RWST r w s m) where + ask' = Lazy.ask + {-# INLINE ask' #-} + local' = Lazy.local + {-# INLINE local' #-} + reader' = Lazy.reader + {-# INLINE reader' #-} + +instance Monad m => Reader' tag r (Strict.RWST r w s m) where + ask' = Strict.ask + {-# INLINE ask' #-} + local' = Strict.local + {-# INLINE local' #-} + reader' = Strict.reader {-# INLINE reader' #-} -- | Gets a specific component of the environment, using the provided projection function. diff --git a/src/Control/Effect/State.hs b/src/Control/Effect/State.hs --- a/src/Control/Effect/State.hs +++ b/src/Control/Effect/State.hs @@ -54,10 +54,12 @@ import Data.Tuple (swap) -- transformers +import qualified Control.Monad.Trans.RWS.CPS as Strict +import qualified Control.Monad.Trans.RWS.Lazy as Lazy 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) +import Control.Effect.Machinery -- | An effect that adds a mutable state to a given computation. class Monad m => State' tag s m | tag m -> s where @@ -98,6 +100,22 @@ put' = S.put {-# INLINE put' #-} state' = S.state . fmap swap + {-# INLINE state' #-} + +instance (Monad m, Monoid w) => State' tag s (Lazy.RWST r w s m) where + get' = Lazy.get + {-# INLINE get' #-} + put' = Lazy.put + {-# INLINE put' #-} + state' = Lazy.state . fmap swap + {-# INLINE state' #-} + +instance Monad m => State' tag s (Strict.RWST r w s m) where + get' = Strict.get + {-# INLINE get' #-} + put' = Strict.put + {-# INLINE put' #-} + state' = Strict.state . fmap swap {-# INLINE state' #-} -- | Gets a specific component of the state, using the provided projection function. diff --git a/src/Control/Effect/Writer.hs b/src/Control/Effect/Writer.hs --- a/src/Control/Effect/Writer.hs +++ b/src/Control/Effect/Writer.hs @@ -50,10 +50,12 @@ import Data.Tuple (swap) -- transformers +import qualified Control.Monad.Trans.RWS.CPS as Strict +import qualified Control.Monad.Trans.RWS.Lazy as Lazy 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) +import Control.Effect.Machinery -- | An effect that adds a write-only, accumulated output to a given computation. class Monad m => Writer' tag w m | tag m -> w where @@ -82,6 +84,22 @@ listen' = fmap swap . S.listen {-# INLINE listen' #-} censor' = S.censor + {-# INLINE censor' #-} + +instance (Monad m, Monoid w) => Writer' tag w (Lazy.RWST r w s m) where + tell' = Lazy.tell + {-# INLINE tell' #-} + listen' = fmap swap . Lazy.listen + {-# INLINE listen' #-} + censor' = Lazy.censor + {-# INLINE censor' #-} + +instance (Monad m, Monoid w) => Writer' tag w (Strict.RWST r w s m) where + tell' = Strict.tell + {-# INLINE tell' #-} + listen' = fmap swap . Strict.listen + {-# INLINE listen' #-} + censor' = Strict.censor {-# INLINE censor' #-} -- | Executes a sub-computation and applies the function to its output, thus adding