1{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
2{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
3{-# LANGUAGE
4    ExplicitForAll
5  , GADTs
6  , RebindableSyntax #-}
7module T5908
8       ( Writer
9       , runWriter
10       , execWriter
11       , WriterT
12       , runWriterT
13       , execWriterT
14       , tell
15       ) where
16
17import Control.Category (Category (id), (>>>))
18
19import Prelude hiding (Monad (..), id)
20import qualified Prelude
21
22newtype Identity a = Identity { runIdentity :: a }
23
24class Monad m where
25  (>>=) :: forall e ex x a b . m e ex a -> (a -> m ex x b) -> m e x b
26  (>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b
27  return :: a -> m ex ex a
28  fail :: String -> m e x a
29
30  {-# INLINE (>>) #-}
31  m >> k = m >>= \ _ -> k
32  fail = error
33
34type Writer w = WriterT w Identity
35
36runWriter :: Writer w e x a -> (a, w e x)
37runWriter = runIdentity . runWriterT
38
39execWriter :: Writer w e x a -> w e x
40execWriter m = snd (runWriter m)
41
42newtype WriterT w m e x a = WriterT { runWriterT :: m (a, w e x) }
43
44execWriterT :: Prelude.Monad m => WriterT w m e x a -> m (w e x)
45execWriterT m = do
46  ~(_, w) <- runWriterT m
47  return w
48  where
49    (>>=) = (Prelude.>>=)
50    return = Prelude.return
51
52instance (Category w, Prelude.Monad m) => Monad (WriterT w m) where
53  return a = WriterT $ return (a, id)
54    where
55      return = Prelude.return
56  m >>= k = WriterT $ do
57    ~(a, w) <- runWriterT m
58    ~(b, w') <- runWriterT (k a)
59    return (b, w >>> w')
60    where
61      (>>=) = (Prelude.>>=)
62      return = Prelude.return
63  fail msg = WriterT $ fail msg
64    where
65      fail = Prelude.fail
66
67tell :: (Category w, Prelude.Monad m) => w e x -> WriterT w m e x ()
68tell w = WriterT $ return ((), w)
69  where
70    return = Prelude.return
71
72
73