Ticket #5908: Works.hs

File Works.hs, 1.2 KB (added by scooty-puff, 2 years ago)

Working Writer.hs

Line 
1{-# LANGUAGE
2    ExplicitForAll
3  , GADTs #-}
4{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
5module Writer
6       ( Writer
7       , runWriter
8       , execWriter
9       , WriterT
10       , runWriterT
11       , execWriterT
12       , tell
13       ) where
14
15import Control.Category (Category (id), (>>>))
16import Control.Monad.Identity (Identity, runIdentity)
17
18import Data.Semigroupoid
19
20import qualified MyMonad
21
22import Prelude hiding (id)
23
24type Writer w = WriterT w Identity
25
26runWriter :: Writer w e x a -> (a, w e x)
27runWriter = runIdentity . runWriterT
28
29execWriter :: Writer w e x a -> w e x
30execWriter m = snd (runWriter m)
31
32newtype WriterT w m e x a = WriterT { runWriterT :: m (a, w e x) }
33
34execWriterT :: Monad m => WriterT w m e x a -> m (w e x)
35execWriterT m = do
36  ~(_, w) <- runWriterT m
37  return w
38
39instance (Category w, Monad m) => MyMonad.Monad (WriterT w m) where
40  return a = WriterT $ return (a, id)
41  m >>= k = WriterT $ do
42    ~(a, w) <- runWriterT m
43    ~(b, w') <- runWriterT (k a)
44    return (b, w >>> w')
45  fail msg = WriterT $ fail msg
46
47tell :: (Category w, Monad m) => w e x -> WriterT w m e x ()
48tell w = WriterT $ return ((), w)