@@ -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
11+ (
12+ -- * The Writer monad
13+ Writer
14+ , writer
15+ , runWriter
16+ , execWriter
17+ -- * The WriterT monad transformer
18+ , WriterT
19+ , writerT
20+ , runWriterT
21+ , execWriterT
22+ , mapWriterT
23+ -- * Writer operations
24+ , tell
25+ -- * Lifting other operations
26+ , liftCallCC
27+ , liftCatch
28+ ) where
29+
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
42+
43+import qualified Control.Monad.Signatures as Sig
44+import qualified Control.Monad.Trans.Writer.Lazy as Trans
45+
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
51+
52+-- | The parametrizable writer monad.
53+--
54+-- Computations can accumulate a monoid value.
55+--
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
59+
60+-- | The writer monad transformer.
61+--
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)
65+ deriving ( Generic
66+ , Functor, Applicative, Alternative, Monad, MonadPlus
67+ , MonadFix, MonadTrans, MonadIO )
68+
69+instance NT.Newtype (WriterT tag w m a)
70+
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
74+
75+instance Tagged (WriterT tag w m) tag where
76+ type Untagged (WriterT tag w m) = Trans.WriterT w m
77+
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
81+
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
86+
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
91+
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
96+
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
101+
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
106+
107+-- | Transform the computation inside a 'WriterT'.
108+--
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)
112+
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)
116+
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)
120+
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)
124+
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)
128+
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)
132+
133+instance (Monoid w, Class.MonadCont m) => Class.MonadCont (WriterT tag w m) where
134+ callCC = liftCallCC Proxy Class.callCC
135+
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
140+
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
145+
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
151+
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