← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to libraries/mtl/Control/Monad/Writer/Lazy.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libraries/mtl/Control/Monad/Writer/Lazy.hs
 
1
{-# LANGUAGE UndecidableInstances #-}
 
2
-- Search for UndecidableInstances to see why this is needed
 
3
 
 
4
-----------------------------------------------------------------------------
 
5
-- |
 
6
-- Module      :  Control.Monad.Writer.Lazy
 
7
-- Copyright   :  (c) Andy Gill 2001,
 
8
--                (c) Oregon Graduate Institute of Science and Technology, 2001
 
9
-- License     :  BSD-style (see the file libraries/base/LICENSE)
 
10
--
 
11
-- Maintainer  :  libraries@haskell.org
 
12
-- Stability   :  experimental
 
13
-- Portability :  non-portable (multi-param classes, functional dependencies)
 
14
--
 
15
-- Lazy writer monads.
 
16
--
 
17
--      Inspired by the paper
 
18
--      /Functional Programming with Overloading and
 
19
--          Higher-Order Polymorphism/,
 
20
--        Mark P Jones (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>)
 
21
--          Advanced School of Functional Programming, 1995.
 
22
-----------------------------------------------------------------------------
 
23
 
 
24
module Control.Monad.Writer.Lazy (
 
25
    module Control.Monad.Writer.Class,
 
26
    Writer(..),
 
27
    execWriter,
 
28
    mapWriter,
 
29
    WriterT(..),
 
30
    execWriterT,
 
31
    mapWriterT,
 
32
    module Control.Monad,
 
33
    module Control.Monad.Fix,
 
34
    module Control.Monad.Trans,
 
35
    module Data.Monoid,
 
36
  ) where
 
37
 
 
38
import Control.Monad
 
39
import Control.Monad.Cont.Class
 
40
import Control.Monad.Error.Class
 
41
import Control.Monad.Fix
 
42
import Control.Monad.Reader.Class
 
43
import Control.Monad.State.Class
 
44
import Control.Monad.Trans
 
45
import Control.Monad.Writer.Class
 
46
import Data.Monoid
 
47
 
 
48
-- ---------------------------------------------------------------------------
 
49
-- Our parameterizable writer monad
 
50
 
 
51
newtype Writer w a = Writer { runWriter :: (a, w) }
 
52
 
 
53
execWriter :: Writer w a -> w
 
54
execWriter m = snd (runWriter m)
 
55
 
 
56
mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
 
57
mapWriter f m = Writer $ f (runWriter m)
 
58
 
 
59
instance Functor (Writer w) where
 
60
    fmap f m = Writer $ let (a, w) = runWriter m in (f a, w)
 
61
 
 
62
instance (Monoid w) => Monad (Writer w) where
 
63
    return a = Writer (a, mempty)
 
64
    m >>= k  = Writer $ let
 
65
        (a, w)  = runWriter m
 
66
        (b, w') = runWriter (k a)
 
67
        in (b, w `mappend` w')
 
68
 
 
69
instance (Monoid w) => MonadFix (Writer w) where
 
70
    mfix m = Writer $ let (a, w) = runWriter (m a) in (a, w)
 
71
 
 
72
instance (Monoid w) => MonadWriter w (Writer w) where
 
73
    tell   w = Writer ((), w)
 
74
    listen m = Writer $ let (a, w) = runWriter m in ((a, w), w)
 
75
    pass   m = Writer $ let ((a, f), w) = runWriter m in (a, f w)
 
76
 
 
77
-- ---------------------------------------------------------------------------
 
78
-- Our parameterizable writer monad, with an inner monad
 
79
 
 
80
newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
 
81
 
 
82
execWriterT :: Monad m => WriterT w m a -> m w
 
83
execWriterT m = do
 
84
    ~(_, w) <- runWriterT m
 
85
    return w
 
86
 
 
87
mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
 
88
mapWriterT f m = WriterT $ f (runWriterT m)
 
89
 
 
90
instance (Monad m) => Functor (WriterT w m) where
 
91
    fmap f m = WriterT $ do
 
92
        ~(a, w) <- runWriterT m
 
93
        return (f a, w)
 
94
 
 
95
instance (Monoid w, Monad m) => Monad (WriterT w m) where
 
96
    return a = WriterT $ return (a, mempty)
 
97
    m >>= k  = WriterT $ do
 
98
        ~(a, w)  <- runWriterT m
 
99
        ~(b, w') <- runWriterT (k a)
 
100
        return (b, w `mappend` w')
 
101
    fail msg = WriterT $ fail msg
 
102
 
 
103
instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where
 
104
    mzero       = WriterT mzero
 
105
    m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n
 
106
 
 
107
instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where
 
108
    mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a)
 
109
 
 
110
instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
 
111
    tell   w = WriterT $ return ((), w)
 
112
    listen m = WriterT $ do
 
113
        ~(a, w) <- runWriterT m
 
114
        return ((a, w), w)
 
115
    pass   m = WriterT $ do
 
116
        ~((a, f), w) <- runWriterT m
 
117
        return (a, f w)
 
118
 
 
119
-- ---------------------------------------------------------------------------
 
120
-- Instances for other mtl transformers
 
121
 
 
122
instance (Monoid w) => MonadTrans (WriterT w) where
 
123
    lift m = WriterT $ do
 
124
        a <- m
 
125
        return (a, mempty)
 
126
 
 
127
instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where
 
128
    liftIO = lift . liftIO
 
129
 
 
130
instance (Monoid w, MonadCont m) => MonadCont (WriterT w m) where
 
131
    callCC f = WriterT $
 
132
        callCC $ \c ->
 
133
        runWriterT (f (\a -> WriterT $ c (a, mempty)))
 
134
 
 
135
instance (Monoid w, MonadError e m) => MonadError e (WriterT w m) where
 
136
    throwError       = lift . throwError
 
137
    m `catchError` h = WriterT $ runWriterT m
 
138
        `catchError` \e -> runWriterT (h e)
 
139
 
 
140
-- This instance needs UndecidableInstances, because
 
141
-- it does not satisfy the coverage condition
 
142
instance (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where
 
143
    ask       = lift ask
 
144
    local f m = WriterT $ local f (runWriterT m)
 
145
 
 
146
-- Needs UndecidableInstances
 
147
instance (Monoid w, MonadState s m) => MonadState s (WriterT w m) where
 
148
    get = lift get
 
149
    put = lift . put
 
150