@@ -0,0 +1,154 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE UndecidableInstances #-}
7+{-# LANGUAGE DataKinds #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10+module Control.Monad.Trans.Ether.Writer
12+ -- * The Writer monad
17+ -- * The WriterT monad transformer
23+ -- * Writer operations
25+ -- * Lifting other operations
30+import Data.Proxy (Proxy(Proxy))
31+import Data.Functor.Identity (Identity(..))
32+import Data.Coerce (coerce)
33+import Control.Applicative (Alternative)
34+import Control.Monad (MonadPlus)
35+import Control.Monad.Fix (MonadFix)
36+import Control.Monad.Trans.Class (MonadTrans, lift)
37+import Control.Monad.IO.Class (MonadIO)
38+import Control.Ether.Tags (Taggable(..), Tagged(..))
39+import qualified Control.Ether.Util as Util
40+import GHC.Generics (Generic)
41+import qualified Control.Newtype as NT
43+import qualified Control.Monad.Signatures as Sig
44+import qualified Control.Monad.Trans.Writer.Lazy as Trans
46+import qualified Control.Monad.Cont.Class as Class
47+import qualified Control.Monad.Reader.Class as Class
48+import qualified Control.Monad.State.Class as Class
49+import qualified Control.Monad.Writer.Class as Class
50+import qualified Control.Monad.Error.Class as Class
52+-- | The parametrizable writer monad.
54+-- Computations can accumulate a monoid value.
56+-- The 'return' function produces the output 'mempty', while '>>=' combines
57+-- the outputs of the subcomputations using 'mappend'.
58+type Writer tag w = WriterT tag w Identity
60+-- | The writer monad transformer.
62+-- The 'return' function produces the output 'mempty', while '>>=' combines
63+-- the outputs of the subcomputations using 'mappend'.
64+newtype WriterT tag w m a = WriterT (Trans.WriterT w m a)
66+ , Functor, Applicative, Alternative, Monad, MonadPlus
67+ , MonadFix, MonadTrans, MonadIO )
69+instance NT.Newtype (WriterT tag w m a)
71+instance Taggable (WriterT tag w m) where
72+ type Tag (WriterT tag w m) = 'Just tag
73+ type Inner (WriterT tag w m) = 'Just m
75+instance Tagged (WriterT tag w m) tag where
76+ type Untagged (WriterT tag w m) = Trans.WriterT w m
78+-- | Constructor for computations in the writer monad transformer.
79+writerT :: proxy tag -> m (a, w) -> WriterT tag w m a
80+writerT t = tagged t . Trans.WriterT
82+-- | Constructor for computations in the writer monad
83+-- (the inverse of 'runWriter').
84+writer :: Monad m => proxy tag -> (a, w) -> WriterT tag w m a
85+writer t = tagged t . Trans.writer
87+-- | Runs a 'WriterT' and returns both the normal value
88+-- and the final accumulator.
89+runWriterT :: proxy tag -> WriterT tag w m a -> m (a, w)
90+runWriterT t = Trans.runWriterT . untagged t
92+-- | Runs a 'Writer' and returns both the normal value
93+-- and the final accumulator.
94+runWriter :: proxy tag -> Writer tag w a -> (a, w)
95+runWriter t = Trans.runWriter . untagged t
97+-- | Runs a 'WriterT' and returns the final accumulator,
98+-- discarding the normal value.
99+execWriterT :: Monad m => proxy tag -> WriterT tag w m a -> m w
100+execWriterT t = Trans.execWriterT . untagged t
102+-- | Runs a 'Writer' and returns the final accumulator,
103+-- discarding the normal value.
104+execWriter :: proxy tag -> Writer tag w a -> w
105+execWriter t = Trans.execWriter . untagged t
107+-- | Transform the computation inside a 'WriterT'.
109+-- * @'runWriterT' tag ('mapWriterT' tag f m) = f ('runWriterT' tag m)@
110+mapWriterT :: proxy tag -> (m (a, w) -> n (b, w')) -> WriterT tag w m a -> WriterT tag w' n b
111+mapWriterT t f m = tagged t $ Trans.mapWriterT f (coerce m)
113+-- | Appends a value to the accumulator within the monad.
114+tell :: Monad m => proxy tag -> w -> WriterT tag w m ()
115+tell t w = writer t ((), w)
117+-- | Lift a @catchE@ operation to the new monad.
118+liftCatch :: proxy tag -> Sig.Catch e m (a, w) -> Sig.Catch e (WriterT tag w m) a
119+liftCatch t f m h = tagged t $ Trans.liftCatch f (coerce m) (coerce h)
121+-- | Lift a @callCC@ operation to the new monad.
122+liftCallCC :: Monoid w => proxy tag -> Sig.CallCC m (a, w) (b, w) -> Sig.CallCC (WriterT tag w m) a b
123+liftCallCC t callCC f = tagged t $ Trans.liftCallCC callCC (coerce f)
125+-- | Lift a @listen@ operation to the new monad.
126+liftListen :: Monad m => proxy tag -> Sig.Listen w' m (a, w) -> Sig.Listen w' (WriterT tag w m) a
127+liftListen t listen m = tagged t $ Util.liftListen_WriterT listen (coerce m)
129+-- | Lift a @pass@ operation to the new monad.
130+liftPass :: Monad m => proxy tag -> Sig.Pass w' m (a, w) -> Sig.Pass w' (WriterT tag w m) a
131+liftPass t pass m = tagged t $ Util.liftPass_WriterT pass (coerce m)
133+instance (Monoid w, Class.MonadCont m) => Class.MonadCont (WriterT tag w m) where
134+ callCC = liftCallCC Proxy Class.callCC
136+instance (Monoid w, Class.MonadReader r m) => Class.MonadReader r (WriterT tag w m) where
137+ ask = lift Class.ask
138+ local = mapWriterT Proxy . Class.local
139+ reader = lift . Class.reader
141+instance (Monoid w, Class.MonadState s m) => Class.MonadState s (WriterT tag w m) where
142+ get = lift Class.get
143+ put = lift . Class.put
144+ state = lift . Class.state
146+instance (Monoid w, Class.MonadWriter w' m) => Class.MonadWriter w' (WriterT tag w m) where
147+ writer = lift . Class.writer
148+ tell = lift . Class.tell
149+ listen = liftListen Proxy Class.listen
150+ pass = liftPass Proxy Class.pass
152+instance (Monoid w, Class.MonadError e m) => Class.MonadError e (WriterT tag w m) where
153+ throwError = lift . Class.throwError
154+ catchError = liftCatch Proxy Class.catchError