effet 0.3.0.2 → 0.4.0.0

raw patch · 28 files changed

+792/−696 lines, 28 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−1
• README.md +8/−6
• effet.cabal +4/−4
• examples/Example/FileSystem.hs +1/−1
• examples/Example/Managed.hs +8/−9
• examples/Example/RWS.hs +17/−9
• examples/Example/Resource.hs +8/−9
• src/Control/Effect/Cont.hs +12/−16
• src/Control/Effect/Embed.hs +2/−6
• src/Control/Effect/Error.hs +4/−12
• src/Control/Effect/Identity.hs +2/−0
• src/Control/Effect/Machinery/TH.hs +579/−358
• src/Control/Effect/Machinery/Via.hs +26/−8
• src/Control/Effect/Managed.hs +8/−10
• src/Control/Effect/Map.hs +6/−27
• src/Control/Effect/Map/Lazy.hs +29/−7
• src/Control/Effect/Map/Strict.hs +29/−7
• src/Control/Effect/RWS.hs +1/−65
• src/Control/Effect/RWS/Lazy.hs +3/−15
• src/Control/Effect/RWS/Strict.hs +2/−14
• src/Control/Effect/Reader.hs +4/−12
• src/Control/Effect/Resource.hs +9/−20
• src/Control/Effect/State.hs +5/−21
• src/Control/Effect/State/Lazy.hs +3/−15
• src/Control/Effect/State/Strict.hs +3/−15
• src/Control/Effect/Writer.hs +4/−10
• src/Control/Effect/Writer/Lazy.hs +3/−10
• src/Control/Effect/Writer/Strict.hs +2/−9

@@ -21,4 +21,13 @@ 
 ## 0.3.0.2 (2020-10-21)
 
-* Added Control.Effect.Identity for pure effect interpretations.+* Added Control.Effect.Identity for pure effect interpretations.
+
+## 0.4.0.0 (2020-12-24)
+
+* Effects can now have different super classes than Monad (examples: Managed and Resource effects, which have MonadIO).
+* Effects can now have other effects as super classes (example: RWS effect).
+* Fixed various presentation issues with TH-generated code.
+* Untagged functions can now be generated from tagged functions using "makeUntagged" and "makeUntaggedWith", which heavily reduces code duplication.
+* Restructured Haddock documentation for better presentation.
+* Added more test cases.

@@ -138,9 +138,15 @@ 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:+We can also let `effet` generate the untagged version of `runLocalFileSystem`, so we don't have to write it by hand:  ```haskell+makeUntagged ['runLocalFileSystem']+```++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)@@ -154,12 +160,9 @@ runVirtualFileSystem' :: (FileSystem' tag `Via` VirtualFS) m a -> m a runVirtualFileSystem' = coerce -runVirtualFileSystem :: (FileSystem `Via` VirtualFS) m a -> m a-runVirtualFileSystem = runVirtualFileSystem' @G+makeUntagged ['runVirtualFileSystem'] ``` -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:@@ -285,5 +288,4 @@ ## Limitations and Remarks  * `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.

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: fd88a66a694dc0a14a3ea183cf0b921a1df3c88288a96e0410b5f548c9b3ff5d+-- hash: ffe68db8c6d675cf3fe231bfb39afc61fb46480297a4f27060e925180f7eb8a8  name:           effet-version:        0.3.0.2+version:        0.4.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@@ -56,7 +56,7 @@       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+  default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators UndecidableInstances   ghc-options: -Wall   build-depends:       base >=4.7 && <5@@ -87,7 +87,7 @@       Paths_effet   hs-source-dirs:       examples-  default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators UndecidableInstances+  default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeFamilies TypeOperators UndecidableInstances   ghc-options: -Wall   build-depends:       base >=4.7 && <5

@@ -15,7 +15,7 @@ import Control.Effect.Identity
 import Control.Effect.Machinery
 import Control.Effect.Map
-import Control.Effect.Map.Strict
+import Control.Effect.Map.Strict hiding (lookup)
 
 import Example.Logger
 import Hspec (shouldPrint)

@@ -2,8 +2,7 @@ module Example.Managed where
 
 -- base
-import Control.Monad.IO.Class (MonadIO)
-import Prelude         hiding (print)
+import Prelude hiding (print)
 
 -- hspec
 import Test.Hspec (Spec, it)
@@ -20,14 +19,14 @@ newtype Handle = Handle { nameOf :: String }
 
 -- | Gets a managed virtual handle specified by a name.
-getHandle :: (Managed m, MonadIO m) => String -> m Handle
+getHandle :: Managed m => String -> m Handle
 getHandle name = manage
   ( print ("Alloc " ++ name) >> pure (Handle name) )
   ( \handle -> print $ "Free " ++ nameOf handle )
 
 -- | Simple program that makes use of two handles. Handles are destroyed
 -- automatically at the end of the program.
-useHandles :: (Managed m, MonadIO m) => m ()
+useHandles :: Managed m => m ()
 useHandles = do
   a <- getHandle "A"
   b <- getHandle "B"
@@ -35,7 +34,7 @@   print $ "Use " ++ nameOf b
 
 -- | Allocates some handlers, then throws an error.
-throwCheck :: (Error String m, Managed m, MonadIO m) => m ()
+throwCheck :: (Error String m, Managed m) => m ()
 throwCheck = do
   a <- getHandle "A"
   b <- getHandle "B"
@@ -50,13 +49,13 @@   it "manages a handle" $
     ( runManaged      -- result:  (MonadBaseControl IO m, MonadIO m) => m (),
                       --          unified with IO ()
-    $ getHandle "X" ) -- effects: Managed, MonadIO
+    $ getHandle "X" ) -- effects: Managed
       `shouldPrint`
         "\"Alloc X\"\n\"Free X\"\n"
   it "manages multiple handles" $
     ( runManaged      -- result:  (MonadBaseControl IO m, MonadIO m) => m (),
                       --          unified with IO ()
-    $ useHandles )    -- effects: Managed, MonadIO
+    $ useHandles )    -- effects: Managed
       `shouldPrint`
         (  "\"Alloc A\"\n"
         ++ "\"Alloc B\"\n"
@@ -68,8 +67,8 @@   it "manages multiple handles with an error" $
     ( runManaged      -- result:  (MonadBaseControl IO m, MonadIO m) => m (Either String ()),
                       --          unified with IO (Either String ())
-    . runError        -- effects: Managed, MonadIO
-    $ throwCheck )    -- effects: Error String, Managed, MonadIO
+    . runError        -- effects: Managed
+    $ throwCheck )    -- effects: Error String, Managed
       `shouldPrint`
         (  "\"Alloc A\"\n"
         ++ "\"Alloc B\"\n"

@@ -35,18 +35,26 @@ 
 spec :: Spec
 spec = do
+  it "tags and retags the effect" $
+    ( runIdentity         -- result:  (Sum Int, Int, (Int, Int, Int))
+    . L.runRWS' @"b" 10 8 -- result:  Monad m => m (Sum Int, Int, (Int, Int, Int))
+    . retagRWS' @"a" @"b" -- effects: RWS "b" Int (Sum Int) Int
+    . tagRWS' @"a"        -- effects: RWS "a" Int (Sum Int) Int
+    $ combineRWS )        -- effects: RWS Int (Sum Int) Int
+      `shouldBe`
+        (Sum 18, 9, (30, 13, 9))
   it "combines reader/write/state test cases" $
-    ( runIdentity     -- result:  (Sum Int, Int, (Int, Int, Int))
-    . L.runRWS 20 5   -- result:  Monad m => m (Sum Int, Int, (Int, Int, Int))
-    $ combineRWS )    -- effects: RWS Int (Sum Int) Int
+    ( runIdentity         -- result:  (Sum Int, Int, (Int, Int, Int))
+    . L.runRWS 20 5       -- result:  Monad m => m (Sum Int, Int, (Int, Int, Int))
+    $ combineRWS )        -- effects: RWS Int (Sum Int) Int
       `shouldBe`
         (Sum 18, 6, (60, 13, 6))
   it "separates reader/write/state components" $
-    ( runIdentity     -- result:  (Int, (Sum Int, (Int, Int, Int)))
-    . L.runState 3    -- result:  Monad m => m (Int, (Sum Int, (Int, Int, Int)))
-    . S.runWriter     -- effects: State Int
-    . runReader 15    -- effects: Writer (Sum Int), State Int
-    . runSeparatedRWS -- effects: Reader Int, Writer (Sum Int), State Int
-    $ combineRWS )    -- effects: RWS Int (Sum Int) Int
+    ( runIdentity         -- result:  (Int, (Sum Int, (Int, Int, Int)))
+    . L.runState 3        -- result:  Monad m => m (Int, (Sum Int, (Int, Int, Int)))
+    . S.runWriter         -- effects: State Int
+    . runReader 15        -- effects: Writer (Sum Int), State Int
+    . runSeparatedRWS     -- effects: Reader Int, Writer (Sum Int), State Int
+    $ combineRWS )        -- effects: RWS Int (Sum Int) Int
       `shouldBe`
         (4, (Sum 18, (45, 13, 4)))

@@ -3,8 +3,7 @@ 
 -- base
 import qualified Control.Exception as E
-import Control.Monad.IO.Class (MonadIO)
-import Prelude         hiding (print)
+import Prelude hiding (print)
 
 -- hspec
 import Test.Hspec (Spec, it)
@@ -21,7 +20,7 @@ newtype Handle = Handle { nameOf :: String }
 
 -- | Simple bracket with print outputs.
-aBracket :: (MonadIO m, Resource m) => String -> m ()
+aBracket :: Resource m => String -> m ()
 aBracket name = do
   bracket
     ( print ("Alloc " ++ name) >> pure (Handle name) )
@@ -29,7 +28,7 @@     ( \handle -> print $ "Use "  ++ nameOf handle )
 
 -- | Simple bracket with print outputs.
-aBracketOnError :: (MonadIO m, Resource m) => String -> m ()
+aBracketOnError :: Resource m => String -> m ()
 aBracketOnError name = do
   bracketOnError
     ( print ("Alloc " ++ name) >> pure (Handle name) )
@@ -37,7 +36,7 @@     ( \handle -> print $ "Use "  ++ nameOf handle )
 
 -- | Bracket where the usage function throws an ArrayException.
-errorBracket :: (Error String m, MonadIO m, Resource m) => String -> m ()
+errorBracket :: (Error String m, Resource m) => String -> m ()
 errorBracket name = do
   bracket
     ( print ("Alloc " ++ name) >> pure (Handle name) )
@@ -51,20 +50,20 @@   it "evaluates a bracket" $
     ( runResourceIO         -- result:  (MonadBaseControl IO m, MonadIO m) => m (),
                             --          unified with IO ()
-    $ aBracket "X" )        -- effects: MonadIO, Resource
+    $ aBracket "X" )        -- effects: Resource
       `shouldPrint`
         "\"Alloc X\"\n\"Use X\"\n\"Free X\"\n"
   it "evaluates a bracket without freeing" $
     ( runResourceIO         -- result:  (MonadBaseControl IO m, MonadIO m) => m (),
                             --          unified with IO ()
-    $ aBracketOnError "X" ) -- effects: MonadIO, Resource
+    $ aBracketOnError "X" ) -- effects: Resource
       `shouldPrint`
         "\"Alloc X\"\n\"Use X\"\n"
   it "evaluates a bracket with an error" $
     ( runResourceIO         -- result:  (MonadBaseControl IO m, MonadIO m) => m (Either String ()),
                             --          unified with IO (Either String ())
-    . runError              -- effects: MonadIO, Resource
-    $ errorBracket "X" )    -- effects: Error String, MonadIO, Resource
+    . runError              -- effects: Resource
+    $ errorBracket "X" )    -- effects: Error String, Resource
       `E.catch`
         ( \(_ :: E.ArrayException) -> pure (Left "Intended error") )
       `shouldPrint`

@@ -21,10 +21,10 @@   , Cont   , callCC     -- * Interpretations-  , runCont'-  , runCont   , evalCont'   , evalCont+  , runCont'+  , runCont     -- * Tagging and Untagging     -- | Conversion functions between the tagged and untagged continuation effect,     -- usually used in combination with type applications, like:@@ -68,7 +68,7 @@ makeFinder  ''Cont' makeTagger  ''Cont' -instance Control (Cont' tag) t m => Cont' tag (EachVia '[] t m) where+instance Control '[] (Cont' tag) t m => Cont' tag (EachVia '[] t m) where   callCC' f =     liftWith       ( \run -> callCC' @tag $ \c -> run . f $@@ -81,22 +81,18 @@   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' #-} +-- | 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 'evalCont''.-evalCont :: Applicative m => (Cont `Via` C.ContT r) m r -> m r-evalCont = evalCont' @G-{-# INLINE evalCont #-}+makeUntagged ['evalCont']++-- | The untagged version of 'runCont''.+makeUntagged ['runCont']

@@ -113,9 +113,7 @@ {-# INLINE runEmbed' #-}  -- | The untagged version of 'runEmbed''.-runEmbed :: (forall b. n b -> t b) -> (Embed n `Via` Transformation n t) m a -> m a-runEmbed = runEmbed' @G-{-# INLINE runEmbed #-}+makeUntagged ['runEmbed']  -- | The finalization interpreter of the embed effect. This type implements the -- 'Embed' type class by declaring the integrated monad the final monad @m@@@ -150,6 +148,4 @@ -- | The untagged version of 'runFinal''. -- -- @since 0.3.0.0-runFinal :: (Embed m `Via` Finalization) m a -> m a-runFinal = runFinal' @G-{-# INLINE runFinal #-}+makeUntagged ['runFinal']

@@ -14,6 +14,8 @@ module Control.Effect.Error   ( -- * Tagged Error Effect     Error'(..)+    -- * Convenience Functions+  , liftEither'     -- * 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),@@ -21,11 +23,6 @@   , 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'@@ -75,10 +72,7 @@ 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 #-}+makeUntagged ['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)@@ -86,6 +80,4 @@ {-# INLINE runError' #-}  -- | The untagged version of 'runError''.-runError :: (Error e `Via` ExceptT e) m a -> m (Either e a)-runError = coerce-{-# INLINE runError #-}+makeUntagged ['runError']

@@ -22,6 +22,8 @@ -- -- You usually need this when an expression of type @Monad m => m a@ remains -- after handling all the effects and you want to extract its pure result.+--+-- @since 0.3.0.2 runIdentity :: I.Identity a -> a runIdentity = I.runIdentity {-# INLINE runIdentity #-}

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP             #-} {-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- |@@ -22,6 +23,8 @@   , makeTaggedEffectWith   , makeTagger   , makeTaggerWith+  , makeUntagged+  , makeUntaggedWith     -- * Lifting Convenience   , liftL   , runL@@ -30,10 +33,11 @@   ) where  -- base-import Control.Monad (forM, replicateM)-import Data.Coerce   (coerce)-import Data.List     (isSuffixOf)-import Data.Maybe    (maybeToList)+import Control.Monad          (forM, replicateM)+import Control.Monad.IO.Class (MonadIO)+import Data.Coerce            (coerce)+import Data.List              (isSuffixOf)+import Data.Maybe             (catMaybes, maybeToList)  -- monad-control import Control.Monad.Trans.Control (liftWith, restoreT)@@ -46,34 +50,18 @@ import Control.Monad.Trans.Class (lift)  import Control.Effect.Machinery.Tagger (Tagger(..), runTagger)-import Control.Effect.Machinery.Via    (Control, EachVia(..), Find, G, Handle, Lift,-                                        Via, runVia)--data ClassInfo = ClassInfo-  { clsCxt     :: Cxt-  , clsName     :: Name-  , clsTyVars   :: [TyVarBndr]-  , _clsFunDeps :: [FunDep]-  , clsDecs     :: [Dec]-  }+import Control.Effect.Machinery.Via    (Control, EachVia(..), Find, G, Handle,+                                        Lift, Via, runVia) +-----------------------------------------+-- Information about effect type classes.+----------------------------------------- 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]+  { effCxts    :: [Type]+  , effName    :: Name+  , effParams  :: [TyVarBndr]+  , effMonad   :: TyVarBndr+  , effMethods :: [Signature]   }  data Signature = Signature@@ -81,135 +69,22 @@   , 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+-- Given a type class name, extracts infos about an effect.+effectInfo :: Name -> Q EffectInfo+effectInfo className = do   info <- reify className   case info of-    ClassI (ClassD context name tyVars funDeps decs) _ ->-      pure (ClassInfo context name tyVars funDeps decs)+    ClassI (ClassD cxts name tyVars _ decs) _ -> do+      (params, monad) <-+        case tyVars of+          [] -> fail+                  $  "The specified effect type class `"+                  ++ nameBase name+                  ++ "' has no monad type variable. "+                  ++ "It is expected to be the last type variable."+          vs -> pure (init vs, last vs)+      let sigs = [Signature n t | SigD n t <- decs]+      pure $ EffectInfo cxts name params monad sigs     other ->       fail          $ "The specified name `"@@ -217,35 +92,64 @@         ++ "' 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)-  ]+-- Constructs the type of an effect, i.e. the type class+-- without its monad parameter.+effectType :: EffectInfo -> Q Type+effectType info =+  foldl+    ( appT )+    ( conT $ effName info )+    ( fmap tyVarType (effParams info) ) -instanceCxt :: Name -> EffectInfo -> Q Cxt-instanceCxt name info = cxt-  [-    conT name-      `appT` effType info-      `appT` varT (effTrafoName info)-      `appT` tyVarType (effMonad info)-  ]+-- Extracts the super classes of an effect which have the+-- kind of effects. As an example, for the following effect ...+--+-- class (State s m, Monad m) => MyEffect s m where ...+--+-- ... this would return [State s, Monad].+superEffects :: EffectInfo -> [Type]+superEffects info =+  catMaybes $ fmap extract (effCxts info)+    where+      m = tyVarName (effMonad info)+      extract = \case+        ForallT _ _ t -> extract t+        SigT t _      -> extract t+        ParensT t     -> extract t+        t `AppT` VarT n      | n == m -> Just t+        InfixT t _ (VarT n)  | n == m -> Just t+        UInfixT t _ (VarT n) | n == m -> Just t+#if __GLASGOW_HASKELL__ >= 808+        AppKindT t _ -> extract t+        ImplicitParamT _ t -> extract t+#endif+        _ -> Nothing -instanceHead :: Q Type -> EffectInfo -> Q Type-instanceHead effs info =-  effType info-    `appT` (-      conT ''EachVia-        `appT` effs-        `appT` varT (effTrafoName info)-        `appT` tyVarType (effMonad info)-      )+-- Like superEffects, but ignores super classes from base+-- (i.e., Applicative, Functor, Monad, MonadIO).+superEffectsWithoutBase :: EffectInfo -> [Type]+superEffectsWithoutBase =+  filter (not . isBase) . superEffects +    where+      isBase = \case+        ConT n -> n `elem` [''Applicative, ''Functor, ''Monad, ''MonadIO]+        _ -> False +-------------------------------------------------+-- Tagging information about effect type classes.+-------------------------------------------------+data TaggedInfo = TaggedInfo+  { tgTag    :: TyVarBndr+  , tgParams :: [TyVarBndr]+  }++-- Given an effect, extracts infos about the tag parameter.+taggedInfo :: EffectInfo -> Q TaggedInfo+taggedInfo info =+  case effParams info of+    []     -> fail "The effect has no tag parameter."+    (v:vs) -> pure $ TaggedInfo v vs+ -- | Generates the effect handling and lifting infrastructure for an effect which -- does not have a tag type parameter. Requires the @TemplateHaskell@ language -- extension.@@ -287,12 +191,12 @@ -- 'makeLifter'. makeEffect :: Name -> Q [Dec] makeEffect className = do-  clsInfo   <- classInfo className-  effInfo   <- effectInfo clsInfo+  effInfo   <- effectInfo className   hInstance <- handler effInfo   fInstance <- finder effInfo   lInstance <- lifter effInfo-  pure [hInstance, fInstance, lInstance]+  tInstance <- identityTaggerInstance effInfo+  pure [hInstance, fInstance, lInstance, tInstance]  -- | Similar to 'makeTaggedEffect', but only generates the tag-related definitions. makeTagger :: Name -> Q [Dec]@@ -300,11 +204,11 @@  -- | 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+makeTaggerWith mapping className = do+  let f = fmap mkName . mapping . nameBase+  effInfo <- effectInfo className+  tagInfo <- taggedInfo effInfo+  tagger f effInfo 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@@ -358,22 +262,56 @@ -- 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+makeTaggedEffectWith mapping className = do+  let f = fmap mkName . mapping . nameBase+  effInfo    <- effectInfo className+  tagInfo    <- taggedInfo effInfo   hInstance  <- handler effInfo   fInstance  <- finder effInfo   lInstance  <- lifter effInfo-  taggerDecs <- tagger tagInfo+  taggerDecs <- tagger f effInfo tagInfo   pure (hInstance : fInstance : lInstance : taggerDecs) +-- | Given a list of function names, this function generates untagged versions+-- of them, i.e. it removes the tag type parameters  from their type signatures+-- (by applying 'G') and converts tagged effect type classes found in the+-- signature to their corresponding untagged type synonyms using 'removeApostrophe'.+--+-- @since 0.4.0.0+makeUntagged :: [Name] -> Q [Dec]+makeUntagged = makeUntaggedWith removeApostrophe++-- | Similar to 'makeUntagged', but allows to define a naming convention function+-- for the names of the generated functions and the effect type classes modified+-- in the type signatures.+--+-- The default naming convention is enforced by 'removeApostrophe', which simply+-- removes the apostrophe \"'\" at the end of a name.+--+-- @since 0.4.0.0+makeUntaggedWith :: (String -> Q String) -> [Name] -> Q [Dec]+makeUntaggedWith mapping names =+  let f = fmap mkName . mapping . nameBase in+  fmap concat $ forM names $ \name -> do+    info <- reify name+    case info of+      VarI funName typ _ -> do+        tag <- findTagParameter typ+        genName <- f funName+        funSig <- sigD genName $ replaceTag f tag typ+        funDef <- [d| $(varP genName) = $(varE funName) @G |]+        funInline <- pragInlD genName Inline FunLike AllPhases+        pure (funSig : funInline : funDef)+      other ->+        fail+           $ "Expected a function for name " ++ nameBase name+          ++ ", but encountered: " ++ show other+ -- | 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+  effInfo   <- effectInfo className   hInstance <- handler effInfo   pure [hInstance] @@ -383,8 +321,7 @@ -- @since 0.2.0.0 makeFinder :: Name -> Q [Dec] makeFinder className = do-  clsInfo   <- classInfo className-  effInfo   <- effectInfo clsInfo+  effInfo   <- effectInfo className   fInstance <- finder effInfo   pure [fInstance] @@ -392,17 +329,16 @@ -- for lifting an effect. makeLifter :: Name -> Q [Dec] makeLifter className = do-  clsInfo   <- classInfo className-  effInfo   <- effectInfo clsInfo+  effInfo   <- effectInfo className   lInstance <- lifter effInfo   pure [lInstance] -tagger :: TaggedInfo -> Q [Dec]-tagger info = do-  taggerFuns   <- taggerFunctions info-  untaggedSyn  <- untaggedSynonym info-  untaggedFuns <- untaggedFunctions info-  taggerInst   <- taggerInstance info+tagger :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]+tagger f effInfo tagInfo = do+  taggerFuns   <- taggerFunctions effInfo tagInfo+  untaggedSyn  <- untaggedSynonym f effInfo tagInfo+  untaggedFuns <- untaggedFunctions f effInfo tagInfo+  taggerInst   <- taggerInstance effInfo tagInfo   pure     $ untaggedSyn     : taggerInst@@ -411,125 +347,197 @@  handler :: EffectInfo -> Q Dec handler info = do-  funs <- handlerFunctions info-  effs <- newName "effs"+  funs   <- handlerFunctions info+  others <- newName "others"+  trafo  <- newName "t"   instanceD-    ( instanceCxt ''Handle info )-    ( instanceHead (promotedConsT `appT` effType info `appT` varT effs) info )+    ( instanceHandleCxt others trafo )+    ( instanceHead (promotedConsT `appT` effectType info `appT` varT others) trafo info )     ( fmap pure funs )+  where+    instanceHandleCxt :: Name -> Name -> Q Cxt+    instanceHandleCxt others trafo = cxt+      [+        conT ''Handle+          `appT` typeLevelList (fmap pure $ superEffects info)+          `appT` effectType info+          `appT` varT others+          `appT` varT trafo+          `appT` tyVarType (effMonad info)+      ]  finder :: EffectInfo -> Q Dec finder info = do   funs  <- finderFunctions info   other <- newName "other"   effs  <- newName "effs"+  trafo <- newName "t"   instanceWithOverlapD     ( Just Overlappable )-    ( instanceFinderCxt ''Find effs info )-    ( instanceHead (promotedConsT `appT` varT other `appT` varT effs) info )+    ( instanceFinderCxt other effs trafo )+    ( instanceHead (promotedConsT `appT` varT other `appT` varT effs) trafo info )     ( fmap pure funs )+  where+    instanceFinderCxt :: Name -> Name -> Name -> Q Cxt+    instanceFinderCxt other effs trafo = cxt+      [+        conT ''Find+          `appT` typeLevelList (fmap pure $ superEffects info)+          `appT` effectType info+          `appT` varT other+          `appT` varT effs+          `appT` varT trafo+          `appT` tyVarType (effMonad info)+      ]  lifter :: EffectInfo -> Q Dec lifter info = do   let     monad = effMonad info-    context =-      if any (isHigherOrder monad) (effSigs info)+    liftType =+      if any (isHigherOrder monad) (effMethods info)       then ''Control       else ''Lift-  funs <- lifterFunctions info+  funs  <- lifterFunctions info+  trafo <- newName "t"   instanceD-    ( instanceCxt context info )-    ( instanceHead promotedNilT info )+    ( instanceLiftControlCxt liftType trafo )+    ( instanceHead promotedNilT trafo info )     ( fmap pure funs )+  where+    instanceLiftControlCxt :: Name -> Name -> Q Cxt+    instanceLiftControlCxt name trafo = cxt+      [+        conT name+          `appT` typeLevelList (fmap pure $ superEffects info)+          `appT` effectType info+          `appT` varT trafo+          `appT` tyVarType (effMonad info)+      ] -taggerFunctions :: TaggedInfo -> Q [Dec]-taggerFunctions info = do-  let params       = tgParams info-      tagVar       = tgTag info-      effectName   = tgEffName info-      nameString   = nameBase effectName+instanceHead :: Q Type -> Name -> EffectInfo -> Q Type+instanceHead effs trafo info =+  effectType info+    `appT` (+      conT ''EachVia+        `appT` effs+        `appT` varT trafo+        `appT` tyVarType (effMonad info)+      )++taggerFunctions :: EffectInfo -> TaggedInfo -> Q [Dec]+taggerFunctions effInfo tagInfo = do+  let tagVar       = tgTag tagInfo+      nameString   = nameBase (effName effInfo)       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+  tagF   <- taggerFunction tagFName effInfo tagInfo Nothing (Just new)+  retagF <- taggerFunction retagFName effInfo tagInfo (Just tagVar) (Just new)+  untagF <- taggerFunction untagFName effInfo tagInfo (Just tagVar) Nothing   pure $     tagF ++ retagF ++ untagF--taggerFunction :: Name -> Name -> Maybe Name -> Maybe Name -> [TyVarBndr] -> Q [Dec]-taggerFunction baseName funName tag new params = do+  +taggerFunction :: Name -> EffectInfo -> TaggedInfo -> Maybe TyVarBndr -> Maybe Name -> Q [Dec]+taggerFunction funName effInfo tagInfo tag new = do   mName <- newName "m"   aName <- newName "a"+  gType <- [t| G |]   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+      params      = tgParams tagInfo+      tagParam    = maybe (pure gType) (varT . tyVarName) tag+      newParam    = maybe (pure gType) varT new+      tagVars     = maybeToList tag ++ maybeToList (fmap PlainTV new)+      forallVars  = fmap unkindTyVar (tagVars ++ params) ++ [PlainTV mName, PlainTV aName]       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+      effType     = foldl appT (conT $ effName effInfo) (tagParam : paramTypes)+      effList     = effType : fmap pure (superEffectsWithoutBase effInfo)+      untagList =+        case tag of+            Nothing -> fmap (fmap (replace (tyVarName $ tgTag tagInfo) gType)) effList+            Just _  -> effList+      taggerType = [t| Tagger $tagParam $newParam |]+      viaType =+        case untagList of+#if __GLASGOW_HASKELL__ >= 808+          [e] -> uInfixT e ''Via taggerType+          es  -> uInfixT (typeLevelList es) ''EachVia taggerType+#else+          [e] -> conT ''Via `appT` e `appT` taggerType+          es  -> conT ''EachVia `appT` typeLevelList es `appT` taggerType+#endif+      funSigType = [t| $viaType $m $a -> $m $a |]+  funSig    <- sigD funName $ forallT forallVars (cxt []) funSigType+  funDef    <- [d| $(varP funName) = runTagger . runVia |]+  funInline <- pragInlD funName Inline FunLike AllPhases   pure (funSig : funInline : funDef)+    where+      replace :: Name -> Type -> Type -> Type+      replace oldTag newTag = \case+        ConT n `AppT` VarT param | param == oldTag -> ConT n `AppT` newTag+        ForallT vars ctx t -> ForallT vars ctx (replace oldTag newTag t)+        AppT l r           -> AppT (replace oldTag newTag l) r+        SigT t k           -> SigT (replace oldTag newTag t) k+        InfixT l n r       -> InfixT (replace oldTag newTag l) n (replace oldTag newTag r)+        UInfixT l n r      -> UInfixT (replace oldTag newTag l) n (replace oldTag newTag r)+        ParensT t          -> ParensT (replace oldTag newTag t)+#if __GLASGOW_HASKELL__ >= 808+        AppKindT t k -> AppKindT (replace oldTag newTag t) k+        ImplicitParamT s t -> ImplicitParamT s (replace oldTag newTag t)+#endif+        other              -> other -untaggedSynonym :: TaggedInfo -> Q Dec-untaggedSynonym info = do-  synName <- synonymName info+untaggedSynonym :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q Dec+untaggedSynonym f effInfo tagInfo = do+  synName <- f (effName effInfo)   tySynD     ( synName )     ( params  )-    ( foldl appT (conT effectName) (conT ''G : fmap tyVarType params) )+    ( foldl appT (conT $ effName effInfo) (conT ''G : fmap tyVarType params) )   where-    effectName = tgEffName info-    params     = fmap unkindTyVar (tgParams info)+    params = fmap unkindTyVar (tgParams tagInfo) -untaggedFunctions :: TaggedInfo -> Q [Dec]-untaggedFunctions info = do-  synName <- synonymName info+untaggedFunctions :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]+untaggedFunctions f effInfo tagInfo = do+  synName <- f (effName effInfo)   fmap concat $-    forM (tgSigs info)-      $ untaggedFunction (tgNameMap info)+    forM (effMethods effInfo)+      $ untaggedFunction f       $ foldl           ( appT         )           ( conT synName )-          ( fmap (tyVarType . unkindTyVar) $ tgParams info ++ [tgMonad info] )+          ( fmap (tyVarType . unkindTyVar) $ tgParams tagInfo ++ [effMonad effInfo] ) -untaggedFunction :: (String -> Q String) -> Q Type -> Signature -> Q [Dec]-untaggedFunction f effectType sig = do+untaggedFunction :: (Name -> Q Name) -> Q Type -> Signature -> Q [Dec]+untaggedFunction f effType sig = do   let originalName = sigName sig       signatureBody = pure (unkindType $ sigType sig)-  funName   <- mapName f originalName-  funSig    <- sigD funName [t| $effectType => $signatureBody |]+  funName   <- f originalName+  funSig    <- sigD funName [t| $effType => $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+taggerInstance :: EffectInfo -> TaggedInfo -> Q Dec+taggerInstance effInfo tagInfo = do   newTagName <- newName "new"   let new = varT newTagName-      monadName = tyVarName (tgMonad info)+      monadName = tyVarName (effMonad effInfo)       m = varT monadName-      tag = tyVarType (tgTag info)-      effectType = conT $ tgEffName info-      paramTypes = fmap tyVarType (tgParams info)+      tag = tyVarType (tgTag tagInfo)+      effType = conT (effName effInfo)+      paramTypes = fmap tyVarType (tgParams tagInfo)       taggerType = [t| Tagger $tag $new $m |]       cxtParams  = new : paramTypes ++ [m]       headParams = tag : paramTypes ++ [taggerType]   funs <-     fmap concat $-      forM (tgSigs info) $ taggerInstanceFunction new monadName+      forM (effMethods effInfo) $ taggerInstanceFunction new monadName   instanceD-    ( cxt [foldl appT effectType cxtParams] )-    ( foldl appT effectType headParams )+    ( cxt [foldl appT effType cxtParams] )+    ( foldl appT effType headParams )     ( fmap pure funs )  taggerInstanceFunction :: Q Type -> Name -> Signature -> Q [Dec]@@ -542,59 +550,52 @@   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."+identityTaggerInstance :: EffectInfo -> Q Dec+identityTaggerInstance info = do+  oldTagName <- newName "tag"+  newTagName <- newName "new"+  let old = varT oldTagName+      new = varT newTagName+      monadName = tyVarName (effMonad info)+      m = varT monadName+      effType = conT $ effName info+      paramTypes = fmap tyVarType (effParams info)+      taggerType = [t| Tagger $old $new $m |]+      cxtParams  = paramTypes ++ [m]+      headParams = paramTypes ++ [taggerType]+  funs <-+    fmap concat $+      forM (effMethods info) $+        function [| Tagger |] [| runTagger |] (effMonad info) (effParams info)+  instanceD+    ( cxt [foldl appT effType cxtParams] )+    ( foldl appT effType headParams )+    ( fmap pure funs )  handlerFunctions :: EffectInfo -> Q [Dec] handlerFunctions info =   fmap concat $     mapM       ( 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 #-}+      ( effMethods info )  finderFunctions :: EffectInfo -> Q [Dec] finderFunctions info =   fmap concat $     mapM       ( function [| liftL |] [| runL |] (effMonad info) (effParams info) )-      ( effSigs info )+      ( effMethods info )  lifterFunctions :: EffectInfo -> Q [Dec] lifterFunctions info =   let m = effMonad info       params = effParams info+      invalid = fail+         $ "Could not generate effect instance because the operation is "+        ++ "invalid for higher-order effects."   in   fmap concat $-    forM (effSigs info) $ \sig ->+    forM (effMethods info) $ \sig ->       if isHigherOrder m sig       then higherFunction m params sig       else function [| lift |] invalid m params sig@@ -619,75 +620,295 @@       restores = restorables False m typ       expr = derive restores [| id |] [| run . runVia |] m typ   fParams <- replicateM (paramCount typ) (newName "x")    -  res     <- resultType m typ+  resType <- resultType m typ   let typeAppliedName = foldl appTypeE (varE funName) paramTypes       appliedExp = foldl appE expr (typeAppliedName : fmap varE fParams)       body =         [| EachVia $             (liftWith $ \ $([p|run|]) -> $appliedExp)-              >>= $(traverseExp res) (restoreT . pure)+              >>= $(traverseExp resType) (restoreT . pure)         |]   funDef    <- funD funName [clause (fmap varP fParams) (normalB body) []]   funInline <- pragInlD funName Inline FunLike AllPhases   pure [funDef, funInline]+  where+    restorables :: Bool -> Name -> Type -> [Type]+    restorables neg m = \case+      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+#if __GLASGOW_HASKELL__ >= 808+      AppKindT t _ -> restorables neg m t+      ImplicitParamT _ t -> restorables neg m t+#endif+      other -> fail+        $  "Encountered an unknown term when finding restorables: "+        ++ show other+    traverseExp :: Type -> Q Exp+    traverseExp = \case+      ForallT _ _ t -> traverseExp t+      AppT _ r      -> traverseRec r+      SigT t _      -> traverseExp t+      InfixT _ _ r  -> traverseRec r+      UInfixT _ _ r -> traverseRec r+      ParensT t     -> traverseExp t+#if __GLASGOW_HASKELL__ >= 808+      AppKindT t _ -> traverseExp t+      ImplicitParamT _ t -> traverseExp t+#endif+      _             -> [| id |]+      where+        traverseRec t = [| traverse . $(traverseExp t) |] +derive :: [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp+derive rs f inv m = \case+  -- TODO: This is missing some cases - see algorithm of DeriveFunctor.+  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 =<<) . EachVia . restoreT . pure) b) |]+       else [| \x b -> $rf (x ($af b)) |]+  ForallT _ _ t ->+    derive rs f inv m t+#if __GLASGOW_HASKELL__ >= 808+  AppKindT t _ ->+    derive rs f inv m t+  ImplicitParamT _ t ->+    derive rs f inv m t+#endif+  other -> fail+     $ "Could not generate effect instance because an unknown structure "+    ++ "was encountered: "+    ++ show other++---------------------+-- Utility functions.+---------------------++-- Throws away all kind information and forall from a type. 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+unkindType = \case+  -- 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)+#if __GLASGOW_HASKELL__ >= 808+  AppKindT t _ -> unkindType t+  ImplicitParamT s t -> ImplicitParamT s (unkindType t)+#endif+  other         -> other +-- Throws away the kind information of a type variable.+unkindTyVar :: TyVarBndr -> TyVarBndr+unkindTyVar (KindedTV n _) = PlainTV n+unkindTyVar unkinded       = unkinded++-- Returns the name of a type variable.+tyVarName :: TyVarBndr -> Name+tyVarName (PlainTV  n  ) = n+tyVarName (KindedTV n _) = n++-- Converts a type variable to a type.+tyVarType :: TyVarBndr -> Q Type+tyVarType (PlainTV n   ) = varT n+tyVarType (KindedTV n k) = sigT (varT n) k++-- Counts the parameters of a type.+paramCount :: Type -> Int+paramCount = \case+  ArrowT `AppT` _ `AppT` r -> 1 + paramCount r+  ForallT _ _ t            -> paramCount t+  _                        -> 0++-- | 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 #-}++-- | 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 \"'\"."++-- Converts a list of types to a type-level list.+typeLevelList :: [Q Type] -> Q Type+typeLevelList []     = promotedNilT+typeLevelList (t:ts) = promotedConsT `appT` t `appT` typeLevelList ts++-- Returns the result type of a monadic type m.+-- Example: X -> Y -> Z -> m a+-- Returns: a+resultType :: Name -> Type -> Q Type+resultType m = \case+  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+#if __GLASGOW_HASKELL__ >= 808+  AppKindT t _ -> resultType m t+  ImplicitParamT _ t -> resultType m t+#endif+  other -> fail+    $  "Expected a return type of the form 'm a', but encountered: "+    ++ show other++-- Checks if a name m appears somewhere in a type. 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+contains m = \case+  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+#if __GLASGOW_HASKELL__ >= 808+  AppKindT t _ -> contains m t+  ImplicitParamT _ t -> contains m t+#endif+  _             -> 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 =<<) . EachVia . 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+-- Given a monad type variable m and a type, checks if the+-- type is a higher-order type where m is in negative position.+isHigherType :: TyVarBndr -> Type -> Bool+isHigherType monad = go False+  where+    m = tyVarName monad+    go negPos = \case+      VarT n `AppT` _ | n == m -> negPos+      ArrowT `AppT` a `AppT` r ->+        go (not negPos) a || go negPos r+      ForallT _ _ t ->+        go negPos t+      _ ->+        False -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 |]+-- Given a monad type variable m and a signature, checks if its+-- type is a higher-order type where m is in negative position.+isHigherOrder :: TyVarBndr -> Signature -> Bool+isHigherOrder monad = isHigherType monad . sigType++-- Finds the first ("leftmost") type parameter of a type, which+-- is expected to be the tag type parameter.+findTagParameter :: Type -> Q Name+findTagParameter typ =+  case go typ of+    Just n -> pure n+    Nothing ->+      fail $ "Cannot find the tag parameter of the type: " ++ show typ   where-    traverseRec t = [| traverse . $(traverseExp t) |]+    go :: Type -> Maybe Name+    go = \case+      ForallT tyVars ctx t ->+        case filter (not . isStar) tyVars of+          (v:_) -> Just $ tyVarName v+          [] ->+            case catMaybes (fmap go ctx) of+              (n:_) -> Just n+              [] -> go t+      AppT l r ->+        case go l of+          Just n  -> Just n+          Nothing -> go r+      SigT t _ -> go t+      VarT n -> Just n+      InfixT l _ r ->+        case go l of+          Just n  -> Just n+          Nothing -> go r+      UInfixT l _ r ->+        case go l of+          Just n  -> Just n+          Nothing -> go r+      ParensT t -> go t+#if __GLASGOW_HASKELL__ >= 808+      AppKindT t _ -> go t+      ImplicitParamT _ t -> go t+#endif+      _ -> Nothing+    -- We need this because the first type parameter+    -- is often 'k' for the kind of the tag. We ignore it.+    isStar :: TyVarBndr -> Bool+    isStar (PlainTV _) = True+    isStar (KindedTV _ StarT) = True+    isStar _ = False++-- Replaces the tag parameter with its G-counterpart, simplifying+-- types to their untagged synonym if possible.+replaceTag :: (Name -> Q Name) -> Name -> Type -> Q Type+replaceTag f tag = \case+  -- We eliminate outermost forall variables completely for now,+  -- to make the type signatures more readable.+  -- If we want to preserve it, we might need something+  -- like the line below.+  -- filter (not . (== tag) . tyVarName) tyVars+  ForallT _tyVars cxts t -> go (ForallT [] cxts t)+  other -> go other+  where+    go = \case+      ForallT tyVars cxts t ->+        forallT+          ( fmap unkindTyVar tyVars )+          ( sequence $ fmap go cxts )+          ( go t )+#if __GLASGOW_HASKELL__ >= 808+      ConT n `AppT` eff `AppT` t | n == ''Via || n == ''EachVia ->+        go (UInfixT eff n t)+#endif+      ConT n `AppT` VarT t | t == tag ->+        f n >>= conT+      AppT l r ->+        appT (go l) (go r)+      SigT t _ ->+        go t -- eliminate kinds for readability.+      VarT n | n == tag -> conT ''G+             | otherwise -> varT n+      InfixT l n r ->+        infixT (go l) n (go r)+      UInfixT l n r ->+        uInfixT (go l) n (go r)+      ParensT t ->+        parensT (go t)+#if __GLASGOW_HASKELL__ >= 808+      AppKindT t k ->+        appKindT (go t) (pure k)+      ImplicitParamT s t ->+        implicitParamT s (go t)+#endif+      other ->+        pure other

@@ -31,6 +31,8 @@   , Find
   , Lift
   , Control
+    -- * Convenience Functions
+  , Expand
   ) where
 
 -- base
@@ -101,15 +103,18 @@ 
 -- | This constraint synonym indicates that an effect is handled by a specific monad
 -- transformer.
-type Handle (eff :: Effect) (t :: Transformer) m =
-  eff (t m)
+--
+-- @since 0.4.0.0
+type Handle (cxt :: [Effect]) (eff :: Effect) (others :: [Effect]) (t :: Transformer) m =
+  (eff (t m), Expand cxt (eff ': others) t m)
 
 -- | This constraint 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))
+-- @since 0.4.0.0
+type Find (cxt :: [Effect]) (eff :: Effect) (other :: Effect) (effs :: [Effect]) (t :: Transformer) m =
+  (eff (EachVia effs t m), Expand cxt (other ': 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\")
@@ -121,8 +126,10 @@ -- 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)
+--
+-- @since 0.4.0.0
+type Lift (cxt :: [Effect]) (eff :: Effect) (t :: Transformer) m =
+  (eff m, Expand cxt '[] 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\")
@@ -137,5 +144,16 @@ -- 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)+--
+-- @since 0.4.0.0
+type Control (cxt :: [Effect]) (eff :: Effect) (t :: Transformer) m =
+  (eff m, Expand cxt '[] t m, Monad (t m), MonadTransControl t)
+
+-- | Type-level helper function to apply a list of constraints (i.e., effects)
+-- to 'EachVia'. One should not call this by hand, it will be used by the generated
+-- code or called by 'Handle', 'Find', 'Lift' and 'Control'.
+--
+-- @since 0.4.0.0
+type family Expand (cxt :: [Effect]) (effs :: [Effect]) (t :: Transformer) m :: Constraint where
+  Expand '[] effs t m = ()
+  Expand (cxt ': cxts) effs t m = (cxt (EachVia effs t m), Expand cxts effs t m)

@@ -54,12 +54,12 @@ -- | An effect that allows a computation to allocate resources which are -- guaranteed to be released after the computation. ----- @since 0.3.0.0-class Monad m => Managed' tag m where+-- @since 0.4.0.0+class MonadIO m => Managed' tag m where   -- | Acquire a resource by specifying an acquisition action and a release   -- action to be used for cleanup after the computation.   ---  -- @since 0.3.0.0+  -- @since 0.4.0.0   manage' :: m a        -- ^ The computation which acquires the resource.           -> (a -> m b) -- ^ The computation which releases the resource.           -> m a        -- ^ The acquired resource.@@ -73,13 +73,13 @@ -- When interpreting the effect, you usually don\'t interact with this type directly, -- but instead use one of its corresponding interpretation functions. ----- @since 0.3.0.0+-- @since 0.4.0.0 newtype Bracket n m a = Bracket { runBracket :: ReaderT (IORef [n ()]) m a }   deriving (Applicative, Functor, Monad, MonadIO)   deriving (MonadTrans, MonadTransControl)   deriving (MonadBase b, MonadBaseControl b) -instance MonadBase IO m => Managed' tag (Bracket m m) where+instance (MonadBase IO m, MonadIO m) => Managed' tag (Bracket m m) where   manage' alloc free = Bracket . ReaderT $     \ref -> do       a <- runReaderT (runBracket alloc) ref@@ -91,7 +91,7 @@  -- | Runs the managed effect using 'IO.bracket'. ----- @since 0.3.0.0+-- @since 0.4.0.0 runManaged' :: forall tag m a. MonadBaseControl IO m => (Managed' tag `Via` Bracket m) m a -> m a runManaged' program =   liftedBracket@@ -116,7 +116,5 @@  -- | The untagged version of 'runManaged''. ----- @since 0.3.0.0-runManaged :: MonadBaseControl IO m => (Managed `Via` Bracket m) m a -> m a-runManaged = runManaged' @G-{-# INLINE runManaged #-}+-- @since 0.4.0.0+makeUntagged ['runManaged']

@@ -16,6 +16,11 @@ module Control.Effect.Map   ( -- * Tagged Map Effect     Map'(..)+    -- * Convenience Functions+  , delete'+  , exists'+  , insert'+  , modify'     -- * 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),@@ -24,17 +29,9 @@   , 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,@@ -75,32 +72,17 @@ 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@@ -116,7 +98,4 @@     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 #-}+makeUntagged ['delete', 'exists', 'insert', 'modify']

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Effect.Map.Lazy@@ -14,14 +15,20 @@ -- you usually need the untagged interpretations. ----------------------------------------------------------------------------- module Control.Effect.Map.Lazy-  ( -- * Interpreter Type+  ( -- * Interpreter Implementation     LazyMap+  , clear+  , lookup+  , update     -- * Tagged Interpretations   , runMap'     -- * Untagged Interpretations   , runMap   ) where +-- base+import Prelude hiding (lookup)+ -- containers import qualified Data.Map.Lazy as M @@ -43,13 +50,30 @@     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+  clear' = clear   {-# INLINE clear' #-}-  lookup' = LazyMap . S.gets . M.lookup+  lookup' = lookup   {-# INLINE lookup' #-}-  update' k mv = LazyMap $ S.modify (M.alter (const mv) k)+  update' = update   {-# INLINE update' #-} +-- | Deletes all key-value pairs from the map.+clear :: Monad m => LazyMap k v m ()+clear = LazyMap $ S.put M.empty+{-# INLINE clear #-}++-- | Searches for a value that corresponds to a given key.+-- Returns 'Nothing' if the key cannot be found.+lookup :: (Monad m, Ord k) => k -> LazyMap k v m (Maybe v)+lookup = LazyMap . S.gets . M.lookup+{-# INLINE lookup #-}++-- | Updates the value that corresponds to a given key.+-- Passing 'Nothing' as the updated value removes the key-value pair from the map.+update :: (Monad m, Ord k) => k -> Maybe v -> LazyMap k v m ()+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.@@ -58,6 +82,4 @@ {-# 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 #-}+makeUntagged ['runMap']

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Effect.Map.Strict@@ -14,14 +15,20 @@ -- you usually need the untagged interpretations. ----------------------------------------------------------------------------- module Control.Effect.Map.Strict-  ( -- * Interpreter Type+  ( -- * Interpreter Implementation     StrictMap+  , clear+  , lookup+  , update     -- * Tagged Interpretations   , runMap'     -- * Untagged Interpretations   , runMap   ) where +-- base+import Prelude hiding (lookup)+ -- containers import qualified Data.Map.Strict as M @@ -43,13 +50,30 @@     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+  clear' = clear   {-# INLINE clear' #-}-  lookup' = StrictMap . S.gets . M.lookup+  lookup' = lookup   {-# INLINE lookup' #-}-  update' k mv = StrictMap $ S.modify (M.alter (const mv) k)+  update' = update   {-# INLINE update' #-} +-- | Deletes all key-value pairs from the map.+clear :: Monad m => StrictMap k v m ()+clear = StrictMap $ S.put M.empty+{-# INLINE clear #-}++-- | Searches for a value that corresponds to a given key.+-- Returns 'Nothing' if the key cannot be found.+lookup :: (Monad m, Ord k) => k -> StrictMap k v m (Maybe v)+lookup = StrictMap . S.gets . M.lookup+{-# INLINE lookup #-}++-- | Updates the value that corresponds to a given key.+-- Passing 'Nothing' as the updated value removes the key-value pair from the map.+update :: (Monad m, Ord k) => k -> Maybe v -> StrictMap k v m ()+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.@@ -58,6 +82,4 @@ {-# 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 #-}+makeUntagged ['runMap']

@@ -27,7 +27,6 @@   , runSeparatedRWS'   , runSeparatedRWS     -- * Tagging and Untagging-  , Tagger     -- | Conversion functions between the tagged and untagged RWS effect,     -- usually used in combination with type applications, like:     --@@ -64,18 +63,7 @@ -- @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 -type RWS r w s = RWS' G r w s--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)--instance {-# OVERLAPPABLE #-}-         Find (RWS' tag r w s) effs t m => RWS' tag r w s (EachVia (other : effs) t m)--instance Control (RWS' tag r w s) t m => RWS' tag r w s (EachVia '[] t m)+makeTaggedEffect ''RWS'  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)@@ -134,55 +122,3 @@ 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 IdentityT-    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 m = Tagger (R.local' @new f (runRWSTagger m))-  {-# INLINE local' #-}-  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' m = Tagger (W.listen' @new (runRWSTagger m))-  {-# INLINE listen' #-}-  censor' f m = Tagger (W.censor' @new f (runRWSTagger m))-  {-# INLINE censor' #-}--instance RWS' new r w s m => S.State' tag s (Tagger tag new m) where-  get' = Tagger (S.get' @new)-  {-# INLINE get' #-}-  put' s = Tagger (S.put' @new s)-  {-# INLINE put' #-}-  state' f = Tagger (S.state' @new f)-  {-# INLINE state' #-}--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' #-}--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' #-}

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Effect.RWS.Lazy@@ -27,7 +28,7 @@ -- transformers import Control.Monad.Trans.RWS.Lazy (RWST, runRWST) -import Control.Effect.Machinery (EachVia, G, runVia)+import Control.Effect.Machinery (EachVia, makeUntagged, runVia) import Control.Effect.Reader    (Reader, Reader') import Control.Effect.RWS       (RWS, RWS') import Control.Effect.State     (State, State')@@ -50,11 +51,6 @@     reorder (a, _, w) = (w, a) {-# INLINE evalRWS' #-} --- | The untagged version of 'evalRWS''.-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@@ -72,11 +68,6 @@     reorder (_, s', w) = (w, s') {-# INLINE execRWS' #-} --- | The untagged version of 'execRWS''.-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'@@ -95,7 +86,4 @@     reorder (a, s', w) = (w, s', a) {-# INLINE runRWS' #-} --- | The untagged version of 'runRWS''.-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 #-}+makeUntagged ['evalRWS', 'execRWS', 'runRWS']

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Effect.RWS.Strict@@ -89,11 +90,6 @@     reorder (a, _, w) = (w, a) {-# INLINE evalRWS' #-} --- | The untagged version of 'evalRWS''.-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)@@ -111,11 +107,6 @@     reorder (_, s', w) = (w, s') {-# INLINE execRWS' #-} --- | The untagged version of 'execRWS''.-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)@@ -133,7 +124,4 @@     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, Reader r, Writer w, State s] `EachVia` RWST r w s) m a -> m (w, s, a)-runRWS = runRWS' @G-{-# INLINE runRWS #-}+makeUntagged ['evalRWS', 'execRWS', 'runRWS']

@@ -14,6 +14,8 @@ module Control.Effect.Reader   ( -- * Tagged Reader Effect     Reader'(..)+    -- * Convenience Functions+  , asks'     -- * 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),@@ -22,11 +24,6 @@   , 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'@@ -110,10 +107,7 @@ asks' = reader' @tag {-# INLINE asks' #-} --- | The untagged version of 'asks''.-asks :: Reader r m => (r -> a) -> m a-asks = asks' @G-{-# INLINE asks #-}+makeUntagged ['asks']  -- | Runs the reader effect. runReader' :: forall tag r m a. r                   -- ^ The initial environment.@@ -123,6 +117,4 @@ {-# INLINE runReader' #-}  -- | The untagged version of 'runReader''.-runReader :: r -> (Reader r `Via` R.ReaderT r) m a -> m a-runReader = runReader' @G-{-# INLINE runReader #-}+makeUntagged ['runReader']

@@ -14,6 +14,9 @@ module Control.Effect.Resource   ( -- * Tagged Resource Effect     Resource'(..)+    -- * Convenience Functions+  , finally'+  , onException'     -- * 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),@@ -21,13 +24,7 @@   , 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@@ -56,7 +53,9 @@  -- | 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+--+-- @since 0.4.0.0+class MonadIO 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.@@ -83,11 +82,6 @@   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@@ -99,10 +93,7 @@   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 #-}+makeUntagged ['finally', '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@@ -116,7 +107,7 @@     deriving (MonadTrans, MonadTransControl) via IdentityT     deriving (MonadBase b, MonadBaseControl b) -instance MonadBaseControl IO m => Resource' tag (LowerIO m) where+instance (MonadBaseControl IO m, MonadIO m) => Resource' tag (LowerIO m) where   bracket' alloc free use =     control $ \run ->       IO.bracket@@ -138,6 +129,4 @@ {-# INLINE runResourceIO' #-}  -- | The untagged version of 'runResourceIO''.-runResourceIO :: (Resource `Via` LowerIO) m a -> m a-runResourceIO = coerce-{-# INLINE runResourceIO #-}+makeUntagged ['runResourceIO']

@@ -17,6 +17,10 @@ module Control.Effect.State   ( -- * Tagged State Effect     State'(..)+    -- * Convenience Functions+  , gets'+  , modify'+  , modifyStrict'     -- * 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),@@ -25,15 +29,8 @@   , 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,@@ -123,11 +120,6 @@ 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@@ -135,11 +127,6 @@   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 ()@@ -148,7 +135,4 @@   put' @tag $! f s {-# INLINE modifyStrict' #-} --- | The untagged version of 'modifyStrict''.-modifyStrict :: State s m => (s -> s) -> m ()-modifyStrict = modifyStrict' @G-{-# INLINE modifyStrict #-}+makeUntagged ['gets', 'modify', 'modifyStrict']

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Effect.State.Lazy@@ -31,7 +32,7 @@ import Control.Monad.Trans.State.Lazy (StateT, runStateT)  import Control.Effect.State     (State, State')-import Control.Effect.Machinery (G, Via, runVia)+import Control.Effect.Machinery (Via, makeUntagged, runVia)  -- | Runs the state effect and discards the final state. evalState' :: forall tag s m a. Functor m@@ -41,11 +42,6 @@ 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.@@ -54,11 +50,6 @@ 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.@@ -67,7 +58,4 @@ 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 #-}+makeUntagged ['evalState', 'execState', 'runState']

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Effect.State.Strict@@ -31,7 +32,7 @@ import Control.Monad.Trans.State.Strict (StateT, runStateT)  import Control.Effect.State     (State, State')-import Control.Effect.Machinery (G, Via, runVia)+import Control.Effect.Machinery (Via, makeUntagged, runVia)  -- | Runs the state effect and discards the final state. evalState' :: forall tag s m a. Functor m@@ -41,11 +42,6 @@ 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.@@ -54,11 +50,6 @@ 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.@@ -67,7 +58,4 @@ 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 #-}+makeUntagged ['evalState', 'execState', 'runState']

@@ -17,6 +17,8 @@ module Control.Effect.Writer   ( -- * Tagged Writer Effect     Writer'(..)+    -- * Convenience Functions+  , listens'     -- * 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),@@ -25,11 +27,6 @@   , 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,@@ -58,7 +55,7 @@ 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+class (Monad m, Monoid w) => 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.@@ -113,7 +110,4 @@   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 #-}+makeUntagged ['listens']

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Effect.Writer.Lazy@@ -29,7 +30,7 @@ import Control.Monad.Trans.Writer.Lazy (WriterT, execWriterT, runWriterT)  import Control.Effect.Writer    (Writer, Writer')-import Control.Effect.Machinery (G, Via, runVia)+import Control.Effect.Machinery (Via, makeUntagged, runVia)  -- | Runs the writer effect and returns the final output. execWriter' :: forall tag w m a. Monad m@@ -38,11 +39,6 @@ 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.@@ -50,7 +46,4 @@ 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 #-}+makeUntagged ['execWriter', 'runWriter']

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Effect.Writer.Strict@@ -75,11 +76,6 @@ 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.@@ -87,7 +83,4 @@ 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 #-}+makeUntagged ['execWriter', 'runWriter']