ether 0.3.1.1 → 0.4.0.0

raw patch · 34 files changed

+992/−1089 lines, 34 filesdep +exceptionsdep −newtype-genericsPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions

Dependencies removed: newtype-generics

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• ether.cabal +36/−16
• src/Control/Ether/TH.hs +1/−1
• src/Control/Ether/Tagged.hs +0/−159
• src/Control/Ether/Util.hs +15/−18
• src/Control/Ether/Wrapped.hs +0/−92
• src/Control/Monad/Ether.hs +9/−18
• src/Control/Monad/Ether/Except/Class.hs +8/−7
• src/Control/Monad/Ether/Implicit.hs +9/−14
• src/Control/Monad/Ether/Implicit/Except.hs +2/−2
• src/Control/Monad/Ether/Implicit/Reader.hs +4/−4
• src/Control/Monad/Ether/Implicit/State/Lazy.hs +5/−5
• src/Control/Monad/Ether/Implicit/State/Strict.hs +5/−5
• src/Control/Monad/Ether/Implicit/Writer.hs +6/−6
• src/Control/Monad/Ether/Reader/Class.hs +8/−7
• src/Control/Monad/Ether/State/Class.hs +14/−13
• src/Control/Monad/Ether/Writer/Class.hs +8/−7
• src/Control/Monad/Trans/Ether/Dispatch.hs +209/−0
• src/Control/Monad/Trans/Ether/Except.hs +8/−97
• src/Control/Monad/Trans/Ether/Reader.hs +9/−100
• src/Control/Monad/Trans/Ether/State/Lazy.hs +13/−105
• src/Control/Monad/Trans/Ether/State/Strict.hs +13/−105
• src/Control/Monad/Trans/Ether/Tagged.hs +154/−0
• src/Control/Monad/Trans/Ether/Writer.hs +11/−100
• test/Regression.hs +19/−208
• test/Regression/T1.hs +39/−0
• test/Regression/T2.hs +30/−0
• test/Regression/T3.hs +56/−0
• test/Regression/T4.hs +25/−0
• test/Regression/T5.hs +45/−0
• test/Regression/T6.hs +66/−0
• test/Regression/T7.hs +50/−0
• test/Regression/T8.hs +52/−0
• test/Regression/T9.hs +51/−0

@@ -1,3 +1,15 @@+0.4.0.0+-------++* Poly-kinded tags.+* Remove `Control.Ether.Tagged`.+* Replace `Control.Ether.Wrapped` with `Control.Monad.Trans.Ether.Dispatch`.+* Unified tagged transformer type in `Control.Monad.Trans.Ether.Tagged`.+* `MonadThrow`, `MonadCatch`, `MonadMask` instances.+* Drop `newtype-generics`.+* Instance search is now more strict.++ 0.3.1.1 ------- 

@@ -1,5 +1,5 @@ name:                ether-version:             0.3.1.1+version:             0.4.0.0 synopsis:            Monad transformers and classes description:     Ether is a Haskell library that extends @mtl@ and @transformers@ with@@ -24,9 +24,7 @@  library -  exposed-modules:     Control.Ether.Tagged-                       Control.Ether.Wrapped-                       Control.Ether.Abbr+  exposed-modules:     Control.Ether.Abbr                        Control.Ether.Implicit.Abbr                        Control.Ether.TH                        Control.Monad.Trans.Ether.Reader@@ -35,6 +33,8 @@                        Control.Monad.Trans.Ether.State.Lazy                        Control.Monad.Trans.Ether.State.Strict                        Control.Monad.Trans.Ether.Except+                       Control.Monad.Trans.Ether.Dispatch+                       Control.Monad.Trans.Ether.Tagged                        Control.Monad.Ether                        Control.Monad.Ether.Reader                        Control.Monad.Ether.Reader.Class@@ -63,25 +63,24 @@                ,       mmorph >=1.0.4                ,       monad-control >=1.0.0.4                ,       transformers-base >=0.4.4+               ,       exceptions >=0.8                ,       template-haskell >=2.9-               ,       newtype-generics >=0.4.1    default-language:    Haskell2010-  other-extensions:    DeriveGeneric-                       MultiParamTypeClasses-                       TypeFamilies-                       FlexibleInstances-                       UndecidableInstances+  other-extensions:    CPP+                       ConstraintKinds                        DataKinds-                       GeneralizedNewtypeDeriving+                       DefaultSignatures+                       DeriveGeneric+                       FlexibleInstances                        FunctionalDependencies-                       ConstraintKinds+                       GeneralizedNewtypeDeriving+                       MultiParamTypeClasses                        ScopedTypeVariables                        TemplateHaskell-                       PolyKinds+                       TypeFamilies                        TypeOperators-                       DefaultSignatures-                       CPP+                       UndecidableInstances    hs-source-dirs:      src   ghc-options:         -Wall@@ -98,7 +97,28 @@                ,       ether    main-is:             Regression.hs+  other-modules:       Regression.T1+                       Regression.T2+                       Regression.T3+                       Regression.T4+                       Regression.T5+                       Regression.T6+                       Regression.T7+                       Regression.T8+                       Regression.T9+   type:                exitcode-stdio-1.0   hs-source-dirs:      test   default-language:    Haskell2010-  ghc-options:         -Wall+  default-extensions:  ConstraintKinds+                       DataKinds+                       EmptyDataDecls+                       FlexibleContexts+                       GeneralizedNewtypeDeriving+                       LambdaCase+                       PolyKinds+                       ScopedTypeVariables+                       TemplateHaskell+                       TypeFamilies+                       TypeOperators+  ghc-options:         -Wall -fno-warn-missing-signatures

@@ -26,7 +26,7 @@ -- Creates a tag and a value-level proxy for it. -- -- @'ethereal' \"Foo\" \"foo\"@ generates the following code:--- +-- -- > data Foo -- > foo :: Proxy Foo -- > foo = Proxy

@@ -1,159 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE DefaultSignatures #-}---- | Type-level machinery for tag manipulation.--module Control.Ether.Tagged-    ( Taggable(..)-    , Tagged(..)-    , Tags-    , Inners-    , UniqueTag-    , UniqueTags-    , ensureUniqueTags-    ) where--import Data.Proxy (Proxy)-import Data.Functor.Identity (Identity)-import Data.Monoid (First, Last)-import qualified Control.Monad.ST.Strict as Strict (ST)-import qualified Control.Monad.ST.Lazy   as Lazy   (ST)-import GHC.Conc (STM)-import GHC.Exts (Constraint)-import qualified Control.Newtype as NT-import Control.Ether.Util (type (++), MaybeToList)--import qualified Control.Monad.Trans.Cont          as Trans-import qualified Control.Monad.Trans.Except        as Trans-import qualified Control.Monad.Trans.Identity      as Trans-import qualified Control.Monad.Trans.List          as Trans-import qualified Control.Monad.Trans.Maybe         as Trans-import qualified Control.Monad.Trans.Reader        as Trans-import qualified Control.Monad.Trans.State.Lazy    as Trans.Lazy-import qualified Control.Monad.Trans.State.Strict  as Trans.Strict-import qualified Control.Monad.Trans.Writer.Lazy   as Trans.Lazy-import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict---- |--- The main purpose of the 'UniqueTag' class is to provide clear error--- messages when the tag uniqueness property is violated. You should never--- write instances for it unless you know what you're doing.-class UniqueTag a--type family IsUnique (x :: k) (as :: [k]) :: Constraint where-    IsUnique x (x ': as) = (UniqueTag x, IsUnique x as)-    IsUnique x (a ': as) = IsUnique x as-    IsUnique x '[] = ()--type family Unique (as :: [k]) :: Constraint where-    Unique '[] = ()-    Unique (a ': as) = (IsUnique a as, Unique as)---- |--- The 'UniqueTags` constraint placed on a type variable representing a--- monad transformer stack ensures that every tag in the stack appears--- only once.-type family UniqueTags (m :: * -> *) :: Constraint where-    UniqueTags m = Unique (Tags m)---- |--- Type-restricted version of 'id' that adds a 'UniqueTags' constraint to--- the provided monadic value.-ensureUniqueTags :: UniqueTags m => m a -> m a-ensureUniqueTags = id--type family ListMapTag (as :: [* -> *]) :: [*] where-    ListMapTag '[] = '[]-    ListMapTag (a ': as) = MaybeToList (Tag a) ++ ListMapTag as---- | The 'Taggable' class defines the type families to manage tags in monad--- transformer stacks. Its kind is restricted to @* -> *@ to prevent incorrect--- instances.-class Taggable (m :: * -> *) where--    -- | The 'Tag' type family equals @Nothing@ for most types, but for tagged-    -- monad transformers it equals @Just tag@.-    type Tag m :: Maybe *-    type instance Tag m = 'Nothing--    -- | The 'Inner' type family equals @Nothing@ for most types, but for-    -- monad transformers with inner monad @m@ it equals @Just m@.-    type Inner m :: Maybe (* -> *)-    type instance Inner m = 'Nothing--type family Inners' m where-    Inners' 'Nothing = '[]-    Inners' ('Just n) = n ': Inners n---- | The 'Inners' type function recursively applies 'Inner' and returns the--- results in a type-level list.-type Inners m = Inners' (Inner m)--instance Taggable IO-instance Taggable Identity--instance Taggable Maybe-instance Taggable Last-instance Taggable First-instance Taggable ((->) r)-instance Taggable STM-instance Taggable (Either e)-instance Taggable Proxy-instance Taggable (Strict.ST s)-instance Taggable (Lazy.ST s)--instance Taggable (Trans.ContT r m) where-    type Inner (Trans.ContT r m) = 'Just m--instance Taggable (Trans.ExceptT e m) where-    type Inner (Trans.ExceptT e m) = 'Just m--instance Taggable (Trans.IdentityT m) where-    type Inner (Trans.IdentityT m) = 'Just m--instance Taggable (Trans.ListT m) where-    type Inner (Trans.ListT m) = 'Just m--instance Taggable (Trans.MaybeT m) where-    type Inner (Trans.MaybeT m) = 'Just m--instance Taggable (Trans.ReaderT r m) where-    type Inner (Trans.ReaderT r m) = 'Just m--instance Taggable (Trans.Lazy.StateT s m) where-    type Inner (Trans.Lazy.StateT s m) = 'Just m--instance Taggable (Trans.Strict.StateT s m) where-    type Inner (Trans.Strict.StateT s m) = 'Just m--instance Taggable (Trans.Lazy.WriterT w m) where-    type Inner (Trans.Lazy.WriterT w m) = 'Just m--instance Taggable (Trans.Strict.WriterT w m) where-    type Inner (Trans.Strict.WriterT w m) = 'Just m---- | The 'Tags' type function returns a type-level list of all tags in--- a monad transformer stack. Requires 'Taggable' instances.-type Tags (m :: * -> *) = MaybeToList (Tag m) ++ ListMapTag (Inners m)---- | The 'Tagged' type class establishes a relationship between a tagged--- monad transformer and its untagged counterpart.-class (Taggable m, Tag m ~ 'Just tag) => Tagged m tag | m -> tag where--    type Untagged m :: * -> *--    tagged :: proxy tag -> Untagged m a -> m a-    default tagged :: NT.Newtype (m a) => proxy tag -> NT.O (m a) -> m a-    tagged _ = NT.pack--    untagged :: proxy tag -> m a -> Untagged m a-    default untagged :: NT.Newtype (m a) => proxy tag -> m a -> NT.O (m a)-    untagged _ = NT.unpack

@@ -1,36 +1,33 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-} module Control.Ether.Util-    ( type (++)-    , MaybeToList-    , fmap-    ) where+  ( fmap+  , MonadApplicative+  ) where  import Prelude hiding (fmap)  #if __GLASGOW_HASKELL__ < 710+import qualified Control.Applicative import qualified Control.Monad #else import qualified Prelude #endif -type family (as :: [*]) ++ (bs :: [*]) :: [*] where-    '[] ++ bs = bs-    (a ': as) ++ bs = a ': (as ++ bs)--type family MaybeToList (mt :: Maybe k) :: [k] where-    MaybeToList 'Nothing = '[]-    MaybeToList ('Just t) = '[t]- #if __GLASGOW_HASKELL__ < 710 fmap :: Monad f => (a -> b) -> f a -> f b-fmap = Control.Monad.liftM +fmap = Control.Monad.liftM #else fmap :: Functor f => (a -> b) -> f a -> f b-fmap = Prelude.fmap +fmap = Prelude.fmap #endif  {-# INLINE fmap #-}++#if __GLASGOW_HASKELL__ < 710+type MonadApplicative m =+  ( Control.Applicative.Applicative m+  , Control.Monad.Monad m )+#else+type MonadApplicative = Monad+#endif

@@ -1,92 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{- |-Annotating monads with tags to turn untagged constraints into tagged ones.--> import qualified Control.Monad.State as T-> import Control.Ether.TH (ethereal)-> import Control.Monad.Ether.State (MonadState)-> import Control.Ether.Wrapped (ethered)->-> ethereal "Foo" "foo"->-> f :: T.MonadState Int m => m String-> f = fmap show T.get-> -> g :: MonadState Foo Int m => m String-> g = ethered foo f--}--module Control.Ether.Wrapped-    ( WrappedEther(..)-    , ethered-    ) where--import Data.Proxy (Proxy(Proxy))-import Control.Applicative-import Control.Monad (MonadPlus)-import Control.Monad.Fix (MonadFix)-import Control.Monad.IO.Class (MonadIO)-import GHC.Generics (Generic)-import qualified Control.Newtype as NT--import Control.Monad.Ether.Reader.Class-import Control.Monad.Ether.State.Class-import Control.Monad.Ether.Except.Class-import Control.Monad.Ether.Writer.Class--import qualified Control.Monad.Reader as Class-import qualified Control.Monad.State  as Class-import qualified Control.Monad.Except as Class-import qualified Control.Monad.Writer as Class---- | Wrap a monad to attach a tag to it.-newtype WrappedEther tag m a = WrapEther { unwrapEther :: m a }-    deriving ( Generic-             , Functor, Applicative, Alternative, Monad, MonadPlus-             , MonadFix, MonadIO )--instance NT.Newtype (WrappedEther tag m a)---- | Annotate a polymorphic monadic computation with a tag.-ethered :: proxy tag -> WrappedEther tag m a -> m a-ethered _proxy = unwrapEther--instance MonadReader tag r m => Class.MonadReader r (WrappedEther tag m) where-    ask = WrapEther $ ask (Proxy :: Proxy tag)-    local f = WrapEther . local (Proxy :: Proxy tag) f . unwrapEther--instance MonadReader tag r m => MonadReader tag r (WrappedEther tag' m) where-    ask t = WrapEther $ ask t-    local t f = WrapEther . local t f . unwrapEther--instance MonadState tag s m => Class.MonadState s (WrappedEther tag m) where-    get = WrapEther $ get (Proxy :: Proxy tag)-    put = WrapEther . put (Proxy :: Proxy tag)--instance MonadState tag s m => MonadState tag s (WrappedEther tag' m) where-    get t = WrapEther $ get t-    put t = WrapEther . put t--instance MonadExcept tag e m => Class.MonadError e (WrappedEther tag m) where-    throwError = WrapEther . throw (Proxy :: Proxy tag)-    catchError m h = WrapEther $ catch (Proxy :: Proxy tag) (unwrapEther m) (unwrapEther . h)--instance MonadExcept tag e m => MonadExcept tag e (WrappedEther tag' m) where-    throw t = WrapEther . throw t-    catch t m h = WrapEther $ catch t (unwrapEther m) (unwrapEther . h)--instance MonadWriter tag w m => Class.MonadWriter w (WrappedEther tag m) where-    tell = WrapEther . tell (Proxy :: Proxy tag)-    listen = WrapEther . listen (Proxy :: Proxy tag) . unwrapEther-    pass = WrapEther . pass (Proxy :: Proxy tag) . unwrapEther--instance MonadWriter tag w m => MonadWriter tag w (WrappedEther tag' m) where-    tell t = WrapEther . tell t-    listen t = WrapEther . listen t . unwrapEther-    pass t = WrapEther . pass t . unwrapEther

@@ -2,22 +2,13 @@ -- | This module provides convenience exports of all -- tagged monad classes from Ether. -module Control.Monad.Ether-    ( module Control.Monad-    , module Control.Monad.Fix-    , module Control.Monad.Ether.Reader-    , module Control.Monad.Ether.Writer-    , module Control.Monad.Ether.State-    , module Control.Monad.Ether.Except-    , module Control.Ether.Wrapped-    , ethereal-    ) where+module Control.Monad.Ether (module X) where -import Control.Monad-import Control.Monad.Fix-import Control.Monad.Ether.Reader-import Control.Monad.Ether.Writer-import Control.Monad.Ether.State-import Control.Monad.Ether.Except-import Control.Ether.Wrapped-import Control.Ether.TH (ethereal)+import Control.Monad as X+import Control.Monad.Fix as X+import Control.Monad.Ether.Reader as X+import Control.Monad.Ether.Writer as X+import Control.Monad.Ether.State as X+import Control.Monad.Ether.Except as X+import Control.Monad.Trans.Ether.Dispatch as X+import Control.Ether.TH as X (ethereal)

@@ -1,14 +1,16 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-} {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif -{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-}--#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}  -- | See "Control.Monad.Except". @@ -16,7 +18,6 @@     ( MonadExcept(..)     ) where -import Control.Monad.Trans.Ether.Except hiding (throw, catch) import qualified Control.Monad.Trans.Ether.Except as E import qualified Control.Monad.Trans.Lift.Catch as Lift @@ -31,7 +32,7 @@     -- normal execution.     catch :: proxy tag -> m a -> (e -> m a) -> m a -instance Monad m => MonadExcept tag e (ExceptT tag e m) where+instance (Monad m, e ~ e') => MonadExcept tag e (E.ExceptT tag e' m) where     throw = E.throw     catch = E.catch 

@@ -2,18 +2,13 @@ -- | This module provides convenience exports of all -- implicitly tagged monad classes from Ether. -module Control.Monad.Ether.Implicit-    ( module Control.Monad-    , module Control.Monad.Fix-    , module Control.Monad.Ether.Implicit.Reader-    , module Control.Monad.Ether.Implicit.Writer-    , module Control.Monad.Ether.Implicit.State-    , module Control.Monad.Ether.Implicit.Except-    ) where+module Control.Monad.Ether.Implicit (module X) where -import Control.Monad-import Control.Monad.Fix-import Control.Monad.Ether.Implicit.Reader-import Control.Monad.Ether.Implicit.Writer-import Control.Monad.Ether.Implicit.State-import Control.Monad.Ether.Implicit.Except+import Control.Monad as X+import Control.Monad.Fix as X+import Control.Monad.Ether.Implicit.Reader as X+import Control.Monad.Ether.Implicit.Writer as X+import Control.Monad.Ether.Implicit.State as X+import Control.Monad.Ether.Implicit.Except as X+import Control.Monad.Trans.Ether.Dispatch as X+import Control.Ether.TH as X (ethereal)

@@ -55,8 +55,8 @@  -- | See 'Control.Monad.Ether.Except.handle'. handle :: (e -> a) -> Except e a -> a-handle = Explicit.handle (Proxy :: Proxy e)+handle = Explicit.handle Proxy  -- | See 'Control.Monad.Ether.Except.handleT'. handleT :: Functor m => (e -> a) -> ExceptT e m a -> m a-handleT = Explicit.handleT (Proxy :: Proxy e)+handleT = Explicit.handleT Proxy

@@ -45,17 +45,17 @@ type MonadReader r = Explicit.MonadReader r r  -- | See 'Control.Monad.Ether.Reader.local'.-local :: forall m r a . MonadReader r m => (r -> r) -> m a -> m a+local :: forall r m a . MonadReader r m => (r -> r) -> m a -> m a local = Explicit.local (Proxy :: Proxy r)  -- | See 'Control.Monad.Ether.Reader.ask'.-ask :: forall m r . MonadReader r m => m r+ask :: forall r m . MonadReader r m => m r ask = Explicit.ask (Proxy :: Proxy r)  -- | See 'Control.Monad.Ether.Reader.reader'.-reader :: forall m r a . MonadReader r m => (r -> a) -> m a+reader :: forall r m a . MonadReader r m => (r -> a) -> m a reader = Explicit.reader (Proxy :: Proxy r)  -- | See 'Control.Monad.Ether.Reader.asks'.-asks :: forall m r a . MonadReader r m => (r -> a) -> m a+asks :: forall r m a . MonadReader r m => (r -> a) -> m a asks = Explicit.asks (Proxy :: Proxy r)

@@ -66,21 +66,21 @@ type MonadState s = Explicit.MonadState s s  -- | See 'Control.Monad.Ether.State.Lazy.get'.-get :: forall m s . MonadState s m => m s+get :: forall s m . MonadState s m => m s get = Explicit.get (Proxy :: Proxy s)  -- | See 'Control.Monad.Ether.State.Lazy.gets'.-gets :: forall m s a . MonadState s m => (s -> a) -> m a+gets :: forall s m a . MonadState s m => (s -> a) -> m a gets = Explicit.gets (Proxy :: Proxy s)  -- | See 'Control.Monad.Ether.State.Lazy.put'.-put :: forall m s . MonadState s m => s -> m ()+put :: forall s m . MonadState s m => s -> m () put = Explicit.put (Proxy :: Proxy s)  -- | See 'Control.Monad.Ether.State.Lazy.state'.-state :: forall m s a . MonadState s m => (s -> (a, s)) -> m a+state :: forall s m a . MonadState s m => (s -> (a, s)) -> m a state = Explicit.state (Proxy :: Proxy s)  -- | See 'Control.Monad.Ether.State.Lazy.modify'.-modify :: forall m s . MonadState s m => (s -> s) -> m ()+modify :: forall s m . MonadState s m => (s -> s) -> m () modify = Explicit.modify (Proxy :: Proxy s)

@@ -66,21 +66,21 @@ type MonadState s = Explicit.MonadState s s  -- | See 'Control.Monad.Ether.State.Strict.get'.-get :: forall m s . MonadState s m => m s+get :: forall s m . MonadState s m => m s get = Explicit.get (Proxy :: Proxy s)  -- | See 'Control.Monad.Ether.State.Strict.gets'.-gets :: forall m s a . MonadState s m => (s -> a) -> m a+gets :: forall s m a . MonadState s m => (s -> a) -> m a gets = Explicit.gets (Proxy :: Proxy s)  -- | See 'Control.Monad.Ether.State.Strict.put'.-put :: forall m s . MonadState s m => s -> m ()+put :: forall s m . MonadState s m => s -> m () put = Explicit.put (Proxy :: Proxy s)  -- | See 'Control.Monad.Ether.State.Strict.state'.-state :: forall m s a . MonadState s m => (s -> (a, s)) -> m a+state :: forall s m a . MonadState s m => (s -> (a, s)) -> m a state = Explicit.state (Proxy :: Proxy s)  -- | See 'Control.Monad.Ether.State.Strict.modify'.-modify :: forall m s . MonadState s m => (s -> s) -> m ()+modify :: forall s m . MonadState s m => (s -> s) -> m () modify = Explicit.modify (Proxy :: Proxy s)

@@ -31,27 +31,27 @@ type MonadWriter w = Explicit.MonadWriter w w  -- | See 'Control.Monad.Ether.Writer.writer'.-writer :: forall m w a . MonadWriter w m => (a, w) -> m a+writer :: forall w m a . MonadWriter w m => (a, w) -> m a writer = Explicit.writer (Proxy :: Proxy w)  -- | See 'Control.Monad.Ether.Writer.tell'.-tell :: forall m w . MonadWriter w m => w -> m ()+tell :: forall w m . MonadWriter w m => w -> m () tell = Explicit.tell (Proxy :: Proxy w)  -- | See 'Control.Monad.Ether.Writer.listen'.-listen :: forall m w a . MonadWriter w m => m a -> m (a, w)+listen :: forall w m a . MonadWriter w m => m a -> m (a, w) listen = Explicit.listen (Proxy :: Proxy w)  -- | See 'Control.Monad.Ether.Writer.pass'.-pass :: forall m w a . MonadWriter w m => m (a, w -> w) -> m a+pass :: forall w m a . MonadWriter w m => m (a, w -> w) -> m a pass = Explicit.pass (Proxy :: Proxy w)  -- | See 'Control.Monad.Ether.Writer.listens'.-listens :: forall m w a b . MonadWriter w m => (w -> b) -> m a -> m (a, b)+listens :: forall w m a b . MonadWriter w m => (w -> b) -> m a -> m (a, b) listens = Explicit.listens (Proxy :: Proxy w)  -- | See 'Control.Monad.Ether.Writer.censor'.-censor :: forall m w a . MonadWriter w m => (w -> w) -> m a -> m a+censor :: forall w m a . MonadWriter w m => (w -> w) -> m a -> m a censor = Explicit.censor (Proxy :: Proxy w)  -- | See 'Control.Monad.Ether.Writer.Writer'.

@@ -1,14 +1,16 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-} {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif -{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-}--#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}  -- | See "Control.Monad.Reader.Class". @@ -17,7 +19,6 @@     , asks     ) where -import Control.Monad.Trans.Ether.Reader hiding (reader, ask, local) import qualified Control.Monad.Trans.Ether.Reader as R import qualified Control.Monad.Trans.Lift.Local as Lift import qualified Control.Ether.Util as Util@@ -57,7 +58,7 @@     -> m a asks = reader -instance Monad m => MonadReader tag r (ReaderT tag r m) where+instance (Monad m, r ~ r') => MonadReader tag r (R.ReaderT tag r' m) where     ask = R.ask     local = R.local     reader = R.reader

@@ -1,14 +1,16 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-} {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif -{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-}--#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}  -- | See "Control.Monad.State.Class". @@ -18,10 +20,9 @@     , gets     ) where -import Control.Monad.Trans (MonadTrans(..))- import qualified Control.Monad.Trans.Ether.State.Lazy   as S.L import qualified Control.Monad.Trans.Ether.State.Strict as S.S+import qualified Control.Monad.Trans as Lift import qualified Control.Ether.Util as Util  -- | See 'Control.Monad.State.MonadState'.@@ -53,21 +54,21 @@ gets :: MonadState tag s m => proxy tag -> (s -> a) -> m a gets t f = Util.fmap f (get t) -instance Monad m => MonadState tag s (S.L.StateT tag s m) where+instance (Monad m, s ~ s') => MonadState tag s (S.L.StateT tag s' m) where     get = S.L.get     put = S.L.put     state = S.L.state -instance Monad m => MonadState tag s (S.S.StateT tag s m) where+instance (Monad m, s ~ s') => MonadState tag s (S.S.StateT tag s' m) where     get = S.S.get     put = S.S.put     state = S.S.state  instance {-# OVERLAPPABLE #-}-         ( MonadTrans t+         ( Lift.MonadTrans t          , Monad (t m)          , MonadState tag s m          ) => MonadState tag s (t m) where-    get t = lift (get t)-    put t = lift . put t-    state t = lift . state t+    get t = Lift.lift (get t)+    put t = Lift.lift . put t+    state t = Lift.lift . state t

@@ -1,14 +1,16 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-} {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif -{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-}--#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}  -- | See "Control.Monad.Writer.Class". @@ -22,7 +24,6 @@ import Data.Monoid #endif -import Control.Monad.Trans.Ether.Writer hiding (writer, tell, listen, pass) import qualified Control.Monad.Trans.Ether.Writer as W import qualified Control.Monad.Trans.Lift.Listen as Lift import qualified Control.Monad.Trans.Lift.Pass   as Lift@@ -63,7 +64,7 @@     a <- m     return (a, f) -instance (Monoid w, Monad m) => MonadWriter tag w (WriterT tag w m) where+instance (Monoid w, Monad m, w ~ w') => MonadWriter tag w (W.WriterT tag w' m) where     writer = W.writer     tell = W.tell     listen = W.listen

@@ -0,0 +1,209 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 710+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}+#endif++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |++Type-level machinery to manipulate constraints on the monad+transformer stack.++Out of the box it provides the following dispatch strategies:++* 'tagAttach' to use functions defined using untagged monad classes+  as if they were defined using tagged ones.++* 'tagReplace' to use functions defined using one tag+  as if they were defined using another one.++> import qualified Control.Monad.State as T+> import Control.Ether.TH (ethereal)+> import Control.Monad.Ether.State (MonadState)+> import Control.Monad.Trans.Ether.Dispatch (tagAttach, tagDispatch)+>+> ethereal "Foo" "foo"+> ethereal "Bar" "bar"+>+> f :: T.MonadState Int m => m String+> f = fmap show T.get+>+> g :: MonadState Foo Int m => m String+> g = tagAttach foo f+>+> h :: MonadState Bar Int m => m String+> h = tagReplace foo bar g++-}++module Control.Monad.Trans.Ether.Dispatch+  (+  -- * The DispatchT monad transformer+    DispatchT+  -- * Dispatch types and functions+  , K_TagAttach(..)+  , K_TagReplace(..)+  , tagAttach+  , tagReplace+  ) where++import Control.Applicative+import Control.Monad (MonadPlus)+import Control.Monad.Fix (MonadFix)+import Control.Monad.Trans.Class (MonadTrans)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Morph (MFunctor, MMonad)+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)+import GHC.Generics (Generic)+import Data.Coerce (coerce)+import Data.Proxy++import qualified Control.Monad.Base as MB+import qualified Control.Monad.Trans.Control as MC+import qualified Control.Monad.Trans.Identity as Trans++import qualified Control.Monad.Trans.Lift.StT    as Lift+import qualified Control.Monad.Trans.Lift.Local  as Lift+import qualified Control.Monad.Trans.Lift.Catch  as Lift+import qualified Control.Monad.Trans.Lift.Listen as Lift+import qualified Control.Monad.Trans.Lift.Pass   as Lift+import qualified Control.Monad.Trans.Lift.CallCC as Lift++import Control.Monad.Ether.Reader.Class+import Control.Monad.Ether.State.Class+import Control.Monad.Ether.Except.Class+import Control.Monad.Ether.Writer.Class++import qualified Control.Monad.Reader as Class+import qualified Control.Monad.State  as Class+import qualified Control.Monad.Except as Class+import qualified Control.Monad.Writer as Class++-- | Encode type-level information for 'tagAttach'.+data K_TagAttach t = TagAttach t++-- | Encode type-level information for 'tagReplace'.+data K_TagReplace tOld tNew = TagReplace tOld tNew++-- | Wrap a monad to change its tags. Under the hood this is+-- simply 'Trans.IdentityT', all the work is happening on the type level.+newtype DispatchT dp m a = DispatchT (Trans.IdentityT m a)+  deriving+    ( Generic+    , Functor, Applicative, Alternative, Monad, MonadPlus+    , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad+    , MonadThrow, MonadCatch, MonadMask )++type DispatchTagAttachT t = DispatchT (TagAttach t)+type DispatchTagReplaceT tOld tNew = DispatchT (TagReplace tOld tNew)++-- | Type-restricted 'coerce'.+pack :: Trans.IdentityT m a -> DispatchT dp m a+pack = coerce++-- | Type-restricted 'coerce'.+unpack :: DispatchT dp m a -> Trans.IdentityT m a+unpack = coerce++instance MB.MonadBase b m => MB.MonadBase b (DispatchT dp m) where+  liftBase = MB.liftBaseDefault++instance MC.MonadTransControl (DispatchT dp) where+  type StT (DispatchT dp) a = MC.StT Trans.IdentityT a+  liftWith = MC.defaultLiftWith pack unpack+  restoreT = MC.defaultRestoreT pack++instance MC.MonadBaseControl b m => MC.MonadBaseControl b (DispatchT dp m) where+  type StM (DispatchT dp m) a = MC.ComposeSt (DispatchT dp) m a+  liftBaseWith = MC.defaultLiftBaseWith+  restoreM = MC.defaultRestoreM++type instance Lift.StT (DispatchT dp) a = MC.StT (DispatchT dp) a++instance Lift.LiftLocal (DispatchT dp) where+  liftLocal = Lift.defaultLiftLocal pack unpack++instance Lift.LiftCatch (DispatchT dp) where+  liftCatch = Lift.defaultLiftCatch pack unpack++instance Lift.LiftListen (DispatchT dp) where+  liftListen = Lift.defaultLiftListen pack unpack++instance Lift.LiftPass (DispatchT dp) where+  liftPass = Lift.defaultLiftPass pack unpack++instance Lift.LiftCallCC (DispatchT dp) where+  liftCallCC  = Lift.defaultLiftCallCC  pack unpack+  liftCallCC' = Lift.defaultLiftCallCC' pack unpack++-- | Attach a tag to untagged transformers.+tagAttach :: proxy t -> DispatchTagAttachT t m a -> m a+tagAttach _ = coerce++-- | Replace a tag with another tag.+tagReplace+  :: proxy tOld+  -> proxy tNew+  -> DispatchTagReplaceT tOld tNew m a+  -> m a+tagReplace _ _ = coerce+++-- TagAttach instances++instance MonadReader tag r m+      => Class.MonadReader r (DispatchTagAttachT tag m) where+  ask   = let t = Proxy :: Proxy tag in Lift.lift (ask t)+  local = let t = Proxy :: Proxy tag in Lift.liftLocal (ask t) (local t)++instance MonadState tag s m+      => Class.MonadState s (DispatchTagAttachT tag m) where+  get = let t = Proxy :: Proxy tag in Lift.lift (get t)+  put = let t = Proxy :: Proxy tag in Lift.lift . put t++instance MonadExcept tag e m+      => Class.MonadError e (DispatchTagAttachT tag m) where+  throwError = let t = Proxy :: Proxy tag in Lift.lift . throw t+  catchError = let t = Proxy :: Proxy tag in Lift.liftCatch (catch t)++instance MonadWriter tag w m+      => Class.MonadWriter w (DispatchTagAttachT tag m) where+  writer = let t = Proxy :: Proxy tag in Lift.lift . writer t+  tell   = let t = Proxy :: Proxy tag in Lift.lift . tell t+  listen = let t = Proxy :: Proxy tag in Lift.liftListen (listen t)+  pass   = let t = Proxy :: Proxy tag in Lift.liftPass (pass t)+++-- TagReplace instances++instance MonadReader tNew r m+      => MonadReader tOld r (DispatchTagReplaceT tOld tNew m) where+  ask   _ = let t = Proxy :: Proxy tNew in Lift.lift (ask t)+  local _ = let t = Proxy :: Proxy tNew in Lift.liftLocal (ask t) (local t)++instance MonadState tNew s m+      => MonadState tOld s (DispatchTagReplaceT tOld tNew m) where+  get _ = let t = Proxy :: Proxy tNew in Lift.lift (get t)+  put _ = let t = Proxy :: Proxy tNew in Lift.lift . put t++instance MonadExcept tNew e m+      => MonadExcept tOld e (DispatchTagReplaceT tOld tNew m) where+  throw _ = let t = Proxy :: Proxy tNew in Lift.lift . throw t+  catch _ = let t = Proxy :: Proxy tNew in Lift.liftCatch (catch t)++instance MonadWriter tNew w m+      => MonadWriter tOld w (DispatchTagReplaceT tOld tNew m) where+  writer _ = let t = Proxy :: Proxy tNew in Lift.lift . writer t+  tell   _ = let t = Proxy :: Proxy tNew in Lift.lift . tell t+  listen _ = let t = Proxy :: Proxy tNew in Lift.liftListen (listen t)+  pass   _ = let t = Proxy :: Proxy tNew in Lift.liftPass (pass t)

@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | See "Control.Monad.Trans.Except".@@ -24,32 +25,8 @@     ) where  import Data.Functor.Identity (Identity(..))-import Control.Applicative-import Control.Monad (MonadPlus)-import Control.Monad.Fix (MonadFix)-import Control.Monad.Trans.Class (MonadTrans, lift)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Morph (MFunctor, MMonad)-import Control.Ether.Tagged (Taggable(..), Tagged(..))-import GHC.Generics (Generic)-import qualified Control.Newtype as NT--import qualified Control.Monad.Base as MB-import qualified Control.Monad.Trans.Control as MC import qualified Control.Monad.Trans.Except as Trans--import qualified Control.Monad.Trans.Lift.StT    as Lift-import qualified Control.Monad.Trans.Lift.Local  as Lift-import qualified Control.Monad.Trans.Lift.Catch  as Lift-import qualified Control.Monad.Trans.Lift.Listen as Lift-import qualified Control.Monad.Trans.Lift.Pass   as Lift-import qualified Control.Monad.Trans.Lift.CallCC as Lift--import qualified Control.Monad.Cont.Class    as Class-import qualified Control.Monad.Reader.Class  as Class-import qualified Control.Monad.State.Class   as Class-import qualified Control.Monad.Writer.Class  as Class-import qualified Control.Monad.Error.Class   as Class+import Control.Monad.Trans.Ether.Tagged   -- | The parameterizable exception monad.@@ -62,60 +39,17 @@  -- | Runs an 'Except' and returns either an exception or a normal value. runExcept :: proxy tag -> Except tag e a -> Either e a-runExcept t = Trans.runExcept . untagged t+runExcept _ = Trans.runExcept . unpack  -- | The exception monad transformer. -- -- The 'return' function returns a normal value, while '>>=' exits on -- the first exception.-newtype ExceptT tag e m a = ExceptT (Trans.ExceptT e m a)-    deriving ( Generic-             , Functor, Applicative, Alternative, Monad, MonadPlus-             , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad )--instance NT.Newtype (ExceptT tag e m a)--instance MB.MonadBase b m => MB.MonadBase b (ExceptT tag e m) where-    liftBase = MB.liftBaseDefault--instance MC.MonadTransControl (ExceptT tag e) where-    type StT (ExceptT tag e) a = MC.StT (Trans.ExceptT e) a-    liftWith = MC.defaultLiftWith NT.pack NT.unpack-    restoreT = MC.defaultRestoreT NT.pack--instance MC.MonadBaseControl b m => MC.MonadBaseControl b (ExceptT tag e m) where-    type StM (ExceptT tag e m) a = MC.ComposeSt (ExceptT tag e) m a-    liftBaseWith = MC.defaultLiftBaseWith-    restoreM = MC.defaultRestoreM--type instance Lift.StT (ExceptT tag e) a = MC.StT (ExceptT tag e) a--instance Lift.LiftLocal (ExceptT tag e) where-    liftLocal = Lift.defaultLiftLocal NT.pack NT.unpack--instance Lift.LiftCatch (ExceptT tag e) where-    liftCatch = Lift.defaultLiftCatch NT.pack NT.unpack--instance Lift.LiftListen (ExceptT tag e) where-    liftListen = Lift.defaultLiftListen NT.pack NT.unpack--instance Lift.LiftPass (ExceptT tag e) where-    liftPass = Lift.defaultLiftPass NT.pack NT.unpack--instance Lift.LiftCallCC (ExceptT tag e) where-    liftCallCC  = Lift.defaultLiftCallCC NT.pack NT.unpack-    liftCallCC' = Lift.defaultLiftCallCC NT.pack NT.unpack--instance Taggable (ExceptT tag e m) where-    type Tag (ExceptT tag e m) = 'Just tag-    type Inner (ExceptT tag e m) = 'Just m--instance Tagged (ExceptT tag e m) tag where-    type Untagged (ExceptT tag e m) = Trans.ExceptT e m+type ExceptT tag e = TaggedTrans tag (Trans.ExceptT e)  -- | Constructor for computations in the exception monad transformer. exceptT :: proxy tag -> m (Either e a) -> ExceptT tag e m a-exceptT t = tagged t . Trans.ExceptT+exceptT _ = pack . Trans.ExceptT  -- | Constructor for computations in the exception monad -- (the inverse of 'runExcept').@@ -124,35 +58,12 @@  -- | Runs an 'ExceptT' and returns either an exception or a normal value. runExceptT :: proxy tag -> ExceptT tag e m a -> m (Either e a)-runExceptT t = Trans.runExceptT . untagged t+runExceptT _ = Trans.runExceptT . unpack  -- | Is used within a monadic computation to begin exception processing. throw :: Monad m => proxy tag -> e -> ExceptT tag e m a-throw t = tagged t . Trans.throwE+throw _ = pack . Trans.throwE  -- | A handler function to handle previous exceptions and return to normal execution. catch :: Monad m => proxy tag -> ExceptT tag e m a -> (e -> ExceptT tag e m a) -> ExceptT tag e m a-catch t m h = tagged t $ Trans.catchE (untagged t m) (untagged t . h)--instance Class.MonadCont m => Class.MonadCont (ExceptT tag e m) where-    callCC = Lift.liftCallCC Class.callCC--instance Class.MonadReader r m => Class.MonadReader r (ExceptT tag e m) where-    ask = lift Class.ask-    local = Lift.liftLocal Class.ask Class.local-    reader = lift . Class.reader--instance Class.MonadState s m => Class.MonadState s (ExceptT tag e m) where-    get = lift Class.get-    put = lift . Class.put-    state = lift . Class.state--instance Class.MonadWriter w m => Class.MonadWriter w (ExceptT tag e m) where-    writer = lift . Class.writer-    tell   = lift . Class.tell-    listen = Lift.liftListen Class.listen-    pass   = Lift.liftPass Class.pass--instance Class.MonadError e' m => Class.MonadError e' (ExceptT tag e m) where-    throwError = lift . Class.throwError-    catchError = Lift.liftCatch Class.catchError+catch _ m h = pack $ Trans.catchE (unpack m) (unpack . h)

@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | See "Control.Monad.Trans.Reader".@@ -24,32 +25,8 @@     ) where  import Data.Functor.Identity (Identity(..))-import Control.Applicative-import Control.Monad (MonadPlus)-import Control.Monad.Fix (MonadFix)-import Control.Monad.Trans.Class (MonadTrans, lift)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Morph (MFunctor, MMonad)-import Control.Ether.Tagged (Taggable(..), Tagged(..))-import GHC.Generics (Generic)-import qualified Control.Newtype as NT--import qualified Control.Monad.Base as MB-import qualified Control.Monad.Trans.Control as MC import qualified Control.Monad.Trans.Reader as Trans--import qualified Control.Monad.Trans.Lift.StT    as Lift-import qualified Control.Monad.Trans.Lift.Local  as Lift-import qualified Control.Monad.Trans.Lift.Catch  as Lift-import qualified Control.Monad.Trans.Lift.Listen as Lift-import qualified Control.Monad.Trans.Lift.Pass   as Lift-import qualified Control.Monad.Trans.Lift.CallCC as Lift--import qualified Control.Monad.Cont.Class    as Class-import qualified Control.Monad.Reader.Class  as Class-import qualified Control.Monad.State.Class   as Class-import qualified Control.Monad.Writer.Class  as Class-import qualified Control.Monad.Error.Class   as Class+import Control.Monad.Trans.Ether.Tagged  -- | The parameterizable reader monad. --@@ -64,73 +41,30 @@ -- -- The 'return' function ignores the environment, while '>>=' passes -- the inherited environment to both subcomputations.-newtype ReaderT tag r m a = ReaderT (Trans.ReaderT r m a)-    deriving ( Generic-             , Functor, Applicative, Alternative, Monad, MonadPlus-             , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad )--instance NT.Newtype (ReaderT tag r m a)--instance MB.MonadBase b m => MB.MonadBase b (ReaderT tag r m) where-    liftBase = MB.liftBaseDefault--instance MC.MonadTransControl (ReaderT tag r) where-    type StT (ReaderT tag r) a = MC.StT (Trans.ReaderT r) a-    liftWith = MC.defaultLiftWith NT.pack NT.unpack-    restoreT = MC.defaultRestoreT NT.pack--instance MC.MonadBaseControl b m => MC.MonadBaseControl b (ReaderT tag r m) where-    type StM (ReaderT tag r m) a = MC.ComposeSt (ReaderT tag r) m a-    liftBaseWith = MC.defaultLiftBaseWith-    restoreM = MC.defaultRestoreM--type instance Lift.StT (ReaderT tag r) a = MC.StT (ReaderT tag r) a--instance Lift.LiftLocal (ReaderT tag r) where-    liftLocal = Lift.defaultLiftLocal NT.pack NT.unpack--instance Lift.LiftCatch (ReaderT tag r) where-    liftCatch = Lift.defaultLiftCatch NT.pack NT.unpack--instance Lift.LiftListen (ReaderT tag r) where-    liftListen = Lift.defaultLiftListen NT.pack NT.unpack--instance Lift.LiftPass (ReaderT tag r) where-    liftPass = Lift.defaultLiftPass NT.pack NT.unpack--instance Lift.LiftCallCC (ReaderT tag r) where-    liftCallCC  = Lift.defaultLiftCallCC  NT.pack NT.unpack-    liftCallCC' = Lift.defaultLiftCallCC' NT.pack NT.unpack--instance Taggable (ReaderT tag r m) where-    type Tag (ReaderT tag r m) = 'Just tag-    type Inner (ReaderT tag r m) = 'Just m--instance Tagged (ReaderT tag r m) tag where-    type Untagged (ReaderT tag r m) = Trans.ReaderT r m+type ReaderT tag r = TaggedTrans tag (Trans.ReaderT r)  -- | Constructor for computations in the reader monad transformer. readerT :: proxy tag -> (r -> m a) -> ReaderT tag r m a-readerT t = tagged t . Trans.ReaderT+readerT _ = pack . Trans.ReaderT  -- | Constructor for computations in the reader monad -- (the inverse of 'runReader'). reader :: Monad m => proxy tag -> (r -> a) -> ReaderT tag r m a-reader t = tagged t . Trans.reader+reader _ = pack . Trans.reader  -- | Runs a 'ReaderT' with the given environment -- and returns the vinal value. runReaderT :: proxy tag -> ReaderT tag r m a -> r -> m a-runReaderT t = Trans.runReaderT . untagged t+runReaderT _ = Trans.runReaderT . unpack  -- | Runs a 'ReaderT' with the given environment -- and returns the vinal value. runReader :: proxy tag -> Reader tag r a -> r -> a-runReader t = Trans.runReader . untagged t+runReader _ = Trans.runReader . unpack  -- | Fetch the value of the environment. ask :: Monad m => proxy tag -> ReaderT tag r m r-ask t = tagged t Trans.ask+ask _ = pack Trans.ask  -- | Execute a computation in a modified environment -- (a specialization of 'withReaderT').@@ -143,29 +77,4 @@     -> ReaderT tag r m a     -- ^ Computation to run in the modified environment.     -> ReaderT tag r m a-local t f m = tagged t $ Trans.withReaderT f (untagged t m)---- Instances for mtl classes--instance Class.MonadCont m => Class.MonadCont (ReaderT tag r m) where-    callCC = Lift.liftCallCC Class.callCC--instance Class.MonadReader r' m => Class.MonadReader r' (ReaderT tag r m) where-    ask = lift Class.ask-    local = Lift.liftLocal Class.ask Class.local-    reader = lift . Class.reader--instance Class.MonadState s m => Class.MonadState s (ReaderT tag r m) where-    get = lift Class.get-    put = lift . Class.put-    state = lift . Class.state--instance Class.MonadWriter w m => Class.MonadWriter w (ReaderT tag r m) where-    writer = lift . Class.writer-    tell   = lift . Class.tell-    listen = Lift.liftListen Class.listen-    pass   = Lift.liftPass Class.pass--instance Class.MonadError e m => Class.MonadError e (ReaderT tag r m) where-    throwError = lift . Class.throwError-    catchError = Lift.liftCatch Class.catchError+local _ f = pack . Trans.withReaderT f . unpack

@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | See "Control.Monad.Trans.State.Lazy".@@ -28,33 +29,8 @@     ) where  import Data.Functor.Identity (Identity(..))-import Control.Applicative-import Control.Monad (MonadPlus)-import Control.Monad.Fix (MonadFix)-import Control.Monad.Trans.Class (MonadTrans, lift)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Morph (MFunctor)-import Control.Ether.Tagged (Taggable(..), Tagged(..))-import GHC.Generics (Generic)-import qualified Control.Newtype as NT--import qualified Control.Monad.Base as MB-import qualified Control.Monad.Trans.Control as MC import qualified Control.Monad.Trans.State.Lazy as Trans--import qualified Control.Monad.Trans.Lift.StT    as Lift-import qualified Control.Monad.Trans.Lift.Local  as Lift-import qualified Control.Monad.Trans.Lift.Catch  as Lift-import qualified Control.Monad.Trans.Lift.Listen as Lift-import qualified Control.Monad.Trans.Lift.Pass   as Lift-import qualified Control.Monad.Trans.Lift.CallCC as Lift--import qualified Control.Monad.Cont.Class    as Class-import qualified Control.Monad.Reader.Class  as Class-import qualified Control.Monad.State.Class   as Class-import qualified Control.Monad.Writer.Class  as Class-import qualified Control.Monad.Error.Class   as Class-+import Control.Monad.Trans.Ether.Tagged  -- | The parametrizable state monad. --@@ -68,119 +44,51 @@ -- -- The 'return' function leaves the state unchanged, while '>>=' uses -- the final state of the first computation as the initial state of the second.-newtype StateT tag s m a = StateT (Trans.StateT s m a)-    deriving ( Generic-             , Functor, Applicative, Alternative, Monad, MonadPlus-             , MonadFix, MonadTrans, MonadIO, MFunctor )--instance NT.Newtype (StateT tag s m a)--instance MB.MonadBase b m => MB.MonadBase b (StateT tag s m) where-    liftBase = MB.liftBaseDefault--instance MC.MonadTransControl (StateT tag s) where-    type StT (StateT tag s) a = MC.StT (Trans.StateT s) a-    liftWith = MC.defaultLiftWith NT.pack NT.unpack-    restoreT = MC.defaultRestoreT NT.pack--instance MC.MonadBaseControl b m => MC.MonadBaseControl b (StateT tag s m) where-    type StM (StateT tag s m) a = MC.ComposeSt (StateT tag s) m a-    liftBaseWith = MC.defaultLiftBaseWith-    restoreM = MC.defaultRestoreM--type instance Lift.StT (StateT tag s) a = MC.StT (StateT tag s) a--instance Lift.LiftLocal (StateT tag s) where-    liftLocal = Lift.defaultLiftLocal NT.pack NT.unpack--instance Lift.LiftCatch (StateT tag s) where-    liftCatch = Lift.defaultLiftCatch NT.pack NT.unpack--instance Lift.LiftListen (StateT tag s) where-    liftListen = Lift.defaultLiftListen NT.pack NT.unpack--instance Lift.LiftPass (StateT tag s) where-    liftPass = Lift.defaultLiftPass NT.pack NT.unpack--instance Lift.LiftCallCC (StateT tag s) where-    liftCallCC  = Lift.defaultLiftCallCC  NT.pack NT.unpack-    liftCallCC' = Lift.defaultLiftCallCC' NT.pack NT.unpack--instance Taggable (StateT tag s m) where-    type Tag (StateT tag s m) = 'Just tag-    type Inner (StateT tag s m) = 'Just m--instance Tagged (StateT tag s m) tag where-    type Untagged (StateT tag s m) = Trans.StateT s m+type StateT tag s = TaggedTrans tag (Trans.StateT s)  -- | Constructor for computations in the state monad transformer. stateT :: proxy tag -> (s -> m (a, s)) -> StateT tag s m a-stateT t = tagged t . Trans.StateT+stateT _ = pack . Trans.StateT  -- | Constructor for computations in the state monad -- (the inverse of 'runState'). state :: Monad m => proxy tag -> (s -> (a, s)) -> StateT tag s m a-state t = tagged t . Trans.state+state _ = pack . Trans.state  -- | Runs a 'StateT' with the given initial state -- and returns both the final value and the final state. runStateT :: proxy tag -> StateT tag s m a -> s -> m (a, s)-runStateT t = Trans.runStateT . untagged t+runStateT _ = Trans.runStateT . unpack  -- | Runs a 'StateT' with the given initial state -- and returns the final value, discarding the final state. evalStateT :: Monad m => proxy tag -> StateT tag s m a -> s -> m a-evalStateT t = Trans.evalStateT . untagged t+evalStateT _ = Trans.evalStateT . unpack  -- | Runs a 'StateT' with the given initial state -- and returns the final state, discarding the final value. execStateT :: Monad m => proxy tag -> StateT tag s m a -> s -> m s-execStateT t = Trans.execStateT . untagged t+execStateT _ = Trans.execStateT . unpack  -- | Runs a 'State' with the given initial state -- and returns both the final value and the final state. runState :: proxy tag -> State tag s a -> s -> (a, s)-runState t = Trans.runState . untagged t+runState _ = Trans.runState . unpack  -- | Runs a 'State' with the given initial state -- and returns the final value, discarding the final state. evalState :: proxy tag -> State tag s a -> s -> a-evalState t = Trans.evalState . untagged t+evalState _ = Trans.evalState . unpack  -- | Runs a 'State' with the given initial state -- and returns the final state, discarding the final value. execState :: proxy tag -> State tag s a -> s -> s-execState t = Trans.execState . untagged t+execState _ = Trans.execState . unpack  -- | Fetch the current value of the state within the monad. get :: Monad m => proxy tag -> StateT tag s m s-get t = tagged t Trans.get+get _ = pack Trans.get  -- | Set the value of the state within the monad. put :: Monad m => proxy tag -> s -> StateT tag s m ()-put t = tagged t . Trans.put---- Instances for mtl classes--instance Class.MonadCont m => Class.MonadCont (StateT tag s m) where-    callCC = Lift.liftCallCC' Class.callCC--instance Class.MonadReader r m => Class.MonadReader r (StateT tag s m) where-    ask = lift Class.ask-    local = Lift.liftLocal Class.ask Class.local-    reader = lift . Class.reader--instance Class.MonadState s' m => Class.MonadState s' (StateT tag s m) where-    get = lift Class.get-    put = lift . Class.put-    state = lift . Class.state--instance Class.MonadWriter w m => Class.MonadWriter w (StateT tag s m) where-    writer = lift . Class.writer-    tell   = lift . Class.tell-    listen = Lift.liftListen Class.listen-    pass   = Lift.liftPass Class.pass--instance Class.MonadError e m => Class.MonadError e (StateT tag s m) where-    throwError = lift . Class.throwError-    catchError = Lift.liftCatch Class.catchError+put _ = pack . Trans.put

@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | See "Control.Monad.Trans.State.Strict".@@ -28,33 +29,8 @@     ) where  import Data.Functor.Identity (Identity(..))-import Control.Applicative-import Control.Monad (MonadPlus)-import Control.Monad.Fix (MonadFix)-import Control.Monad.Trans.Class (MonadTrans, lift)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Morph (MFunctor)-import Control.Ether.Tagged (Taggable(..), Tagged(..))-import GHC.Generics (Generic)-import qualified Control.Newtype as NT--import qualified Control.Monad.Base as MB-import qualified Control.Monad.Trans.Control as MC import qualified Control.Monad.Trans.State.Strict as Trans--import qualified Control.Monad.Trans.Lift.StT    as Lift-import qualified Control.Monad.Trans.Lift.Local  as Lift-import qualified Control.Monad.Trans.Lift.Catch  as Lift-import qualified Control.Monad.Trans.Lift.Listen as Lift-import qualified Control.Monad.Trans.Lift.Pass   as Lift-import qualified Control.Monad.Trans.Lift.CallCC as Lift--import qualified Control.Monad.Cont.Class    as Class-import qualified Control.Monad.Reader.Class  as Class-import qualified Control.Monad.State.Class   as Class-import qualified Control.Monad.Writer.Class  as Class-import qualified Control.Monad.Error.Class   as Class-+import Control.Monad.Trans.Ether.Tagged  -- | The parametrizable state monad. --@@ -68,119 +44,51 @@ -- -- The 'return' function leaves the state unchanged, while '>>=' uses -- the final state of the first computation as the initial state of the second.-newtype StateT tag s m a = StateT (Trans.StateT s m a)-    deriving ( Generic-             , Functor, Applicative, Alternative, Monad, MonadPlus-             , MonadFix, MonadTrans, MonadIO, MFunctor )--instance NT.Newtype (StateT tag s m a)--instance MB.MonadBase b m => MB.MonadBase b (StateT tag s m) where-    liftBase = MB.liftBaseDefault--instance MC.MonadTransControl (StateT tag s) where-    type StT (StateT tag s) a = MC.StT (Trans.StateT s) a-    liftWith = MC.defaultLiftWith NT.pack NT.unpack-    restoreT = MC.defaultRestoreT NT.pack--instance MC.MonadBaseControl b m => MC.MonadBaseControl b (StateT tag s m) where-    type StM (StateT tag s m) a = MC.ComposeSt (StateT tag s) m a-    liftBaseWith = MC.defaultLiftBaseWith-    restoreM = MC.defaultRestoreM--type instance Lift.StT (StateT tag s) a = MC.StT (StateT tag s) a--instance Lift.LiftLocal (StateT tag s) where-    liftLocal = Lift.defaultLiftLocal NT.pack NT.unpack--instance Lift.LiftCatch (StateT tag s) where-    liftCatch = Lift.defaultLiftCatch NT.pack NT.unpack--instance Lift.LiftListen (StateT tag s) where-    liftListen = Lift.defaultLiftListen NT.pack NT.unpack--instance Lift.LiftPass (StateT tag s) where-    liftPass = Lift.defaultLiftPass NT.pack NT.unpack--instance Lift.LiftCallCC (StateT tag s) where-    liftCallCC  = Lift.defaultLiftCallCC  NT.pack NT.unpack-    liftCallCC' = Lift.defaultLiftCallCC' NT.pack NT.unpack--instance Taggable (StateT tag s m) where-    type Tag (StateT tag s m) = 'Just tag-    type Inner (StateT tag s m) = 'Just m--instance Tagged (StateT tag s m) tag where-    type Untagged (StateT tag s m) = Trans.StateT s m+type StateT tag s = TaggedTrans tag (Trans.StateT s)  -- | Constructor for computations in the state monad transformer. stateT :: proxy tag -> (s -> m (a, s)) -> StateT tag s m a-stateT t = tagged t . Trans.StateT+stateT _ = pack . Trans.StateT  -- | Constructor for computations in the state monad -- (the inverse of 'runState'). state :: Monad m => proxy tag -> (s -> (a, s)) -> StateT tag s m a-state t = tagged t . Trans.state+state _ = pack . Trans.state  -- | Runs a 'StateT' with the given initial state -- and returns both the final value and the final state. runStateT :: proxy tag -> StateT tag s m a -> s -> m (a, s)-runStateT t = Trans.runStateT . untagged t+runStateT _ = Trans.runStateT . unpack  -- | Runs a 'StateT' with the given initial state -- and returns the final value, discarding the final state. evalStateT :: Monad m => proxy tag -> StateT tag s m a -> s -> m a-evalStateT t = Trans.evalStateT . untagged t+evalStateT _ = Trans.evalStateT . unpack  -- | Runs a 'StateT' with the given initial state -- and returns the final state, discarding the final value. execStateT :: Monad m => proxy tag -> StateT tag s m a -> s -> m s-execStateT t = Trans.execStateT . untagged t+execStateT _ = Trans.execStateT . unpack  -- | Runs a 'State' with the given initial state -- and returns both the final value and the final state. runState :: proxy tag -> State tag s a -> s -> (a, s)-runState t = Trans.runState . untagged t+runState _ = Trans.runState . unpack  -- | Runs a 'State' with the given initial state -- and returns the final value, discarding the final state. evalState :: proxy tag -> State tag s a -> s -> a-evalState t = Trans.evalState . untagged t+evalState _ = Trans.evalState . unpack  -- | Runs a 'State' with the given initial state -- and returns the final state, discarding the final value. execState :: proxy tag -> State tag s a -> s -> s-execState t = Trans.execState . untagged t+execState _ = Trans.execState . unpack  -- | Fetch the current value of the state within the monad. get :: Monad m => proxy tag -> StateT tag s m s-get t = tagged t Trans.get+get _ = pack Trans.get  -- | Set the value of the state within the monad. put :: Monad m => proxy tag -> s -> StateT tag s m ()-put t = tagged t . Trans.put---- Instances for mtl classes--instance Class.MonadCont m => Class.MonadCont (StateT tag s m) where-    callCC = Lift.liftCallCC' Class.callCC--instance Class.MonadReader r m => Class.MonadReader r (StateT tag s m) where-    ask = lift Class.ask-    local = Lift.liftLocal Class.ask Class.local-    reader = lift . Class.reader--instance Class.MonadState s' m => Class.MonadState s' (StateT tag s m) where-    get = lift Class.get-    put = lift . Class.put-    state = lift . Class.state--instance Class.MonadWriter w m => Class.MonadWriter w (StateT tag s m) where-    writer = lift . Class.writer-    tell   = lift . Class.tell-    listen = Lift.liftListen Class.listen-    pass   = Lift.liftPass Class.pass--instance Class.MonadError e m => Class.MonadError e (StateT tag s m) where-    throwError = lift . Class.throwError-    catchError = Lift.liftCatch Class.catchError+put _ = pack . Trans.put

@@ -0,0 +1,154 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module defines the core data type of Ether, 'TaggedTrans',+-- and a bunch of instances for it. 'TaggedTrans' attaches a tag to+-- an existing monad transformer.++module Control.Monad.Trans.Ether.Tagged where++import Control.Applicative+import Control.Monad (MonadPlus)+import Control.Monad.Fix (MonadFix)+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Morph (MFunctor, MMonad)+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)++import qualified Control.Monad.Base as MB+import qualified Control.Monad.Trans.Control as MC++import qualified Control.Monad.Trans.Lift.StT    as Lift+import qualified Control.Monad.Trans.Lift.Local  as Lift+import qualified Control.Monad.Trans.Lift.Catch  as Lift+import qualified Control.Monad.Trans.Lift.Listen as Lift+import qualified Control.Monad.Trans.Lift.Pass   as Lift+import qualified Control.Monad.Trans.Lift.CallCC as Lift++import qualified Control.Monad.Cont.Class    as Class+import qualified Control.Monad.Reader.Class  as Class+import qualified Control.Monad.State.Class   as Class+import qualified Control.Monad.Writer.Class  as Class+import qualified Control.Monad.Error.Class   as Class++import GHC.Generics (Generic)+import Data.Coerce (coerce)++import Control.Ether.Util (MonadApplicative)++-- | Tagged monad transformer.+newtype TaggedTrans tag trans (m :: * -> *) a = TaggedTrans (trans m a)+  deriving+    ( Generic+    , Functor, Applicative, Alternative, Monad, MonadPlus+    , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad+    , MonadThrow, MonadCatch, MonadMask )++-- | Type-restricted 'coerce'.+pack :: trans m a -> TaggedTrans tag trans m a+pack = coerce++-- | Type-restricted 'coerce'.+unpack :: TaggedTrans tag trans m a -> trans m a+unpack = coerce++instance+    ( MB.MonadBase b m+    , MonadTrans trans+    , MonadApplicative (trans m)+    ) => MB.MonadBase b (TaggedTrans tag trans m)+  where+    liftBase = MB.liftBaseDefault++instance+    ( MC.MonadTransControl trans+    ) => MC.MonadTransControl (TaggedTrans tag trans)+  where+    type StT (TaggedTrans tag trans) a = MC.StT trans a+    liftWith = MC.defaultLiftWith pack unpack+    restoreT = MC.defaultRestoreT pack++instance+    ( MC.MonadBaseControl b m+    , MC.MonadTransControl trans+    , MonadApplicative (trans m)+    ) => MC.MonadBaseControl b (TaggedTrans tag trans m)+  where+    type StM (TaggedTrans tag trans m) a = MC.ComposeSt trans m a+    liftBaseWith = MC.defaultLiftBaseWith+    restoreM = MC.defaultRestoreM++type instance Lift.StT (TaggedTrans tag trans) a = Lift.StT trans a++instance Lift.LiftLocal trans => Lift.LiftLocal (TaggedTrans tag trans) where+  liftLocal = Lift.defaultLiftLocal pack unpack++instance Lift.LiftCatch trans => Lift.LiftCatch (TaggedTrans tag trans) where+  liftCatch = Lift.defaultLiftCatch pack unpack++instance Lift.LiftListen trans => Lift.LiftListen (TaggedTrans tag trans) where+  liftListen = Lift.defaultLiftListen pack unpack++instance Lift.LiftPass trans => Lift.LiftPass (TaggedTrans tag trans) where+  liftPass = Lift.defaultLiftPass pack unpack++instance Lift.LiftCallCC trans => Lift.LiftCallCC (TaggedTrans tag trans) where+  liftCallCC  = Lift.defaultLiftCallCC  pack unpack+  liftCallCC' = Lift.defaultLiftCallCC' pack unpack++-- Instances for mtl classes++instance+    ( Class.MonadCont m+    , Lift.LiftCallCC trans+    , Monad (trans m)+    ) => Class.MonadCont (TaggedTrans tag trans m)+  where+    callCC = Lift.liftCallCC' Class.callCC++instance+    ( Class.MonadReader r m+    , Lift.LiftLocal trans+    , Monad (trans m)+    ) => Class.MonadReader r (TaggedTrans tag trans m)+  where+    ask = lift Class.ask+    local = Lift.liftLocal Class.ask Class.local+    reader = lift . Class.reader++instance+    ( Class.MonadState s m+    , MonadTrans trans+    , Monad (trans m)+    ) => Class.MonadState s (TaggedTrans tag trans m)+  where+    get = lift Class.get+    put = lift . Class.put+    state = lift . Class.state++instance+    ( Class.MonadWriter w m+    , Lift.LiftListen trans+    , Lift.LiftPass trans+    , Monad (trans m)+    ) => Class.MonadWriter w (TaggedTrans tag trans m)+  where+    writer = lift . Class.writer+    tell   = lift . Class.tell+    listen = Lift.liftListen Class.listen+    pass   = Lift.liftPass Class.pass++instance+    ( Class.MonadError e m+    , Lift.LiftCatch trans+    , Monad (trans m)+    ) => Class.MonadError e (TaggedTrans tag trans m)+  where+    throwError = lift . Class.throwError+    catchError = Lift.liftCatch Class.catchError

@@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | See "Control.Monad.Trans.Writer".@@ -32,32 +33,8 @@ #endif  import Data.Functor.Identity (Identity(..))-import Control.Applicative-import Control.Monad (MonadPlus)-import Control.Monad.Fix (MonadFix)-import Control.Monad.Trans.Class (MonadTrans, lift)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Morph (MFunctor, MMonad)-import Control.Ether.Tagged (Taggable(..), Tagged(..))-import GHC.Generics (Generic)-import qualified Control.Newtype as NT--import qualified Control.Monad.Base as MB-import qualified Control.Monad.Trans.Control as MC import qualified Control.Monad.Trans.Writer.Lazy as Trans--import qualified Control.Monad.Trans.Lift.StT    as Lift-import qualified Control.Monad.Trans.Lift.Local  as Lift-import qualified Control.Monad.Trans.Lift.Catch  as Lift-import qualified Control.Monad.Trans.Lift.Listen as Lift-import qualified Control.Monad.Trans.Lift.Pass   as Lift-import qualified Control.Monad.Trans.Lift.CallCC as Lift--import qualified Control.Monad.Cont.Class    as Class-import qualified Control.Monad.Reader.Class  as Class-import qualified Control.Monad.State.Class   as Class-import qualified Control.Monad.Writer.Class  as Class-import qualified Control.Monad.Error.Class   as Class+import Control.Monad.Trans.Ether.Tagged  -- | The parametrizable writer monad. --@@ -71,79 +48,36 @@ -- -- The 'return' function produces the output 'mempty', while '>>=' combines -- the outputs of the subcomputations using 'mappend'.-newtype WriterT tag w m a = WriterT (Trans.WriterT w m a)-    deriving ( Generic-             , Functor, Applicative, Alternative, Monad, MonadPlus-             , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad )--instance NT.Newtype (WriterT tag w m a)--instance (Monoid w, MB.MonadBase b m) => MB.MonadBase b (WriterT tag w m) where-    liftBase = MB.liftBaseDefault--instance Monoid w => MC.MonadTransControl (WriterT tag w) where-    type StT (WriterT tag w) a = MC.StT (Trans.WriterT w) a-    liftWith = MC.defaultLiftWith NT.pack NT.unpack-    restoreT = MC.defaultRestoreT NT.pack--instance (Monoid w, MC.MonadBaseControl b m) => MC.MonadBaseControl b (WriterT tag w m) where-    type StM (WriterT tag w m) a = MC.ComposeSt (WriterT tag w) m a-    liftBaseWith = MC.defaultLiftBaseWith-    restoreM = MC.defaultRestoreM--type instance Lift.StT (WriterT tag w) a = MC.StT (WriterT tag w) a--instance Monoid w => Lift.LiftLocal (WriterT tag w) where-    liftLocal = Lift.defaultLiftLocal NT.pack NT.unpack--instance Monoid w => Lift.LiftCatch (WriterT tag w) where-    liftCatch = Lift.defaultLiftCatch NT.pack NT.unpack--instance Monoid w => Lift.LiftListen (WriterT tag w) where-    liftListen = Lift.defaultLiftListen NT.pack NT.unpack--instance Monoid w' => Lift.LiftPass (WriterT tag w') where-    liftPass = Lift.defaultLiftPass NT.pack NT.unpack--instance Monoid w => Lift.LiftCallCC (WriterT tag w) where-    liftCallCC  = Lift.defaultLiftCallCC NT.pack NT.unpack-    liftCallCC' = Lift.defaultLiftCallCC NT.pack NT.unpack--instance Taggable (WriterT tag w m) where-    type Tag (WriterT tag w m) = 'Just tag-    type Inner (WriterT tag w m) = 'Just m--instance Tagged (WriterT tag w m) tag where-    type Untagged (WriterT tag w m) = Trans.WriterT w m+type WriterT tag w = TaggedTrans tag (Trans.WriterT w)  -- | Constructor for computations in the writer monad transformer. writerT :: proxy tag -> m (a, w) -> WriterT tag w m a-writerT t = tagged t . Trans.WriterT+writerT _ = pack . Trans.WriterT  -- | Constructor for computations in the writer monad -- (the inverse of 'runWriter'). writer :: Monad m => proxy tag -> (a, w) -> WriterT tag w m a-writer t = tagged t . Trans.writer+writer _ = pack . Trans.writer  -- | Runs a 'WriterT' and returns both the normal value -- and the final accumulator. runWriterT :: proxy tag -> WriterT tag w m a -> m (a, w)-runWriterT t = Trans.runWriterT . untagged t+runWriterT _ = Trans.runWriterT . unpack  -- | Runs a 'Writer' and returns both the normal value -- and the final accumulator. runWriter :: proxy tag -> Writer tag w a -> (a, w)-runWriter t = Trans.runWriter . untagged t+runWriter _ = Trans.runWriter . unpack  -- | Runs a 'WriterT' and returns the final accumulator, -- discarding the normal value. execWriterT :: Monad m => proxy tag -> WriterT tag w m a -> m w-execWriterT t = Trans.execWriterT . untagged t+execWriterT _ = Trans.execWriterT . unpack  -- | Runs a 'Writer' and returns the final accumulator, -- discarding the normal value. execWriter :: proxy tag -> Writer tag w a -> w-execWriter t = Trans.execWriter . untagged t+execWriter _ = Trans.execWriter . unpack  -- | Appends a value to the accumulator within the monad. tell :: Monad m => proxy tag -> w -> WriterT tag w m ()@@ -151,32 +85,9 @@  -- | Executes an action and adds its accumulator to the value of the computation. listen :: (Monoid w, Monad m) => proxy tag -> WriterT tag w m a -> WriterT tag w m (a, w)-listen t m = tagged t $ Trans.listen (untagged t m)+listen _ = pack . Trans.listen . unpack  -- | Executes an action which returns a value and a function, and returns the -- value, applying the function to the accumulator. pass :: (Monoid w, Monad m) => proxy tag -> WriterT tag w m (a, w -> w) -> WriterT tag w m a-pass t m = tagged t $ Trans.pass (untagged t m)--instance (Monoid w, Class.MonadCont m) => Class.MonadCont (WriterT tag w m) where-    callCC = Lift.liftCallCC Class.callCC--instance (Monoid w, Class.MonadReader r m) => Class.MonadReader r (WriterT tag w m) where-    ask = lift Class.ask-    local = Lift.liftLocal Class.ask Class.local-    reader = lift . Class.reader--instance (Monoid w, Class.MonadState s m) => Class.MonadState s (WriterT tag w m) where-    get = lift Class.get-    put = lift . Class.put-    state = lift . Class.state--instance (Monoid w, Class.MonadWriter w' m) => Class.MonadWriter w' (WriterT tag w m) where-    writer = lift . Class.writer-    tell   = lift . Class.tell-    listen = Lift.liftListen Class.listen-    pass   = Lift.liftPass Class.pass--instance (Monoid w, Class.MonadError e m) => Class.MonadError e (WriterT tag w m) where-    throwError = lift . Class.throwError-    catchError = Lift.liftCatch Class.catchError+pass _ = pack . Trans.pass . unpack

@@ -1,218 +1,29 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE LambdaCase #-} module Main where -import Data.Monoid-import Control.Monad-import Control.Ether.Tagged-import Control.Ether.TH-import Control.Ether.Wrapped--import Control.Monad.Ether-import Control.Ether.Abbr--import qualified Control.Monad.Ether.Implicit as I-import qualified Control.Ether.Implicit.Abbr as I--import qualified Control.Monad.Reader as T-import qualified Control.Monad.Writer as T-import qualified Control.Monad.State  as T- import Test.Tasty-import Test.Tasty.QuickCheck-import Test.QuickCheck.Function -ethereal "R1" "r1"-ethereal "R2" "r2"-ethereal "S1" "s1"-ethereal "Foo" "foo"-ethereal "Bar" "bar"+import Regression.T1+import Regression.T2+import Regression.T3+import Regression.T4+import Regression.T5+import Regression.T6+import Regression.T7+import Regression.T8+import Regression.T9  main :: IO () main = defaultMain suite  suite :: TestTree suite = testGroup "Ether"-    [ testGroup "ReaderT"-        [ testProperty "layered sum (local left)" layeredLocalLeft-        , testProperty "layered sum (local right)" layeredLocalRight-        ]-    ]--layeredLocalLeft, layeredLocalRight-    :: Fun (Int, Integer) Integer-    -> Fun Integer Integer-    -> Int -> Integer -> Property--layeredLocalLeft k f a1 a2 = property (direct == run indirect)-  where-    run = flip (runReader r1) a1 . flip (runReaderT r2) a2-    (direct, indirect) = layeredLocalCore' k f a1 a2--layeredLocalRight k f a1 a2 = property (direct == run indirect)-  where-    run = flip (runReader r2) a2 . flip (runReaderT r1) a1-    (direct, indirect) = layeredLocalCore' k f a1 a2--layeredLocalCore-    :: Ether '[R1 --> r1, R2 --> r2] m-    => (r2 -> r2) -> (r1 -> r2 -> a) -> m a-layeredLocalCore f g = do-    n <- ask r1-    m <- local r2 f (ask r2)-    return (g n m)--layeredLocalCore'-    :: Ether '[R1 --> Int, R2 --> Integer] m-    => Fun (Int, Integer) Integer-    -> Fun Integer Integer-    -> Int -> Integer -> (Integer, m Integer)-layeredLocalCore' k f a1 a2 = (direct, indirect)-  where-    direct = apply k (fromIntegral a1, apply f a2)-    indirect = layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))--implicitCore :: Ether '[I.R Int, I.R Bool] m => m String-implicitCore = I.local (succ :: Int -> Int) $ do-    n :: Int <- I.ask-    b <- I.local not I.ask-    return (if b then "" else show n)--wrapCore :: (T.MonadReader Int m, T.MonadState Int m) => m Int-wrapCore = do-    b <- T.get-    a <- T.ask-    T.put (a + b)-    return (a * b)--wrapCore' :: Ether '[S1 --> Int, S1 <-> Int, R1 --> Int] m => m Int-wrapCore' = do-    a <- ethered s1 wrapCore-    c <- ask r1-    return (a + c)--wrapCore'' :: Int -> (Int, Int)-wrapCore'' a = runReader r1 (runStateT s1 (runReaderT s1 wrapCore' a) a) (-1)---- Should not compile with `ensureUniqueTags`-uniqueTagsCore :: IO ()-uniqueTagsCore = flip (runReaderT r1) (1 :: Int)-               . flip (runReaderT r1) (True :: Bool)-               . flip (runReaderT r1) (2 :: Int)-               . flip (runReaderT r1) (3 :: Integer)-            {- . ensureUniqueTags -}-               $ do-                    a :: Integer <- ask r1-                    b :: Int <- ask r1-                    c :: Bool <- ask r1-                    T.liftIO $ do-                        print a-                        print b-                        print c--stateCore :: (Ether '[S1 <-> Int, R1 --> Int] m, UniqueTags m) => m ()-stateCore = ensureUniqueTags $ do-    a <- ask r1-    n <- get s1-    put s1 (n * a)-    modify s1 (subtract 1)--recurseCore :: (Num a, Ord a) => Ether '[I.R a, I.S Int]m => m a-recurseCore = do-    a <- I.ask-    if (a <= 0)-        then do-            I.put (0 :: Int)-            return 1-        else do-            I.modify (succ :: Int -> Int)-            b <- I.runReaderT recurseCore (a - 1)-            I.modify (succ :: Int -> Int)-            return (a * b)--factorial :: (Num a, Ord a) => a -> (a, Int)-factorial a = I.runState (I.runReaderT recurseCore a) (0 :: Int)--factorial' :: Int -> (Int, Int)-factorial' a = factorial (a :: Int)--data DivideByZero = DivideByZero-    deriving (Show)-data NegativeLog a = NegativeLog a-    deriving (Show)--exceptCore-    :: ( Floating a, Ord a-       , Ether '[I.E DivideByZero, I.E (NegativeLog a)] m-       ) => a -> a -> m a-exceptCore a b = do-    T.when (b == 0) (I.throw DivideByZero)-    let d = a /b-    T.when (d < 0) (I.throw (NegativeLog d))-    return (log d)--(&) :: a -> (a -> c) -> c-(&) = flip ($)--exceptCore' :: Double -> Double -> String-exceptCore' a b = do-    liftM show (exceptCore a b)-    &I.handleT (\(NegativeLog (x::Double)) -> "nl: " ++ show x)-    &I.handle  (\DivideByZero -> "dz")--summatorCore-    :: ( Num a-       , T.MonadWriter (Sum a) m-       , MonadWriter Foo (Sum a) m-       ) => [a] -> m ()-summatorCore xs = do-    forM_ xs $ \x -> do-        T.tell (Sum x)-        tell foo (Sum 1)--summatorCore' :: Num a => [a] -> (Sum a, Sum a)-summatorCore' = runWriter foo . T.execWriterT . summatorCore--wrapState_f :: T.MonadState Int m => m String-wrapState_f = liftM show T.get--wrapState_g :: T.MonadState Bool m => m String-wrapState_g = liftM show T.get--wrapState_useboth :: Ether '[Foo <-> Int, Bar <-> Bool] m => m String-wrapState_useboth = do-    a <- ethered foo wrapState_f-    b <- ethered bar wrapState_g-    return (a ++ b)--wrapStateCore :: Int -> Bool -> String-wrapStateCore int bool = evalState foo (evalStateT bar wrapState_useboth bool) int--wrapStateBad1_g :: MonadState Foo Int m => m ()-wrapStateBad1_g = modify foo (*100)--wrapStateBad1_useboth :: MonadState Foo Int m => m String-wrapStateBad1_useboth = do-    wrapStateBad1_g-    ethered foo wrapState_f--wrapStateBad1 :: Int -> String-wrapStateBad1 = evalState foo wrapStateBad1_useboth--wrapStateBad2 :: (T.MonadState Int m , MonadState Foo Int m) => m Int-wrapStateBad2 = do-    modify foo (*100)-    T.get--wrapStateBad2Core :: Int -> Int-wrapStateBad2Core = evalState foo (ensureUniqueTags $ ethered foo wrapStateBad2)--wrapReaderCore :: Int -> Int-wrapReaderCore = runReader foo (ethered foo (liftM2 (+) T.ask (ask foo)))+  [ test1+  , test2+  , test3+  , test4+  , test5+  , test6+  , test7+  , test8+  , test9+  ]

@@ -0,0 +1,39 @@+module Regression.T1 (test1) where++import Control.Monad.Ether+import Control.Ether.Abbr++import Test.Tasty+import Test.Tasty.QuickCheck++ethereal "Tag1" "tag1"+ethereal "Tag2" "tag2"++testEther+  :: Ether '[Tag1 --> String, Tag2 --> String] m+  => m ((String, String), (String, String))+testEther = do+  s1 <- ask tag1+  s2 <- ask tag2+  let s1s2 = (s1, s2)+  s1s2' <- local tag2 (map succ) $ do+    s1' <- ask tag1+    s2' <- ask tag2+    return (s1', s2')+  return (s1s2, s1s2')++runner1 s1 s2 = flip (runReader tag1) s1 . flip (runReaderT tag2) s2+runner2 s1 s2 = flip (runReader tag2) s2 . flip (runReaderT tag1) s1++test1 :: TestTree+test1 = testGroup "T1: Reader local environment"+  [ testProperty "runner₁ works"+      $ \s1 s2 -> property+      $ runner1 s1 s2 testEther == ((s1, s2), (s1, map succ s2))+  , testProperty "runner₂ works"+      $ \s1 s2 -> property+      $ runner2 s1 s2 testEther == ((s1, s2), (s1, map succ s2))+  , testProperty "runner₁ == runner₂"+      $ \s1 s2 -> property+      $ runner1 s1 s2 testEther == runner2 s1 s2 testEther+  ]

@@ -0,0 +1,30 @@+module Regression.T2 (test2) where++import Control.Ether.Abbr+import qualified Control.Monad.Ether.Implicit as I+import qualified Control.Ether.Implicit.Abbr as I++import Test.Tasty+import Test.Tasty.QuickCheck++testEther :: Ether '[I.R Integer, I.R Bool] m => m String+testEther = I.local (succ :: Integer -> Integer) $ do+  n :: Integer <- I.ask+  b <- I.local not I.ask+  return (if b then "" else show n)++runner1 (n :: Integer) = flip I.runReader n . flip I.runReaderT True+runner2 (n :: Integer) = flip I.runReader True . flip I.runReaderT n++test2 :: TestTree+test2 = testGroup "T2: Implicit tags"+  [ testProperty "runner₁ works"+    $ \n -> property+    $ runner1 n testEther == show (succ n)+  , testProperty "runner₂ works"+    $ \n -> property+    $ runner2 n testEther == show (succ n)+  , testProperty "runner₁ == runner₂"+    $ \n -> property+    $ runner1 n testEther == runner2 n testEther+  ]

@@ -0,0 +1,56 @@+module Regression.T3 (test3) where++import Control.Ether.Abbr+import Control.Monad.Ether++import qualified Control.Monad.Reader as T+import qualified Control.Monad.State as T++import Test.Tasty+import Test.Tasty.QuickCheck++ethereal "RTag" "rTag"+ethereal "STag" "sTag"++testMTL :: (T.MonadReader Int m, T.MonadState Int m) => m Int+testMTL = do+  b <- T.get+  a <- T.ask+  T.put (a + b)+  return (a * b)++testEther+  :: Ether '[STag --> Int, STag <-> Int, RTag --> Int] m+  => m (Int, Int, Int)+testEther = local rTag (*2) $ do+  a_mul_b <- tagAttach sTag testMTL+  a_add_b <- get sTag+  modify sTag negate+  c <- ask rTag+  return (a_mul_b, a_add_b, c)++runner1 s r+  = flip (runReader  rTag) (negate r)+  . flip (runReaderT sTag) r+  . flip (runStateT  sTag) s+runner2 s r+  = flip (runReader  rTag) (negate r)+  . flip (runStateT  sTag) s+  . flip (runReaderT sTag) r++test3 :: TestTree+test3 = testGroup "T3: Tag attachement"+  [ testProperty "runner₁ works"+    $ \s r -> property+    $ (==)+        (runner1 s r testEther)+        ((s * r, s + r, negate r * 2), negate (s + r))+  , testProperty "runner₂ works"+    $ \s r -> property+    $ (==)+        (runner2 s r testEther)+        ((s * r, s + r, negate r * 2), negate (s + r))+  , testProperty "runner₁ == runner₂"+    $ \s r -> property+    $ runner1 s r testEther == runner2 s r testEther+  ]

@@ -0,0 +1,25 @@+module Regression.T4 (test4) where++import Control.Ether.Abbr+import Control.Monad.Ether++import Test.Tasty+import Test.Tasty.QuickCheck++ethereal "RTag" "rTag"++testEther :: Ether '[RTag --> Int] m => m Int+testEther = ask rTag++runner r+  = flip (runReader  rTag) (r' :: Int)+  . flip (runReaderT rTag) (r  :: Int)+  where+    r' = negate r++test4 :: TestTree+test4 = testGroup "T4: Nested same-tag readers"+  [ testProperty "runner works"+    $ \r -> property+    $ runner r testEther == r+  ]

@@ -0,0 +1,45 @@+module Regression.T5 (test5) where++import Control.Ether.Abbr++import qualified Control.Monad.Ether.Implicit as I+import qualified Control.Ether.Implicit.Abbr as I++import Test.Tasty+import Test.Tasty.QuickCheck++newtype Counter = Counter Int+  deriving (Eq, Ord, Num, Enum)++incCounter :: Counter -> Counter+incCounter = succ++testEther+  :: (Num a, Ord a)+  => Ether '[I.R a, I.S Counter] m+  => m a+testEther = do+  a <- I.ask+  if a <= 0+    then do+      I.put (0 :: Counter)+      return 1+    else do+      I.modify incCounter -- overriden in the base case+      b <- I.runReaderT testEther (a - 1)+      I.modify incCounter+      return (a * b)++runner :: (Num a, Ord a) => a -> (a, Counter)+runner a = I.runState (I.runReaderT testEther a) (0 :: Counter)++factorial :: (Num a, Enum a) => a -> a+factorial a = product [1..a]++test5 :: TestTree+test5 = testGroup "T5: Factorial via Ether"+  [ testProperty "runner works"+    $ \n -> property+    $ let n' = fromIntegral n :: Integer+      in runner n' == (factorial n', max 0 (Counter n))+  ]

@@ -0,0 +1,66 @@+module Regression.T6 (test6) where++import Control.Monad+import Control.Ether.Abbr++import qualified Control.Monad.Ether.Implicit as I+import qualified Control.Ether.Implicit.Abbr as I++import Test.Tasty+import Test.Tasty.QuickCheck++data DivideByZero = DivideByZero+    deriving (Show)++data NegativeLog a = NegativeLog a+    deriving (Show)++testEther+  :: (Floating a, Ord a)+  => Ether '[I.E DivideByZero, I.E (NegativeLog a)] m+  => a -> a -> m a+testEther a b = do+  when (b == 0) (I.throw DivideByZero)+  let d = a / b+  when (d < 0) (I.throw (NegativeLog d))+  return (log d)++-- Copied verbatim from "Data.Function" to support @base < 4.8@.+(&) :: a -> (a -> b) -> b+x & f = f x++handleNegativeLog (NegativeLog (x :: Double)) = "nl: " ++ show x+handleDivideByZero DivideByZero = "dz"++runner1 :: Double -> Double -> String+runner1 a b = do+  (show `fmap` testEther a b)+    & I.handleT handleNegativeLog+    & I.handle  handleDivideByZero++runner2 :: Double -> Double -> String+runner2 a b = do+  (show `fmap` testEther a b)+    & I.handleT handleDivideByZero+    & I.handle  handleNegativeLog++logDiv :: Double -> Double -> String+logDiv a b+  | b == 0    = "dz"+  | d  < 0    = "nl: " ++ show d+  | otherwise = show (log d)+  where+    d = a / b++test6 :: TestTree+test6 = testGroup "T6: Checked exceptions"+  [ testProperty "runner₁ works"+    $ \a b -> property+    $ runner1 a b == logDiv a b+  , testProperty "runner₂ works"+    $ \a b -> property+    $ runner2 a b == logDiv a b+  , testProperty "runner₁ == runner₂"+    $ \a b -> property+    $ runner1 a b == runner2 a b+  ]

@@ -0,0 +1,50 @@+module Regression.T7 (test7) where++import Data.Monoid+import Control.Monad++import Control.Monad.Ether+import qualified Control.Monad.Writer as T++import Test.Tasty+import Test.Tasty.QuickCheck++ethereal "WTag" "wTag"++testEther+  :: Num a+  => T.MonadWriter (Sum a) m+  => MonadWriter WTag (Sum a) m+  => [a] -> m ()+testEther xs = do+  forM_ xs $ \x -> do+    T.tell (Sum x)+    tell wTag (Sum 1)++runner1 :: Num a => [a] -> (a, a)+runner1 xs =+  let (s, c) = T.runWriter . execWriterT wTag $ testEther xs+  in (getSum s, getSum c)++runner2 :: Num a => [a] -> (a, a)+runner2 xs =+  let (c, s) = runWriter wTag . T.execWriterT $ testEther xs+  in (getSum s, getSum c)++triangular :: Integral a => a -> a+triangular n = div (n * (n + 1)) 2++test7 :: TestTree+test7 = testGroup "T7: Triangular via Ether"+  [ testProperty "runner₁ works"+    $ \n -> property+    $ let n' = abs n :: Integer+      in runner1 [1..n'] == (n', triangular n')+  , testProperty "runner₂ works"+    $ \n -> property+    $ let n' = abs n :: Integer+      in runner2 [1..n'] == (n', triangular n')+  , testProperty "runner₁ == runner₂"+    $ \(ns :: [Integer]) -> property+    $ runner1 ns == runner2 ns+  ]

@@ -0,0 +1,52 @@+module Regression.T8 (test8) where++import Control.Ether.Abbr+import Control.Monad.Ether++import qualified Control.Monad.State as T++import Test.Tasty+import Test.Tasty.QuickCheck++ethereal "Foo" "foo"+ethereal "Bar" "bar"++testMTL1 :: T.MonadState Int m => m ()+testMTL1 = T.modify negate++testMTL2 :: T.MonadState Bool m => m ()+testMTL2 = T.modify not++testEther+  :: Ether '[Foo <-> Int, Bar <-> Bool] m+  => m String+testEther = do+  tagAttach foo testMTL1+  tagAttach bar testMTL2+  a <- gets foo show+  b <- gets bar show+  return (a ++ b)++model :: Int -> Bool -> String+model a b = show (negate a) ++ show (not b)++runner1 a b+  = flip (evalState  foo) a+  . flip (evalStateT bar) b++runner2 a b+  = flip (evalState  bar) b+  . flip (evalStateT foo) a++test8 :: TestTree+test8 = testGroup "T8: Multiple tag attachements"+  [ testProperty "runner₁ works"+    $ \a b -> property+    $ runner1 a b testEther == model a b+  , testProperty "runner₂ works"+    $ \a b -> property+    $ runner2 a b testEther == model a b+  , testProperty "runner₁ == runner₂"+    $ \a b -> property+    $ runner1 a b testEther == runner2 a b testEther+  ]

@@ -0,0 +1,51 @@+module Regression.T9 (test9) where++import Control.Ether.Abbr+import Control.Monad.Ether++import Test.Tasty+import Test.Tasty.QuickCheck++ethereal "Foo" "foo"+ethereal "Bar" "bar"+++testEther1 :: Ether '[Foo <-> Int] m => m String+testEther1 = do+  modify foo negate+  gets foo show++testEther2 :: Ether '[Bar <-> Int] m => m String+testEther2 = tagReplace foo bar testEther1++testEther+  :: Ether '[Foo <-> Int, Bar <-> Int] m+  => m String+testEther = do+  a <- testEther1+  b <- testEther2+  return (a ++ b)++model :: Int -> Int -> String+model a b = show (negate a) ++ show (negate b)++runner1 a b+  = flip (evalState  foo) a+  . flip (evalStateT bar) b++runner2 a b+  = flip (evalState  bar) b+  . flip (evalStateT foo) a++test9 :: TestTree+test9 = testGroup "T9: Tag replacement"+  [ testProperty "runner₁ works"+    $ \a b -> property+    $ runner1 a b testEther == model a b+  , testProperty "runner₂ works"+    $ \a b -> property+    $ runner2 a b testEther == model a b+  , testProperty "runner₁ == runner₂"+    $ \a b -> property+    $ runner1 a b testEther == runner2 a b testEther+  ]