Ticket #5908: DoesntWork.hs

File DoesntWork.hs, 1.7 KB (added by scooty-puff, 3 years ago)

Rejected Writer.hs

Line 
1{-# LANGUAGE
2    ExplicitForAll
3  , GADTs
4  , RebindableSyntax #-}
5{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
6module Writer
7       ( Writer
8       , runWriter
9       , execWriter
10       , WriterT
11       , runWriterT
12       , execWriterT
13       , tell
14       ) where
15
16import Control.Category (Category (id), (>>>))
17import Control.Monad.Identity (Identity, runIdentity)
18
19import Data.Semigroupoid
20
21import Prelude hiding (Monad (..), id)
22import qualified Prelude
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