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

Control/Monad/Reader.hs

@@ -50,6 +50,9 @@ module Control.Monad.Reader (
     runReaderT,
     mapReaderT,
     withReaderT,
+    -- * Lifting helper type
+    MonadReader.LiftingReader(..),
+    -- * Lifting into the transformer
     module Control.Monad.Trans,
     -- * Example 1: Simple Reader Usage
     -- $simpleReaderExample

Control/Monad/Reader/Class.hs

@@ -1,9 +1,12 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 -- Search for UndecidableInstances to see why this is needed
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ViewPatterns #-}
 -- 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.
@@ -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,45 @@ 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'.
+--
+-- @
+-- newtype SneakyReaderT m a = SneakyReaderT { runSneakyReaderT :: ReaderT String m a }
+--   deriving (Functor, Applicative, Monad)
+--   deriving (MonadReader r) via LiftingReader (ReaderT String) m
+-- @
+--
+-- @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
+
+-- | @since ????
+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
+
+-- | @since ????
+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
+
+-- | @since ????
+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
+
+-- | @since ????
+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,24 @@ 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'.
+--
+-- @
+-- newtype SneakyStateT m a = SneakyStateT { runSneakyStateT :: Lazy.StateT String m a }
+--   deriving (Functor, Applicative, Monad)
+--   deriving (MonadState s) via LiftingState (Lazy.StateT String) m
+-- @
+--
+-- @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)
+
+-- | @since ????
+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/State/Lazy.hs

@@ -39,6 +39,9 @@ module Control.Monad.State.Lazy (
     execStateT,
     mapStateT,
     withStateT,
+    -- * Lifting helper type
+    MonadState.LiftingState(..),
+    -- * Lifting into the transformer
     module Control.Monad.Trans,
     -- * Examples
     -- $examples

Control/Monad/State/Strict.hs

@@ -39,6 +39,9 @@ module Control.Monad.State.Strict (
     execStateT,
     mapStateT,
     withStateT,
+    -- * Lifting helper type
+    MonadState.LiftingState(..),
+    -- * Lifting into the transformer
     module Control.Monad.Trans,
     -- * Examples
     -- $examples

Control/Monad/Writer/CPS.hs

@@ -35,6 +35,11 @@ module Control.Monad.Writer.CPS (
     WriterT,
     execWriterT,
     mapWriterT,
+    -- * Lifting helper type
+    MonadWriter.LiftingWriter,
+    MonadWriter.LiftWriter(..),
+    MonadWriter.LiftWriterRWS(..),
+    -- * Lifting into the transformer
     module Control.Monad.Trans,
   ) where
 

Control/Monad/Writer/Class.hs

@@ -1,8 +1,16 @@
-{-# LANGUAGE Safe #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
 -- Search for UndecidableInstances to see why this is needed
 
 -----------------------------------------------------------------------------
@@ -28,6 +36,9 @@ module Control.Monad.Writer.Class (
     MonadWriter(..),
     listens,
     censor,
+    LiftingWriter,
+    LiftWriter(..),
+    LiftWriterRWS(..),
   ) where
 
 import Control.Monad.Trans.Except (ExceptT)
@@ -47,7 +58,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, Constraint)
+import Data.Coerce (coerce)
 
 -- ---------------------------------------------------------------------------
 -- MonadWriter class
@@ -205,3 +218,90 @@ instance
     tell   = lift . tell
     listen = Accum.liftListen listen
     pass   = Accum.liftPass pass
+
+-- | A helper type function to decrease boilerplate when defining new
+-- transformer instances of 'MonadWriter'.
+--
+-- Example of deriving 'MonadWriter' from @m@ and not the 'Lazy.WriterT' transformer.
+--
+-- @
+-- newtype SneakyWriterT m a = SneakyWriterT { runSneakyWriterT :: Lazy.WriterT String m a }
+--   deriving (Functor, Applicative, Monad)
+--   deriving (MonadWriter w) via LiftingWriter Lazy.WriterT String m
+-- @
+--
+-- Example of deriving 'MonadWriter' from @m@ and not the 'LazyRWS.RWST' transformer.
+--
+-- @
+-- newtype SneakyRWST m a = SneakyRWST { runSneakyRWST :: LazyRWS.RWST () String () m a }
+--   deriving (Functor, Applicative, Monad)
+--   deriving (MonadWriter w) via LiftingWriter LazyRWS.RWST () String () m
+-- @
+--
+-- | @since ????
+type LiftingWriter :: forall t. t
+type family LiftingWriter where
+  LiftingWriter = LiftWriter
+  LiftingWriter = LiftWriterRWS
+
+-- | Do not use directly; use @LiftingWriter@ instead.
+--
+-- | @since ????
+newtype LiftWriter t w (m :: Type -> Type) a = LiftWriter (t w m a)
+  deriving (Functor, Applicative, Monad, MonadTrans)
+
+-- | Do not use directly; use @LiftingWriter@ instead.
+--
+-- | @since ????
+newtype LiftWriterRWS t r w s (m :: Type -> Type) a = LiftWriterRWS (t r w s m a)
+  deriving (Functor, Applicative, Monad, MonadTrans)
+
+-- | Class that allows new writer transformers to use the existing instance of 'MonadWriter' so that they can be used with 'LiftingWriter' to using the monad's "MonadWriter' instance.
+-- By using this class you only have to define 'mapWriterT' instead of 'writer', 'tell', 'listen', and 'pass'.
+--
+-- | @since ????
+type MapWriter :: (Type -> (Type -> Type) -> Type -> Type) -> Constraint
+class MapWriter t where mapWriterT :: (Monad m, Monoid w) => (m (a, w) -> m (b, w)) -> t w m a -> t w m b
+-- | @since ????
+instance MapWriter Lazy.WriterT where mapWriterT = Lazy.mapWriterT
+-- | @since ????
+instance MapWriter Strict.WriterT where mapWriterT = Strict.mapWriterT
+-- | @since ????
+instance MapWriter CPS.WriterT where mapWriterT = CPS.mapWriterT
+
+-- | Class that allows new reader writer state transformers to use the existing instance of 'MonadWriter' so that they can be used with 'LiftingWriter' to using the monad's "MonadWriter' instance.
+-- By using this class you only have to define 'mapRWST' instead of 'writer', 'tell', 'listen', and 'pass'.
+--
+-- | @since ????
+type MapRWS :: (Type -> Type -> Type -> (Type -> Type) -> Type -> Type) -> Constraint
+class MapRWS t where mapRWST :: (Monad m, Monoid w) => (m (a, s, w) -> m (b, s, w)) -> t r w s m a -> t r w s m b
+-- | @since ????
+instance MapRWS LazyRWS.RWST where mapRWST = LazyRWS.mapRWST
+-- | @since ????
+instance MapRWS StrictRWS.RWST where mapRWST = StrictRWS.mapRWST
+-- | @since ????
+instance MapRWS CPSRWS.RWST where mapRWST = CPSRWS.mapRWST
+
+mapLiftWriter :: (t w m a -> t w m b) -> LiftWriter t w m a -> LiftWriter t w m b
+mapLiftWriter = coerce
+
+formatWriter :: ((a,b),c) -> ((a,c),b)
+formatWriter ((a,b),c) = ((a,c),b)
+
+mapLiftWriterRWS :: (t r w s m a -> t r w s m b) -> LiftWriterRWS t r w s m a -> LiftWriterRWS t r w s m b
+mapLiftWriterRWS = coerce
+
+-- | @since ????
+instance (MapWriter t, MonadWriter w m, MonadTrans (t w'), Monad (t w' m), Monoid w') => MonadWriter w (LiftWriter t w' m) where
+  writer = lift . writer
+  tell = lift . tell
+  listen = mapLiftWriter $ mapWriterT $ fmap formatWriter . listen
+  pass = mapLiftWriter $ mapWriterT $ pass . fmap formatWriter
+
+-- | @since ????
+instance (MapRWS t, MonadWriter w m, MonadTrans (t r w' s), Monad (t r w' s m), Monoid w') => MonadWriter w (LiftWriterRWS t r w' s m) where
+  writer = lift . writer
+  tell = lift . tell
+  listen = mapLiftWriterRWS $ mapRWST $ fmap (\((a,b,c),d) -> ((a,d),b,c)) . listen
+  pass = mapLiftWriterRWS $ mapRWST $ pass . fmap (\((a,b),c,d) -> ((a,c,d),b))
+

Control/Monad/Writer/Lazy.hs

@@ -33,6 +33,11 @@ module Control.Monad.Writer.Lazy (
     runWriterT,
     execWriterT,
     mapWriterT,
+    -- * Lifting helper type
+    MonadWriter.LiftingWriter,
+    MonadWriter.LiftWriter(..),
+    MonadWriter.LiftWriterRWS(..),
+    -- * Lifting into the transformer
     module Control.Monad.Trans,
   ) where
 

Control/Monad/Writer/Strict.hs

@@ -32,6 +32,11 @@ module Control.Monad.Writer.Strict (
     WriterT(..),
     execWriterT,
     mapWriterT,
+    -- * Lifting helper type
+    MonadWriter.LiftingWriter,
+    MonadWriter.LiftWriter(..),
+    MonadWriter.LiftWriterRWS(..),
+    -- * Lifting into the transformer
     module Control.Monad.Trans,
   ) where