Bypass Coercible Type for Deriving Monad* Classes of New Transformers Composed of Transformers

Control/Monad/Reader.hs

@@ -40,6 +40,8 @@ module Control.Monad.Reader (
     -- * MonadReader class
     MonadReader.MonadReader(..),
     MonadReader.asks,
+    -- * Lifting helper type
+    MonadReader.LiftingReader,
     -- * The Reader monad
     Reader,
     runReader,

Control/Monad/Reader/Class.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -7,6 +7,9 @@
 -- Needed because the CPSed versions of Writer and State are secretly State
 -- wrappers, which don't force such constraints, even though they should legally
 -- be there.
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
 {- |
 Module      :  Control.Monad.Reader.Class
@@ -48,6 +51,7 @@ than using the 'Control.Monad.State.State' monad.
 module Control.Monad.Reader.Class (
     MonadReader(..),
     asks,
+    LiftingReader(..),
     ) where
 
 import qualified Control.Monad.Trans.Cont as Cont
@@ -68,7 +72,9 @@ import qualified Control.Monad.Trans.Accum as Accum
 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 Control.Monad.Trans.Class (MonadTrans(lift))
+import Data.Kind (Type)
+import Data.Coerce (coerce)
 
 -- ----------------------------------------------------------------------------
 -- class MonadReader
@@ -202,3 +208,35 @@ instance
       r <- ask
       local f (runSelectT m (local (const r) . c))
     reader = lift . reader
+
+-- | A helper type to decrease boilerplate when defining new transformer
+-- instances of 'MonadReader'.
+--
+-- @since ????
+type LiftingReader :: ((Type -> Type) -> Type -> Type) -> (Type -> Type) -> Type -> Type
+newtype LiftingReader t m a = LiftingReader (t m a)
+  deriving (Functor, Applicative, Monad, MonadTrans)
+
+mapLiftingReader :: (t m a -> t m b) -> LiftingReader t m a -> LiftingReader t m b
+mapLiftingReader = coerce
+
+instance (MonadReader r m, Monoid w) => MonadReader r (LiftingReader (LazyRWS.RWST r' w s) m) where
+  ask = lift ask
+  local = mapLiftingReader . LazyRWS.mapRWST . local
+  reader = lift . reader
+
+instance (MonadReader r m, Monoid w) => MonadReader r (LiftingReader (StrictRWS.RWST r' w s) m) where
+  ask = lift ask
+  local = mapLiftingReader . StrictRWS.mapRWST . local
+  reader = lift . reader
+
+instance (MonadReader r m, Monoid w) => MonadReader r (LiftingReader (CPSRWS.RWST r' w s) m) where
+  ask = lift ask
+  local = mapLiftingReader . CPSRWS.mapRWST . local
+  reader = lift . reader
+
+instance MonadReader r m => MonadReader r (LiftingReader (ReaderT r') m) where
+  ask = lift ask
+  local = mapLiftingReader . ReaderT.mapReaderT . local
+  reader = lift . reader
+

Control/Monad/State/Class.hs

@@ -1,4 +1,6 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -33,7 +35,8 @@ module Control.Monad.State.Class (
     MonadState(..),
     modify,
     modify',
-    gets
+    gets,
+    LiftingState
   ) where
 
 import Control.Monad.Trans.Cont (ContT)
@@ -51,7 +54,8 @@ import Control.Monad.Trans.Accum (AccumT)
 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 Control.Monad.Trans.Class (MonadTrans(lift))
+import Data.Kind (Type)
 
 -- ---------------------------------------------------------------------------
 
@@ -192,3 +196,17 @@ instance MonadState s m => MonadState s (SelectT r m) where
     get = lift get
     put = lift . put
     state = lift . state
+
+-- | A helper type to decrease boilerplate when defining new transformer
+-- instances of 'MonadState'.
+--
+-- @since ????
+type LiftingState :: ((Type -> Type) -> Type -> Type) -> (Type -> Type) -> Type -> Type
+newtype LiftingState t m a = LiftingState (t m a)
+  deriving (Functor, Applicative, Monad, MonadTrans)
+
+instance (MonadState s m, MonadTrans t, Monad (t m)) => MonadState s (LiftingState t m) where
+  get = lift get
+  put = lift . put
+  state = lift . state
+

Control/Monad/Writer/CPS.hs

@@ -26,6 +26,8 @@ module Control.Monad.Writer.CPS (
     MonadWriter.MonadWriter(..),
     MonadWriter.listens,
     MonadWriter.censor,
+    -- * Lifting helper type
+    MonadWriter.LiftingWriter,
     -- * The Writer monad
     Writer,
     runWriter,

Control/Monad/Writer/Class.hs

@@ -1,7 +1,9 @@
-{-# LANGUAGE Safe #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE UndecidableInstances #-}
 -- Search for UndecidableInstances to see why this is needed
 
@@ -28,6 +30,7 @@ module Control.Monad.Writer.Class (
     MonadWriter(..),
     listens,
     censor,
+    LiftingWriter(..),
   ) where
 
 import Control.Monad.Trans.Except (ExceptT)
@@ -47,7 +50,9 @@ import Control.Monad.Trans.Accum (AccumT)
 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 Control.Monad.Trans.Class (MonadTrans(lift))
+import Data.Kind (Type)
+import Data.Coerce (coerce)
 
 -- ---------------------------------------------------------------------------
 -- MonadWriter class
@@ -205,3 +210,56 @@ instance
     tell   = lift . tell
     listen = Accum.liftListen listen
     pass   = Accum.liftPass pass
+
+type LiftingWriter :: ((Type -> Type) -> Type -> Type) -> (Type -> Type) -> Type -> Type
+newtype LiftingWriter t m a = LiftingWriter {runLiftingWriter :: t m a}
+  deriving (Functor, Applicative, Monad, MonadTrans)
+
+mapLiftingWriter :: (t m a -> t m b) -> LiftingWriter t m a -> LiftingWriter t m b
+mapLiftingWriter = coerce
+
+formatWriter :: ((a,b),c) -> ((a,c),b)
+formatWriter ((a,b),c) = ((a,c),b)
+
+instance (MonadWriter w m, Monoid w') => MonadWriter w (LiftingWriter (Lazy.WriterT w') m) where
+    writer = lift . writer
+    tell   = lift . tell
+    listen = mapLiftingWriter $ Lazy.mapWriterT $ fmap formatWriter . listen
+    pass = mapLiftingWriter $ Lazy.mapWriterT $ pass . fmap formatWriter
+
+instance (MonadWriter w m, Monoid w') => MonadWriter w (LiftingWriter (Strict.WriterT w') m) where
+    writer = lift . writer
+    tell   = lift . tell
+    listen = mapLiftingWriter $ Strict.mapWriterT $ fmap formatWriter . listen
+    pass = mapLiftingWriter $ Strict.mapWriterT $ pass . fmap formatWriter
+
+instance (MonadWriter w m, Monoid w') => MonadWriter w (LiftingWriter (CPS.WriterT w') m) where
+    writer = lift . writer
+    tell   = lift . tell
+    listen = mapLiftingWriter $ CPS.mapWriterT $ fmap formatWriter . listen
+    pass = mapLiftingWriter $ CPS.mapWriterT $ pass . fmap formatWriter
+
+formatListenRWS :: ((a,b,c),d) -> ((a,d),b,c)
+formatListenRWS ((a,b,c),d) = ((a,d),b,c)
+
+formatPassRWS :: ((a,b),c,d) -> ((a,c,d),b)
+formatPassRWS ((a,b),c,d) = ((a,c,d),b)
+
+instance (MonadWriter w m, Monoid w') => MonadWriter w (LiftingWriter (LazyRWS.RWST r w' s) m) where
+    writer = lift . writer
+    tell   = lift . tell
+    listen = mapLiftingWriter $ LazyRWS.mapRWST $ fmap formatListenRWS . listen
+    pass = mapLiftingWriter $ LazyRWS.mapRWST $ pass . fmap formatPassRWS
+
+instance (MonadWriter w m, Monoid w') => MonadWriter w (LiftingWriter (StrictRWS.RWST r w' s) m) where
+    writer = lift . writer
+    tell   = lift . tell
+    listen = mapLiftingWriter $ StrictRWS.mapRWST $ fmap formatListenRWS . listen
+    pass = mapLiftingWriter $ StrictRWS.mapRWST $ pass . fmap formatPassRWS
+
+instance (MonadWriter w m, Monoid w') => MonadWriter w (LiftingWriter (CPSRWS.RWST r w' s) m) where
+    writer = lift . writer
+    tell   = lift . tell
+    listen = mapLiftingWriter $ CPSRWS.mapRWST $ fmap formatListenRWS . listen
+    pass = mapLiftingWriter $ CPSRWS.mapRWST $ pass . fmap formatPassRWS
+

Control/Monad/Writer/Lazy.hs

@@ -23,6 +23,8 @@ module Control.Monad.Writer.Lazy (
     MonadWriter.MonadWriter(..),
     MonadWriter.listens,
     MonadWriter.censor,
+    -- * Lifting helper type
+    MonadWriter.LiftingWriter,
     -- * The Writer monad
     Writer,
     runWriter,

Control/Monad/Writer/Strict.hs

@@ -23,6 +23,8 @@ module Control.Monad.Writer.Strict (
     MonadWriter.MonadWriter(..),
     MonadWriter.listens,
     MonadWriter.censor,
+    -- * Lifting helper type
+    MonadWriter.LiftingWriter,
     -- * The Writer monad
     Writer,
     runWriter,