
  0 | module Control.Monad.Writer.Tuple
  1 | 
  2 | import Control.Monad.Writer.CPS
  3 | import public Control.Monad.Writer.Interface
  4 | import Control.Monad.RWS.CPS
  5 | 
  6 | %default total
  7 | 
  8 | --- WriterT ---
  9 | 
 10 | export
 11 | Monad m => Monoid l => Monoid r => MonadWriter l (WriterT (l, r) m) where
 12 |   writer (x, l) = writer (x, l, neutral)
 13 |   tell x        = tell (x, neutral)
 14 |   pass wr       = MkWriterT $ \(ll, rr) => runWriterT wr <&> \((a, f), l, r) => (a, ll <+> f l, rr <+> r)
 15 |   listen wr     = MkWriterT $ \(ll, rr) => runWriterT wr <&> \(x, l, r) => ((x, l), ll <+> l, rr <+> r)
 16 | 
 17 | wrapFst : Functor m => WriterT r m a -> WriterT (l, r) m a
 18 | wrapFst $ MkWriterT fw = MkWriterT $ \(x, y) => map (x,) <$> fw y
 19 | 
 20 | unwrapFst : Functor m => Monoid l => WriterT (l, r) m a -> WriterT r m (a, l)
 21 | unwrapFst $ MkWriterT fw = MkWriterT $ \y => fw (neutral, y) <&> \(a, l, r) => ((a, l), r)
 22 | 
 23 | export
 24 | MonadWriter s (WriterT r m) => Monoid l => Monoid r => Monad m => MonadWriter s (WriterT (l, r) m) where
 25 |   writer (x, l) = wrapFst $ writer (x, l)
 26 |   tell          = wrapFst . tell
 27 |   pass wr       = MkWriterT $ \(x, y) => runWriterT (pass $ unwrapFst wr <&> \((a, f), l) => ((a, l), f)) <&> \((a, l), r) => (a, x <+> l, y <+> r)
 28 |   listen wr     = MkWriterT $ \(x, y) => runWriterT (listen $ unwrapFst wr) <&> \(((a, l), s), r) => ((a, s), x <+> l, y <+> r)
 29 | 
 30 | --- RWST ---
 31 | 
 32 | export
 33 | Monad m => Monoid wl => Monoid wr => MonadWriter wl (RWST r (wl, wr) s m) where
 34 |   writer (x, l) = writer (x, l, neutral)
 35 |   tell x        = tell (x, neutral)
 36 |   pass wr       = MkRWST $ \r, s, (ll, rr) => runRWST r s wr <&> \((a, f), s', x, y) => (a, s', ll <+> f x, rr <+> y)
 37 |   listen wr     = MkRWST $ \r, s, (ll, rr) => runRWST r s wr <&> \(a, s', x, y) => ((a, x), s', ll <+> x, rr <+> y)
 38 | 
 39 | wrapFst' : Functor m => RWST r wr s m a -> RWST r (wl, wr) s m a
 40 | wrapFst' $ MkRWST fw = MkRWST $ \r, s, (x, y) => map @{Compose} (x,) <$> fw r s y
 41 | 
 42 | unwrapFst' : Functor m => Monoid wl => RWST r (wl, wr) s m a -> RWST r wr s m (a, wl)
 43 | unwrapFst' $ MkRWST fw = MkRWST $ \r, s, y => fw r s (neutral, y) <&> \(a, s, wl, wr) => ((a, wl), s, wr)
 44 | 
 45 | export
 46 | MonadWriter v (RWST r wr s m) => Monoid wl => Monoid wr => Monad m => MonadWriter v (RWST r (wl, wr) s m) where
 47 |   writer (x, l) = wrapFst' $ writer (x, l)
 48 |   tell          = wrapFst' . tell
 49 |   pass  wr      = MkRWST $ \r, s, (x, y) => runRWST r s (pass $ unwrapFst' wr <&> \((a, f), l) => ((a, l), f)) <&>
 50 |                     \((a, wl), s, wr) => (a, s, x <+> wl, y <+> wr)
 51 |   listen wr     = MkRWST $ \r, s, (x, y) => runRWST r s (listen $ unwrapFst' wr) <&> \(((a, wl), v), s, wr) => ((a, v), s, x <+> wl, y <+> wr)
 52 |