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,8 @@ 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)
 
 -- ----------------------------------------------------------------------------
 -- class MonadReader
@@ -202,3 +207,31 @@ 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)
+
+instance (MonadReader r m, Monoid w) => MonadReader r (LiftingReader (LazyRWS.RWST r' w s) m) where
+  ask = lift ask
+  local f (LiftingReader (LazyRWS.RWST x)) = LiftingReader . LazyRWS.RWST $ \r s -> local f $ x r s
+  reader = lift . reader
+
+instance (MonadReader r m, Monoid w) => MonadReader r (LiftingReader (StrictRWS.RWST r' w s) m) where
+  ask = lift ask
+  local f (LiftingReader (StrictRWS.RWST x)) = LiftingReader . StrictRWS.RWST $ \r s -> local f $ x r s
+  reader = lift . reader
+
+instance (MonadReader r m, Monoid w) => MonadReader r (LiftingReader (CPSRWS.RWST r' w s) m) where
+  ask = lift ask
+  local f (LiftingReader (CPSRWS.runRWST -> x)) = LiftingReader . CPSRWS.rwsT $ \r s -> local f $ x r s
+  reader = lift . reader
+
+instance MonadReader r m => MonadReader r (LiftingReader (ReaderT r') m) where
+  ask = lift ask
+  local f (LiftingReader (ReaderT.ReaderT x)) = LiftingReader . ReaderT.ReaderT $ local f . x
+  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,37 @@ 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, Monoid w) => MonadState s (LiftingState (LazyRWS.RWST r w s') m) where
+  get = lift get
+  put = lift . put
+  state = lift . state
+
+instance (MonadState s m, Monoid w) => MonadState s (LiftingState (StrictRWS.RWST r w s') m) where
+  get = lift get
+  put = lift . put
+  state = lift . state
+
+instance (MonadState s m, Monoid w) => MonadState s (LiftingState (CPSRWS.RWST r w s') m) where
+  get = lift get
+  put = lift . put
+  state = lift . state
+
+instance MonadState s m => MonadState s (LiftingState (Lazy.StateT s') m) where
+  get = lift get
+  put = lift . put
+  state = lift . state
+
+instance MonadState s m => MonadState s (LiftingState (Strict.StateT s') 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,8 +1,13 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
 -- Search for UndecidableInstances to see why this is needed
 
 -----------------------------------------------------------------------------
@@ -28,6 +33,7 @@ module Control.Monad.Writer.Class (
     MonadWriter(..),
     listens,
     censor,
+    LiftingWriter(..),
   ) where
 
 import Control.Monad.Trans.Except (ExceptT)
@@ -47,7 +53,8 @@ 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)
 
 -- ---------------------------------------------------------------------------
 -- MonadWriter class
@@ -205,3 +212,80 @@ instance
     tell   = lift . tell
     listen = Accum.liftListen listen
     pass   = Accum.liftPass pass
+
+
+-- | A helper type to decrease boilerplate when defining new transformer
+-- instances of 'MonadWriter'.
+--
+-- @since ????
+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)
+
+
+instance (Monoid w', MonadWriter w m) => MonadWriter w (LiftingWriter (LazyRWS.RWST r w' s) m) where
+  writer = lift . writer
+  tell = lift . tell
+  listen (LiftingWriter (LazyRWS.RWST x)) = LiftingWriter $ LazyRWS.RWST $ \r s -> do
+    ((a, s, w'), w) <- listen $ x r s
+    pure ((a, w), s, w')
+  pass (LiftingWriter (LazyRWS.RWST x)) = LiftingWriter $ LazyRWS.RWST $ \r s -> do
+    (y, s, w') <- x r s
+    a <- pass $ pure y
+    pure (a, s, w')
+
+instance (Monoid w', MonadWriter w m) => MonadWriter w (LiftingWriter (StrictRWS.RWST r w' s) m) where
+  writer = lift . writer
+  tell = lift . tell
+  listen (LiftingWriter (StrictRWS.RWST x)) = LiftingWriter $ StrictRWS.RWST $ \r s -> do
+    ((a, s, w'), w) <- listen $ x r s
+    pure ((a, w), s, w')
+  pass (LiftingWriter (StrictRWS.RWST x)) = LiftingWriter $ StrictRWS.RWST $ \r s -> do
+    (y, s, w') <- x r s
+    a <- pass $ pure y
+    pure (a, s, w')
+
+instance (Monoid w', MonadWriter w m) => MonadWriter w (LiftingWriter (CPSRWS.RWST r w' s) m) where
+  writer = lift . writer
+  tell = lift . tell
+  listen (LiftingWriter (CPSRWS.runRWST -> x)) = LiftingWriter $ CPSRWS.rwsT $ \r s -> do
+    ((a, s, w'), w) <- listen $ x r s
+    pure ((a, w), s, w')
+  pass (LiftingWriter (CPSRWS.runRWST -> x)) = LiftingWriter $ CPSRWS.rwsT $ \r s -> do
+    (y, s, w') <- x r s
+    a <- pass $ pure y
+    pure (a, s, w')
+
+instance (Monoid w', MonadWriter w m) => MonadWriter w (LiftingWriter (Lazy.WriterT w') m) where
+  writer = lift . writer
+  tell = lift . tell
+  listen (LiftingWriter (Lazy.WriterT x)) = LiftingWriter $ Lazy.WriterT $ do
+    ((a, w'), w) <- listen x
+    pure ((a, w), w')
+  pass (LiftingWriter (Lazy.WriterT x)) = LiftingWriter $ Lazy.WriterT $ do
+    (y, w') <- x
+    a <- pass $ pure y
+    pure (a, w')
+
+instance (Monoid w', MonadWriter w m) => MonadWriter w (LiftingWriter (Strict.WriterT w') m) where
+  writer = lift . writer
+  tell = lift . tell
+  listen (LiftingWriter (Strict.WriterT x)) = LiftingWriter $ Strict.WriterT $ do
+    ((a, w'), w) <- listen x
+    pure ((a, w), w')
+  pass (LiftingWriter (Strict.WriterT x)) = LiftingWriter $ Strict.WriterT $ do
+    (y, w') <- x
+    a <- pass $ pure y
+    pure (a, w')
+
+instance (Monoid w', MonadWriter w m) => MonadWriter w (LiftingWriter (CPS.WriterT w') m) where
+  writer = lift . writer
+  tell = lift . tell
+  listen (LiftingWriter (CPS.runWriterT -> x)) = LiftingWriter $ CPS.writerT $ do
+    ((a, w'), w) <- listen x
+    pure ((a, w), w')
+  pass (LiftingWriter (CPS.runWriterT -> x)) = LiftingWriter $ CPS.writerT $ do
+    (y, w') <- x
+    a <- pass $ pure y
+    pure (a, w')
+

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,