diff --git a/Control/Monad/Error/Class.hs b/Control/Monad/Error/Class.hs index bbbd9a5..9fb40e5 100644 --- a/Control/Monad/Error/Class.hs +++ b/Control/Monad/Error/Class.hs @@ -74,6 +74,7 @@ import qualified Control.Monad.Trans.Writer.CPS as CPSWriter import Control.Monad.Trans.Class (lift) import Control.Exception (IOException, catch, ioError) import Control.Monad (Monad ((>>=), (>>))) +import Data.Functor.Product (Product(..)) import Data.Monoid (Monoid) import Prelude (Either (Left, Right), Maybe (Nothing), either, flip, (.), IO, pure, (<$>)) @@ -206,6 +207,13 @@ instance throwError = lift . throwError catchError = Accum.liftCatch catchError +instance (MonadError e m, MonadError e n) => MonadError e (Product m n) where + throwError e = Pair (throwError e) (throwError e) + catchError (Pair ma na) f = Pair (catchError ma (productFst . f)) (catchError na (productSnd . f)) + where + productFst (Pair a _) = a + productSnd (Pair _ b) = b + -- | 'MonadError' analogue to the 'Control.Exception.try' function. -- -- @since 2.3 diff --git a/Control/Monad/RWS/Class.hs b/Control/Monad/RWS/Class.hs index ef0866d..586e2e1 100644 --- a/Control/Monad/RWS/Class.hs +++ b/Control/Monad/RWS/Class.hs @@ -41,6 +41,7 @@ import Control.Monad.Trans.Identity (IdentityT) import qualified Control.Monad.Trans.RWS.CPS as CPS (RWST) import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST) import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST) +import Data.Functor.Product (Product(..)) class (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m) => MonadRWS r w s m | m -> r, m -> w, m -> s @@ -62,3 +63,5 @@ instance (Monoid w, Monad m) => MonadRWS r w s (Strict.RWST r w s m) instance MonadRWS r w s m => MonadRWS r w s (ExceptT e m) instance MonadRWS r w s m => MonadRWS r w s (IdentityT m) instance MonadRWS r w s m => MonadRWS r w s (MaybeT m) + +instance (MonadRWS r w s m, MonadRWS r w s n) => MonadRWS r w s (Product m n) diff --git a/Control/Monad/Reader/Class.hs b/Control/Monad/Reader/Class.hs index 6cb83dd..f216d5c 100644 --- a/Control/Monad/Reader/Class.hs +++ b/Control/Monad/Reader/Class.hs @@ -69,6 +69,7 @@ import Control.Monad.Trans.Select (SelectT (SelectT), runSelectT) import qualified Control.Monad.Trans.RWS.CPS as CPSRWS import qualified Control.Monad.Trans.Writer.CPS as CPS import Control.Monad.Trans.Class (lift) +import Data.Functor.Product (Product(..)) -- ---------------------------------------------------------------------------- -- class MonadReader @@ -202,3 +203,7 @@ instance r <- ask local f (runSelectT m (local (const r) . c)) reader = lift . reader + +instance (MonadReader r m, MonadReader r n) => MonadReader r (Product m n) where + ask = Pair ask ask + local f (Pair ma na) = Pair (local f ma) (local f na) diff --git a/Control/Monad/State/Class.hs b/Control/Monad/State/Class.hs index df5a33d..71f0770 100644 --- a/Control/Monad/State/Class.hs +++ b/Control/Monad/State/Class.hs @@ -52,6 +52,7 @@ import Control.Monad.Trans.Select (SelectT) import qualified Control.Monad.Trans.RWS.CPS as CPSRWS import qualified Control.Monad.Trans.Writer.CPS as CPS import Control.Monad.Trans.Class (lift) +import Data.Functor.Product (Product(..)) -- --------------------------------------------------------------------------- @@ -192,3 +193,7 @@ instance MonadState s m => MonadState s (SelectT r m) where get = lift get put = lift . put state = lift . state + +instance (MonadState s m, MonadState s n) => MonadState s (Product m n) where + get = Pair get get + put s = Pair (put s) (put s) diff --git a/Control/Monad/Writer/Class.hs b/Control/Monad/Writer/Class.hs index 11c156a..980cfb3 100644 --- a/Control/Monad/Writer/Class.hs +++ b/Control/Monad/Writer/Class.hs @@ -48,6 +48,7 @@ import qualified Control.Monad.Trans.Accum as Accum import qualified Control.Monad.Trans.RWS.CPS as CPSRWS import qualified Control.Monad.Trans.Writer.CPS as CPS import Control.Monad.Trans.Class (lift) +import Data.Functor.Product (Product(..)) -- --------------------------------------------------------------------------- -- MonadWriter class @@ -205,3 +206,8 @@ instance tell = lift . tell listen = Accum.liftListen listen pass = Accum.liftPass pass + +instance (MonadWriter w m, MonadWriter w n) => MonadWriter w (Product m n) where + tell w = Pair (tell w) (tell w) + listen (Pair ma na) = Pair (listen ma) (listen na) + pass (Pair maf naf) = Pair (pass maf) (pass naf)