Skip to content

Commit f92ef90

Browse files
BebeSparkelSparkelBebeSparkelSparkel
committed
added LiftingReader LiftingWriter LiftingState
1 parent cad092e commit f92ef90

File tree

6 files changed

+155
-12
lines changed

6 files changed

+155
-12
lines changed

‎Control/Monad/Reader/Class.hs‎

Lines changed: 22 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,15 @@
1+
{-# LANGUAGE Trustworthy #-}
12
{-# LANGUAGE FlexibleInstances #-}
23
{-# LANGUAGE FunctionalDependencies #-}
34
{-# LANGUAGE MultiParamTypeClasses #-}
45
-- Search for UndecidableInstances to see why this is needed
56
{-# LANGUAGE UndecidableInstances #-}
6-
{-# LANGUAGE StandaloneKindSignatures #-}
7-
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8-
{-# LANGUAGE Trustworthy #-}
97
-- Needed because the CPSed versions of Writer and State are secretly State
108
-- wrappers, which don't force such constraints, even though they should legally
119
-- be there.
10+
{-# LANGUAGE StandaloneKindSignatures #-}
11+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
12+
{-# LANGUAGE ViewPatterns #-}
1213
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
1314
{- |
1415
Module : Control.Monad.Reader.Class
@@ -207,16 +208,30 @@ instance
207208
local f (runSelectT m (local (const r) . c))
208209
reader = lift . reader
209210

211+
-- | A helper type to decrease boilerplate when defining new transformer
212+
-- instances of 'MonadReader'.
213+
--
214+
-- @since ????
210215
type LiftingReader :: ((Type -> Type) -> Type -> Type) -> (Type -> Type) -> Type -> Type
211216
newtype LiftingReader t m a = LiftingReader (t m a)
212217
deriving (Functor, Applicative, Monad, MonadTrans)
213218

214-
instance MonadReader r m => MonadReader r (LiftingReader (ReaderT r') m) where
219+
instance (MonadReader r m, Monoid w) => MonadReader r (LiftingReader (LazyRWS.RWST r' w s) m) where
215220
ask = lift ask
216-
local f (LiftingReader (ReaderT.ReaderT x)) = LiftingReader . ReaderT.ReaderT $ local f . x
221+
local f (LiftingReader (LazyRWS.RWST x)) = LiftingReader . LazyRWS.RWST $ \r s -> local f $ x r s
217222
reader = lift . reader
218223

219-
instance (MonadReader r m, Monoid w) => MonadReader r (LiftingReader (LazyRWS.RWST r' w s) m) where
224+
instance (MonadReader r m, Monoid w) => MonadReader r (LiftingReader (StrictRWS.RWST r' w s) m) where
220225
ask = lift ask
221-
local f (LiftingReader (LazyRWS.RWST x)) = LiftingReader . LazyRWS.RWST $ \r s -> local f $ x r s
226+
local f (LiftingReader (StrictRWS.RWST x)) = LiftingReader . StrictRWS.RWST $ \r s -> local f $ x r s
227+
reader = lift . reader
228+
229+
instance (MonadReader r m, Monoid w) => MonadReader r (LiftingReader (CPSRWS.RWST r' w s) m) where
230+
ask = lift ask
231+
local f (LiftingReader (CPSRWS.runRWST -> x)) = LiftingReader . CPSRWS.rwsT $ \r s -> local f $ x r s
232+
reader = lift . reader
233+
234+
instance MonadReader r m => MonadReader r (LiftingReader (ReaderT r') m) where
235+
ask = lift ask
236+
local f (LiftingReader (ReaderT.ReaderT x)) = LiftingReader . ReaderT.ReaderT $ local f . x
222237
reader = lift . reader

‎Control/Monad/State/Class.hs‎

Lines changed: 41 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,6 @@
1-
{-# LANGUAGE Safe #-}
1+
{-# LANGUAGE Trustworthy #-}
2+
{-# LANGUAGE StandaloneKindSignatures #-}
3+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
24
{-# LANGUAGE FunctionalDependencies #-}
35
{-# LANGUAGE FlexibleInstances #-}
46
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -33,7 +35,8 @@ module Control.Monad.State.Class (
3335
MonadState(..),
3436
modify,
3537
modify',
36-
gets
38+
gets,
39+
LiftingState
3740
) where
3841

3942
import Control.Monad.Trans.Cont (ContT)
@@ -51,7 +54,8 @@ import Control.Monad.Trans.Accum (AccumT)
5154
import Control.Monad.Trans.Select (SelectT)
5255
import qualified Control.Monad.Trans.RWS.CPS as CPSRWS
5356
import qualified Control.Monad.Trans.Writer.CPS as CPS
54-
import Control.Monad.Trans.Class (lift)
57+
import Control.Monad.Trans.Class (MonadTrans(lift))
58+
import Data.Kind (Type)
5559

5660
-- ---------------------------------------------------------------------------
5761

@@ -192,3 +196,37 @@ instance MonadState s m => MonadState s (SelectT r m) where
192196
get = lift get
193197
put = lift . put
194198
state = lift . state
199+
200+
-- | A helper type to decrease boilerplate when defining new transformer
201+
-- instances of 'MonadState'.
202+
--
203+
-- @since ????
204+
type LiftingState :: ((Type -> Type) -> Type -> Type) -> (Type -> Type) -> Type -> Type
205+
newtype LiftingState t m a = LiftingState (t m a)
206+
deriving (Functor, Applicative, Monad, MonadTrans)
207+
208+
instance (MonadState s m, Monoid w) => MonadState s (LiftingState (LazyRWS.RWST r w s') m) where
209+
get = lift get
210+
put = lift . put
211+
state = lift . state
212+
213+
instance (MonadState s m, Monoid w) => MonadState s (LiftingState (StrictRWS.RWST r w s') m) where
214+
get = lift get
215+
put = lift . put
216+
state = lift . state
217+
218+
instance (MonadState s m, Monoid w) => MonadState s (LiftingState (CPSRWS.RWST r w s') m) where
219+
get = lift get
220+
put = lift . put
221+
state = lift . state
222+
223+
instance MonadState s m => MonadState s (LiftingState (Lazy.StateT s') m) where
224+
get = lift get
225+
put = lift . put
226+
state = lift . state
227+
228+
instance MonadState s m => MonadState s (LiftingState (Strict.StateT s') m) where
229+
get = lift get
230+
put = lift . put
231+
state = lift . state
232+

‎Control/Monad/Writer/CPS.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,8 @@ module Control.Monad.Writer.CPS (
2626
MonadWriter.MonadWriter(..),
2727
MonadWriter.listens,
2828
MonadWriter.censor,
29+
-- * Lifting helper type
30+
MonadWriter.LiftingWriter,
2931
-- * The Writer monad
3032
Writer,
3133
runWriter,

‎Control/Monad/Writer/Class.hs‎

Lines changed: 86 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,13 @@
1-
{-# LANGUAGE Safe #-}
1+
{-# LANGUAGE Trustworthy #-}
22
{-# LANGUAGE FlexibleInstances #-}
33
{-# LANGUAGE FunctionalDependencies #-}
44
{-# LANGUAGE MultiParamTypeClasses #-}
55
{-# LANGUAGE UndecidableInstances #-}
6+
{-# LANGUAGE StandaloneKindSignatures #-}
7+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8+
{-# LANGUAGE TupleSections #-}
9+
{-# LANGUAGE ViewPatterns #-}
10+
{-# OPTIONS_GHC -Wno-name-shadowing #-}
611
-- Search for UndecidableInstances to see why this is needed
712

813
-----------------------------------------------------------------------------
@@ -28,6 +33,7 @@ module Control.Monad.Writer.Class (
2833
MonadWriter(..),
2934
listens,
3035
censor,
36+
LiftingWriter(..),
3137
) where
3238

3339
import Control.Monad.Trans.Except (ExceptT)
@@ -47,7 +53,8 @@ import Control.Monad.Trans.Accum (AccumT)
4753
import qualified Control.Monad.Trans.Accum as Accum
4854
import qualified Control.Monad.Trans.RWS.CPS as CPSRWS
4955
import qualified Control.Monad.Trans.Writer.CPS as CPS
50-
import Control.Monad.Trans.Class (lift)
56+
import Control.Monad.Trans.Class (MonadTrans(lift))
57+
import Data.Kind (Type)
5158

5259
-- ---------------------------------------------------------------------------
5360
-- MonadWriter class
@@ -205,3 +212,80 @@ instance
205212
tell = lift . tell
206213
listen = Accum.liftListen listen
207214
pass = Accum.liftPass pass
215+
216+
217+
-- | A helper type to decrease boilerplate when defining new transformer
218+
-- instances of 'MonadWriter'.
219+
--
220+
-- @since ????
221+
type LiftingWriter :: ((Type -> Type) -> Type -> Type) -> (Type -> Type) -> Type -> Type
222+
newtype LiftingWriter t m a = LiftingWriter {runLiftingWriter :: t m a}
223+
deriving (Functor, Applicative, Monad, MonadTrans)
224+
225+
226+
instance (Monoid w', MonadWriter w m) => MonadWriter w (LiftingWriter (LazyRWS.RWST r w' s) m) where
227+
writer = lift . writer
228+
tell = lift . tell
229+
listen (LiftingWriter (LazyRWS.RWST x)) = LiftingWriter $ LazyRWS.RWST $ \r s -> do
230+
((a, s, w'), w) <- listen $ x r s
231+
pure ((a, w), s, w')
232+
pass (LiftingWriter (LazyRWS.RWST x)) = LiftingWriter $ LazyRWS.RWST $ \r s -> do
233+
(y, s, w') <- x r s
234+
a <- pass $ pure y
235+
pure (a, s, w')
236+
237+
instance (Monoid w', MonadWriter w m) => MonadWriter w (LiftingWriter (StrictRWS.RWST r w' s) m) where
238+
writer = lift . writer
239+
tell = lift . tell
240+
listen (LiftingWriter (StrictRWS.RWST x)) = LiftingWriter $ StrictRWS.RWST $ \r s -> do
241+
((a, s, w'), w) <- listen $ x r s
242+
pure ((a, w), s, w')
243+
pass (LiftingWriter (StrictRWS.RWST x)) = LiftingWriter $ StrictRWS.RWST $ \r s -> do
244+
(y, s, w') <- x r s
245+
a <- pass $ pure y
246+
pure (a, s, w')
247+
248+
instance (Monoid w', MonadWriter w m) => MonadWriter w (LiftingWriter (CPSRWS.RWST r w' s) m) where
249+
writer = lift . writer
250+
tell = lift . tell
251+
listen (LiftingWriter (CPSRWS.runRWST -> x)) = LiftingWriter $ CPSRWS.rwsT $ \r s -> do
252+
((a, s, w'), w) <- listen $ x r s
253+
pure ((a, w), s, w')
254+
pass (LiftingWriter (CPSRWS.runRWST -> x)) = LiftingWriter $ CPSRWS.rwsT $ \r s -> do
255+
(y, s, w') <- x r s
256+
a <- pass $ pure y
257+
pure (a, s, w')
258+
259+
instance (Monoid w', MonadWriter w m) => MonadWriter w (LiftingWriter (Lazy.WriterT w') m) where
260+
writer = lift . writer
261+
tell = lift . tell
262+
listen (LiftingWriter (Lazy.WriterT x)) = LiftingWriter $ Lazy.WriterT $ do
263+
((a, w'), w) <- listen x
264+
pure ((a, w), w')
265+
pass (LiftingWriter (Lazy.WriterT x)) = LiftingWriter $ Lazy.WriterT $ do
266+
(y, w') <- x
267+
a <- pass $ pure y
268+
pure (a, w')
269+
270+
instance (Monoid w', MonadWriter w m) => MonadWriter w (LiftingWriter (Strict.WriterT w') m) where
271+
writer = lift . writer
272+
tell = lift . tell
273+
listen (LiftingWriter (Strict.WriterT x)) = LiftingWriter $ Strict.WriterT $ do
274+
((a, w'), w) <- listen x
275+
pure ((a, w), w')
276+
pass (LiftingWriter (Strict.WriterT x)) = LiftingWriter $ Strict.WriterT $ do
277+
(y, w') <- x
278+
a <- pass $ pure y
279+
pure (a, w')
280+
281+
instance (Monoid w', MonadWriter w m) => MonadWriter w (LiftingWriter (CPS.WriterT w') m) where
282+
writer = lift . writer
283+
tell = lift . tell
284+
listen (LiftingWriter (CPS.runWriterT -> x)) = LiftingWriter $ CPS.writerT $ do
285+
((a, w'), w) <- listen x
286+
pure ((a, w), w')
287+
pass (LiftingWriter (CPS.runWriterT -> x)) = LiftingWriter $ CPS.writerT $ do
288+
(y, w') <- x
289+
a <- pass $ pure y
290+
pure (a, w')
291+

‎Control/Monad/Writer/Lazy.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,8 @@ module Control.Monad.Writer.Lazy (
2323
MonadWriter.MonadWriter(..),
2424
MonadWriter.listens,
2525
MonadWriter.censor,
26+
-- * Lifting helper type
27+
MonadWriter.LiftingWriter,
2628
-- * The Writer monad
2729
Writer,
2830
runWriter,

‎Control/Monad/Writer/Strict.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,8 @@ module Control.Monad.Writer.Strict (
2323
MonadWriter.MonadWriter(..),
2424
MonadWriter.listens,
2525
MonadWriter.censor,
26+
-- * Lifting helper type
27+
MonadWriter.LiftingWriter,
2628
-- * The Writer monad
2729
Writer,
2830
runWriter,

0 commit comments

Comments
 (0)