├── .gitignore ├── CONTRIBUTORS ├── LICENSE ├── Setup.hs ├── include ├── docmacros.h ├── newtypec.h └── overlap.h ├── layers.cabal └── src ├── Control └── Monad │ ├── Lift.hs │ └── Lift │ ├── Base.hs │ ├── IO.hs │ ├── Internal.hs │ ├── Layer.hs │ └── Top.hs ├── Documentation └── Layers │ ├── Glossary.hs │ └── Overview.hs └── Monad ├── Abort.hs ├── Catch.hs ├── Cont.hs ├── Error.hs ├── Fork.hs ├── Mask.hs ├── RWS.hs ├── Reader.hs ├── Recover.hs ├── ST.hs ├── State.hs ├── Throw.hs ├── Try.hs └── Writer.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist* 2 | -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | Shane O'Brien -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Shane O'Brien 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Shane O'Brien nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /include/docmacros.h: -------------------------------------------------------------------------------- 1 | #define B(n) 2 | #define BW(x) 3 | #define BWT(x, y) 4 | #define H(p) @@ 5 | #define HW(p) 6 | #define HWT(p, x) 7 | #define M(p, m) https://hackage.haskell.org/package/p/docs/m.html 8 | #define T(p, m, ty) @@ 9 | #define V(p, m, va) @@ 10 | #define TT(p, m, ty, x) @@ 11 | #define VT(p, m, va, x) @@ 12 | #define UG(x, y) 13 | #define G(section, text) 14 | -------------------------------------------------------------------------------- /include/newtypec.h: -------------------------------------------------------------------------------- 1 | #define newtypeC(constraint, context)\ 2 | class context => constraint; instance context => constraint 3 | #if __GLASGOW_HASKELL__ >= 702 4 | #define newtypeCE(c, d, e) class (d, e) => c; instance (d, e) => c 5 | #define CE(constraint, equalities) (constraint) 6 | #else 7 | #define newtypeCE(c, d, e) class (d) => c; instance (d, e) => c 8 | #define CE(constraint, equalities) (constraint, equalities) 9 | #endif 10 | -------------------------------------------------------------------------------- /include/overlap.h: -------------------------------------------------------------------------------- 1 | #ifdef OverlapPragma 2 | #define __OVERLAPPABLE__ {-# OVERLAPPABLE #-} 3 | #define __OVERLAPPING__ {-# OVERLAPPING #-} 4 | #define __OVERLAPS__ {-# OVERLAPS #-} 5 | #define __INCOHERENT__ {-# INCOHERENT #-} 6 | #else 7 | #define __OVERLAPPABLE__ 8 | #define __OVERLAPPING__ 9 | #define __OVERLAPS__ 10 | #define __INCOHERENT__ 11 | #endif 12 | -------------------------------------------------------------------------------- /layers.cabal: -------------------------------------------------------------------------------- 1 | name: layers 2 | version: 1.0.0 3 | synopsis: Modular type class machinery for monad transformer stacks. 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Shane O'Brien 7 | maintainer: shane@duairc.com 8 | stability: Experimental 9 | category: Control 10 | cabal-version: >= 1.6 11 | homepage: https://github.com/duairc/layers 12 | bug-reports: https://github.com/duairc/layers/issues 13 | build-type: Simple 14 | description: 15 | The @@ package provides 16 | the type class machinery needed to make monads built out of 17 | of 18 | 19 | easy to use. The type class machinery provided and the design patterns 20 | suggested by @@ allow for 21 | much more modularity than is possible with the existing type class machinery 22 | and design patterns. With 23 | @@ 24 | it is possible to use arbitrary 25 | 26 | ( are 27 | what we call the sort of type classes that you see in the 28 | @@ 29 | and similar packages) with arbtirary 30 | 31 | (by 32 | here, we are specifically to 33 | , 34 | such as the ones defined in 35 | @@), without 36 | ever having to explicitly define how to lift specific 37 | through 38 | specific . 39 | It also provides a more complete 40 | set of 41 | than the @@, which fully solve 42 | the problems of exceptions and exception safety (among others), while 43 | maintaining full compatibility with all the 44 | from the 45 | @@. 46 | . 47 | @@ improves upon and/or 48 | replaces, in part or in whole, the following list of packages: 49 | @@, 50 | @@, 51 | @@, 52 | @@, 53 | @@, 54 | @@, 55 | @@, 56 | @@, 57 | @@, 58 | @@, 59 | @@ and 60 | probably more too. There have been many attempts to either improve upon or 61 | work around the deficiencies of the existing type class machinery for 62 | , 63 | but we believe 64 | @@ is the most complete of 65 | any of these so far. 66 | . 67 | A comprehensive overview of the motivation behind 68 | @@ and an explanation of 69 | the design decisions taken is given in "Documentation.Layers.Overview". It 70 | is /highly recommended/ that you read this if you are considering using this 71 | package. A detailed glossary of the jargon used throughout the documentation 72 | of this package is given in "Documentation.Layers.Glossary". The core type 73 | classes used by the package are exported from "Control.Monad.Lift" (some of 74 | these originate in 75 | @@ and 76 | @@). The rest of the 77 | modules in this package export 78 | , in the 79 | hierarchy, including replacements for all of the 80 | of the 81 | @@ package. 82 | 83 | extra-source-files: 84 | include/*.h 85 | LICENSE 86 | 87 | Library 88 | hs-source-dirs: 89 | src 90 | 91 | include-dirs: 92 | include 93 | 94 | exposed-modules: 95 | Documentation.Layers.Glossary 96 | Documentation.Layers.Overview 97 | Control.Monad.Lift 98 | Control.Monad.Lift.Base 99 | Control.Monad.Lift.IO 100 | Control.Monad.Lift.Layer 101 | Control.Monad.Lift.Top 102 | Monad.Abort 103 | Monad.Cont 104 | Monad.Catch 105 | Monad.Error 106 | Monad.Fork 107 | Monad.Mask 108 | Monad.Reader 109 | Monad.Recover 110 | Monad.RWS 111 | Monad.State 112 | Monad.ST 113 | Monad.Throw 114 | Monad.Try 115 | Monad.Writer 116 | 117 | other-modules: 118 | Control.Monad.Lift.Internal 119 | 120 | build-depends: 121 | base >= 4 && < 5, 122 | mmorph >= 1.0 && < 1.2, 123 | transformers >= 0.2 && < 0.6 124 | 125 | ghc-options: 126 | -Wall 127 | 128 | if impl(ghc < 7) 129 | cpp-options: -DINLINABLE=INLINE 130 | 131 | if impl(ghc >= 7.2) 132 | cpp-options: -DLANGUAGE_DefaultSignatures 133 | 134 | if impl(ghc >= 7.2) 135 | cpp-options: -DLANGUAGE_SafeHaskell 136 | 137 | if impl(ghc >= 7.8) 138 | cpp-options: -DClosedTypeFamilies 139 | 140 | if impl(ghc >= 7.10) 141 | cpp-options: -DOverlapPragma -DOverlappingInstances=NoImplicitParams 142 | 143 | if impl(ghc >= 7.8) 144 | cpp-options: -DMinimalPragma 145 | -------------------------------------------------------------------------------- /src/Control/Monad/Lift/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MonoLocalBinds #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | #ifdef LANGUAGE_SafeHaskell 13 | {-# LANGUAGE Trustworthy #-} 14 | #endif 15 | 16 | #include "newtypec.h" 17 | 18 | {-| 19 | 20 | 21 | 22 | -} 23 | 24 | module Control.Monad.Lift.Base 25 | ( MonadBase 26 | , liftB 27 | , MonadBaseControl 28 | , suspendB 29 | , resumeB 30 | , captureB 31 | , extractB 32 | , liftControlB 33 | , controlB 34 | , liftOpB 35 | , liftOpB_ 36 | , liftDiscardB 37 | , MonadBaseInvariant 38 | , hoistisoB 39 | , MonadBaseFunctor 40 | , hoistB 41 | ) 42 | where 43 | 44 | -- base ---------------------------------------------------------------------- 45 | import Control.Monad.ST (ST) 46 | import qualified Control.Monad.ST.Lazy as L (ST) 47 | #if MIN_VERSION_base(4, 7, 0) 48 | import Data.Proxy (Proxy) 49 | #endif 50 | #if MIN_VERSION_base(4, 3, 0) 51 | import GHC.Conc.Sync (STM) 52 | #else 53 | import GHC.Conc (STM) 54 | #endif 55 | 56 | 57 | -- layers -------------------------------------------------------------------- 58 | import Control.Monad.Lift 59 | ( MonadInner 60 | , liftI 61 | , MonadInnerControl 62 | , OuterEffects 63 | , OuterResult 64 | , OuterState 65 | , suspendI 66 | , resumeI 67 | , captureI 68 | , extractI 69 | , liftControlI 70 | , controlI 71 | , liftOpI 72 | , liftOpI_ 73 | , liftDiscardI 74 | , MonadInnerInvariant 75 | , hoistisoI 76 | , MonadInnerFunctor 77 | , hoistI 78 | ) 79 | import Control.Monad.Lift.Internal (coercePeelI) 80 | 81 | 82 | -- transformers -------------------------------------------------------------- 83 | import Data.Functor.Identity (Identity) 84 | 85 | 86 | ------------------------------------------------------------------------------ 87 | class MonadInner b m => MonadBase b m | m -> b 88 | 89 | 90 | ------------------------------------------------------------------------------ 91 | instance MonadBase Identity Identity 92 | 93 | 94 | ------------------------------------------------------------------------------ 95 | instance MonadBase Maybe Maybe 96 | 97 | 98 | ------------------------------------------------------------------------------ 99 | instance MonadBase (Either e) (Either e) 100 | 101 | 102 | ------------------------------------------------------------------------------ 103 | instance MonadBase [] [] 104 | 105 | 106 | ------------------------------------------------------------------------------ 107 | instance MonadBase ((->) r) ((->) r) 108 | 109 | 110 | ------------------------------------------------------------------------------ 111 | instance MonadBase IO IO 112 | 113 | 114 | ------------------------------------------------------------------------------ 115 | instance MonadBase (ST s) (ST s) 116 | 117 | 118 | ------------------------------------------------------------------------------ 119 | instance MonadBase (L.ST s) (L.ST s) 120 | 121 | 122 | ------------------------------------------------------------------------------ 123 | instance MonadBase STM STM 124 | 125 | 126 | #if MIN_VERSION_base(4, 7, 0) 127 | ------------------------------------------------------------------------------ 128 | instance MonadBase Proxy Proxy 129 | 130 | 131 | #endif 132 | ------------------------------------------------------------------------------ 133 | instance (MonadBase b m, MonadInner b (t m)) => MonadBase b (t m) 134 | 135 | 136 | ------------------------------------------------------------------------------ 137 | liftB :: MonadBase b m => b a -> m a 138 | liftB = liftI 139 | 140 | 141 | ------------------------------------------------------------------------------ 142 | newtypeC(MonadBaseControl b m, (MonadInnerControl b m, MonadBase b m)) 143 | 144 | 145 | ------------------------------------------------------------------------------ 146 | data Pm (m :: * -> *) = Pm 147 | 148 | 149 | ------------------------------------------------------------------------------ 150 | suspendB :: MonadBaseControl b m 151 | => m a 152 | -> OuterState b m 153 | -> b (OuterEffects b m a) 154 | suspendB = suspendI 155 | 156 | 157 | ------------------------------------------------------------------------------ 158 | resumeB :: forall b m a. MonadBaseControl b m 159 | => OuterEffects b m a 160 | -> m a 161 | resumeB = resumeI (Pm :: Pm b) 162 | 163 | 164 | ------------------------------------------------------------------------------ 165 | captureB :: forall b m. MonadBaseControl b m 166 | => m (OuterState b m) 167 | captureB = captureI (Pm :: Pm b) 168 | 169 | 170 | ------------------------------------------------------------------------------ 171 | extractB :: forall b m a c proxy. MonadBaseControl b m 172 | => proxy m 173 | -> OuterResult b m a 174 | -> Either (OuterResult b m c) a 175 | extractB = extractI (Pm :: Pm b) 176 | 177 | 178 | ------------------------------------------------------------------------------ 179 | liftControlB :: MonadBaseControl b m 180 | => ((forall c. m c -> b (OuterEffects b m c)) -> b a) 181 | -> m a 182 | liftControlB f = liftControlI (\peel -> f (coercePeelI peel)) 183 | 184 | 185 | ------------------------------------------------------------------------------ 186 | controlB :: MonadBaseControl b m 187 | => ((forall c. m c -> b (OuterEffects b m c)) -> b (OuterEffects b m a)) 188 | -> m a 189 | controlB f = controlI (\peel -> f (coercePeelI peel)) 190 | 191 | 192 | ------------------------------------------------------------------------------ 193 | liftOpB :: MonadBaseControl b m 194 | => ((a -> b (OuterEffects b m c)) -> b (OuterEffects b m d)) 195 | -> (a -> m c) 196 | -> m d 197 | liftOpB = liftOpI 198 | 199 | 200 | ------------------------------------------------------------------------------ 201 | liftOpB_ :: MonadBaseControl b m 202 | => (b (OuterEffects b m a) -> b (OuterEffects b m c)) 203 | -> m a 204 | -> m c 205 | liftOpB_ = liftOpI_ 206 | 207 | 208 | ------------------------------------------------------------------------------ 209 | liftDiscardB :: MonadBaseControl b m 210 | => (b () -> b a) 211 | -> m () 212 | -> m a 213 | liftDiscardB = liftDiscardI 214 | 215 | 216 | ------------------------------------------------------------------------------ 217 | newtypeC(MonadBaseInvariant j n b m, 218 | ( MonadInnerInvariant j n b m 219 | , MonadBase b m 220 | )) 221 | 222 | 223 | ------------------------------------------------------------------------------ 224 | hoistisoB :: MonadBaseInvariant j n b m 225 | => (forall c. b c -> j c) 226 | -> (forall c. j c -> b c) 227 | -> m a 228 | -> n a 229 | hoistisoB = hoistisoI 230 | 231 | 232 | ------------------------------------------------------------------------------ 233 | newtypeC(MonadBaseFunctor j n b m, (MonadInnerFunctor j n b m, MonadBase b m)) 234 | 235 | 236 | ------------------------------------------------------------------------------ 237 | hoistB :: MonadBaseFunctor j n b m => (forall c. b c -> j c) -> m a -> n a 238 | hoistB = hoistI 239 | -------------------------------------------------------------------------------- /src/Control/Monad/Lift/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MonoLocalBinds #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | #ifdef LANGUAGE_SafeHaskell 12 | {-# LANGUAGE Trustworthy #-} 13 | #endif 14 | 15 | #include "docmacros.h" 16 | #include "newtypec.h" 17 | 18 | {-| 19 | 20 | This module defines the 'MonadIO' family of interfaces, which consist of: 21 | 22 | * 'MonadIO' 23 | 24 | * 'MonadIOControl' 25 | 26 | * 'MonadIOInvariant' 27 | 28 | * 'MonadIOFunctor' 29 | 30 | All the constraints and operations in the 'MonadIO' family of interfaces are 31 | exactly identical to constraints and operations from the 'MonadInner' family, 32 | except that the type of the inner monad is fixed to 'IO'. In many cases the 33 | operations in the 'MonadInner' family are too polymorphic to be usable without 34 | type signatures everywhere, so if you know that the monad from which you want 35 | to lift is definitely 'IO', you will have a much easier time if you use these 36 | operations. 37 | 38 | (The point of 'MonadInner' is that it only needs to be written once, and then 39 | 'MonadIO', 'Control.Monad.Lift.Base.MonadBase' and all the rest come for free. 40 | With H(transformers) and H(transformers-base), instances of 41 | 'Control.Monad.IO.Class.MonadIO' and 42 | T(transformers-base,Control-Monad-Base,MonadBase) have to be manually written 43 | for every monad transformer.) 44 | 45 | -} 46 | 47 | module Control.Monad.Lift.IO 48 | ( MonadIO 49 | , liftIO 50 | , MonadIOControl 51 | , suspendIO 52 | , resumeIO 53 | , captureIO 54 | , extractIO 55 | , liftControlIO 56 | , controlIO 57 | , liftOpIO 58 | , liftOpIO_ 59 | , liftDiscardIO 60 | , MonadIOInvariant 61 | , hoistisoIO 62 | , MonadIOFunctor 63 | , hoistIO 64 | ) 65 | where 66 | 67 | -- layers -------------------------------------------------------------------- 68 | import Control.Monad.Lift 69 | ( MonadInner 70 | , liftI 71 | , MonadInnerControl 72 | , OuterEffects 73 | , OuterResult 74 | , OuterState 75 | , suspendI 76 | , resumeI 77 | , captureI 78 | , extractI 79 | , liftControlI 80 | , controlI 81 | , liftOpI 82 | , liftOpI_ 83 | , liftDiscardI 84 | , MonadInnerInvariant 85 | , hoistisoI 86 | , MonadInnerFunctor 87 | , hoistI 88 | ) 89 | import Control.Monad.Lift.Internal (coercePeelI) 90 | 91 | 92 | ------------------------------------------------------------------------------ 93 | -- | The constraint @'MonadIO' m@ holds when 'IO' is an inner monad of @m@ 94 | -- such that it is possible to lift computations in 'IO' into @m@ using 95 | -- 'liftIO'. 96 | -- 97 | -- It is neither possible nor necessary to manually write instances of 98 | -- 'MonadIO'. It's simply a constraint synonym for @'MonadInner' 'IO'@. Any 99 | -- monad built from stack of monad transformers with 'IO' at its 100 | -- (or indeed any \"base\" monad @m@ that 101 | -- satisfies the constraint @'MonadInner' 'IO' m@) is isomatically an instance 102 | -- of 'MonadIO'. 103 | newtypeC(MonadIO m, MonadInner IO m) 104 | 105 | 106 | ------------------------------------------------------------------------------ 107 | liftIO :: MonadIO m => IO a -> m a 108 | liftIO = liftI 109 | 110 | 111 | ------------------------------------------------------------------------------ 112 | -- | The constraint @'MonadIOControl' m@ holds when 'IO' is an inner monad of 113 | -- @m@ such that it is possible to lift computations in 'IO' into @m@ using 114 | -- 'liftIO'. 115 | -- 116 | -- It is neither possible nor necessary to manually write instances of 117 | -- 'MonadIO'. It's simply a constraint synonym for @'MonadInner' 'IO'@. Any 118 | -- monad built from stack of monad transformers with 'IO' at its 119 | -- (or indeed any \"base\" monad @m@ that 120 | -- satisfies the constraint @'MonadInner' 'IO' m@) is isomatically an instance 121 | -- of 'MonadIO'. 122 | newtypeC(MonadIOControl m, MonadInnerControl IO m) 123 | 124 | 125 | ------------------------------------------------------------------------------ 126 | data Pm (m :: * -> *) = Pm 127 | 128 | 129 | ------------------------------------------------------------------------------ 130 | suspendIO :: MonadIOControl m 131 | => m a 132 | -> OuterState IO m 133 | -> IO (OuterEffects IO m a) 134 | suspendIO = suspendI 135 | 136 | 137 | ------------------------------------------------------------------------------ 138 | resumeIO :: MonadIOControl m 139 | => OuterEffects IO m a 140 | -> m a 141 | resumeIO = resumeI (Pm :: Pm IO) 142 | 143 | 144 | ------------------------------------------------------------------------------ 145 | captureIO :: MonadIOControl m 146 | => m (OuterState IO m) 147 | captureIO = captureI (Pm :: Pm IO) 148 | 149 | 150 | ------------------------------------------------------------------------------ 151 | extractIO :: MonadIOControl m 152 | => proxy m -> OuterResult IO m a -> Either (OuterResult IO m b) a 153 | extractIO = extractI (Pm :: Pm IO) 154 | 155 | 156 | ------------------------------------------------------------------------------ 157 | liftControlIO :: MonadIOControl m 158 | => ((forall b. m b -> IO (OuterEffects IO m b)) -> IO a) 159 | -> m a 160 | liftControlIO f = liftControlI (\peel -> f (coercePeelI peel)) 161 | 162 | 163 | ------------------------------------------------------------------------------ 164 | controlIO :: MonadIOControl m 165 | => ((forall b. m b -> IO (OuterEffects IO m b)) 166 | -> IO (OuterEffects IO m a)) 167 | -> m a 168 | controlIO f = controlI (\peel -> f (coercePeelI peel)) 169 | 170 | 171 | ------------------------------------------------------------------------------ 172 | liftOpIO :: MonadIOControl m 173 | => ((a -> IO (OuterEffects IO m b)) -> IO (OuterEffects IO m c)) 174 | -> (a -> m b) 175 | -> m c 176 | liftOpIO = liftOpI 177 | 178 | 179 | ------------------------------------------------------------------------------ 180 | liftOpIO_ :: MonadIOControl m 181 | => (IO (OuterEffects IO m a) -> IO (OuterEffects IO m b)) 182 | -> m a 183 | -> m b 184 | liftOpIO_ = liftOpI_ 185 | 186 | 187 | ------------------------------------------------------------------------------ 188 | liftDiscardIO :: MonadIOControl m => (IO () -> IO a) -> m () -> m a 189 | liftDiscardIO = liftDiscardI 190 | 191 | 192 | ------------------------------------------------------------------------------ 193 | newtypeC(MonadIOInvariant j n m, MonadInnerInvariant j n IO m) 194 | 195 | 196 | ------------------------------------------------------------------------------ 197 | hoistisoIO :: MonadIOInvariant j n m 198 | => (forall b. IO b -> j b) 199 | -> (forall b. j b -> IO b) 200 | -> m a 201 | -> n a 202 | hoistisoIO = hoistisoI 203 | 204 | 205 | ------------------------------------------------------------------------------ 206 | newtypeC(MonadIOFunctor j n m, MonadInnerFunctor j n IO m) 207 | 208 | 209 | ------------------------------------------------------------------------------ 210 | hoistIO :: MonadIOFunctor j n m => (forall b. IO b -> j b) -> m a -> n a 211 | hoistIO = hoistI 212 | -------------------------------------------------------------------------------- /src/Control/Monad/Lift/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 11 | 12 | #ifdef LANGUAGE_DefaultSignatures 13 | {-# LANGUAGE DefaultSignatures #-} 14 | #endif 15 | 16 | #if defined(LANGUAGE_SafeHaskell) && __GLASGOW_HASKELL__ >= 704 17 | {-# LANGUAGE Unsafe #-} 18 | #endif 19 | 20 | #include "docmacros.h" 21 | 22 | module Control.Monad.Lift.Internal 23 | ( LayerEffects, LayerResult, LayerState, coercePeel 24 | , ComposeResult2 (ComposeResult2), ComposeResult3 (ComposeResult3) 25 | , ComposeResult4 (ComposeResult4) 26 | , OuterEffects, OuterResult, OuterState, coercePeelI 27 | , ComposeResult (ComposeResult), fromR, toR, fromS, toS 28 | , Iso1, Codomain1, from1, to1 29 | ) 30 | where 31 | 32 | -- base ---------------------------------------------------------------------- 33 | import Control.Arrow (first) 34 | #if MIN_VERSION_base(4, 7, 0) && __GLASGOW_HASKELL__ >= 710 35 | import Data.Coerce (Coercible, coerce) 36 | #endif 37 | import Data.Functor.Identity (Identity) 38 | #ifndef ClosedTypeFamilies 39 | import GHC.Exts (Any) 40 | import Unsafe.Coerce (unsafeCoerce) 41 | #endif 42 | 43 | 44 | #if MIN_VERSION_mmorph(1, 0, 1) 45 | -- mmorph -------------------------------------------------------------------- 46 | import Control.Monad.Trans.Compose (ComposeT (ComposeT)) 47 | 48 | 49 | #endif 50 | -- transformers -------------------------------------------------------------- 51 | #if !MIN_VERSION_transformers(0, 6, 0) 52 | import Control.Monad.Trans.Error (ErrorT) 53 | #endif 54 | #if MIN_VERSION_transformers(0, 4, 0) 55 | import Control.Monad.Trans.Except (ExceptT) 56 | #endif 57 | import Control.Monad.Trans.Identity (IdentityT) 58 | import Control.Monad.Trans.List (ListT) 59 | import Control.Monad.Trans.Maybe (MaybeT) 60 | import Control.Monad.Trans.Reader (ReaderT) 61 | import qualified Control.Monad.Trans.RWS.Lazy as L (RWST) 62 | import Control.Monad.Trans.RWS.Strict (RWST) 63 | import qualified Control.Monad.Trans.State.Lazy as L (StateT) 64 | import Control.Monad.Trans.State.Strict (StateT) 65 | import qualified Control.Monad.Trans.Writer.Lazy as L (WriterT) 66 | import Control.Monad.Trans.Writer.Strict (WriterT) 67 | 68 | 69 | ------------------------------------------------------------------------------ 70 | -- | The G(layereffect,layer effects) of the @t@ G(monadlayer,layer) of the 71 | -- monad @t m@. 72 | type LayerEffects t a = (LayerResult t a, LayerState t) 73 | 74 | 75 | ------------------------------------------------------------------------------ 76 | -- | The G(layerresult,layer result) of @t@. 77 | type family LayerResult (t :: (* -> *) -> * -> *) :: * -> * 78 | #if !MIN_VERSION_transformers(0, 6, 0) 79 | type instance LayerResult (ErrorT e) = Either e 80 | #endif 81 | #if MIN_VERSION_transformers(0, 4, 0) 82 | type instance LayerResult (ExceptT e) = Either e 83 | #endif 84 | type instance LayerResult IdentityT = Identity 85 | type instance LayerResult ListT = [] 86 | type instance LayerResult MaybeT = Maybe 87 | type instance LayerResult (ReaderT r) = Identity 88 | type instance LayerResult (StateT s) = Identity 89 | type instance LayerResult (L.StateT s) = Identity 90 | type instance LayerResult (RWST r w s) = (,) w 91 | type instance LayerResult (L.RWST r w s) = (,) w 92 | type instance LayerResult (WriterT w) = (,) w 93 | type instance LayerResult (L.WriterT w) = (,) w 94 | #if MIN_VERSION_mmorph(1, 0, 1) 95 | type instance LayerResult (ComposeT f g) = ComposeResult2 f g 96 | #endif 97 | 98 | 99 | ------------------------------------------------------------------------------ 100 | -- | The G(layerstate,layer state) of @t@. 101 | type family LayerState (t :: (* -> *) -> * -> *) :: * 102 | #if !MIN_VERSION_transformers(0, 6, 0) 103 | type instance LayerState (ErrorT e) = () 104 | #endif 105 | #if MIN_VERSION_transformers(0, 4, 0) 106 | type instance LayerState (ExceptT e) = () 107 | #endif 108 | type instance LayerState IdentityT = () 109 | type instance LayerState ListT = () 110 | type instance LayerState MaybeT = () 111 | type instance LayerState (ReaderT r) = r 112 | type instance LayerState (StateT s) = s 113 | type instance LayerState (L.StateT s) = s 114 | type instance LayerState (RWST r w s) = (r, s) 115 | type instance LayerState (L.RWST r w s) = (r, s) 116 | type instance LayerState (WriterT w) = () 117 | type instance LayerState (L.WriterT w) = () 118 | #if MIN_VERSION_mmorph(1, 0, 1) 119 | type instance LayerState (ComposeT f g) = (LayerState f, LayerState g) 120 | #endif 121 | 122 | 123 | ------------------------------------------------------------------------------ 124 | newtype ComposeResult2 u v a = ComposeResult2 125 | (LayerResult v (LayerEffects u a)) 126 | 127 | 128 | ------------------------------------------------------------------------------ 129 | instance (Functor (LayerResult u), Functor (LayerResult v)) => 130 | Functor (ComposeResult2 u v) 131 | where 132 | fmap f (ComposeResult2 a) = ComposeResult2 (fmap (first (fmap f)) a) 133 | {-# INLINE fmap #-} 134 | 135 | 136 | ------------------------------------------------------------------------------ 137 | newtype ComposeResult3 u v w a = ComposeResult3 138 | (LayerResult w (LayerEffects v (LayerEffects u a))) 139 | 140 | 141 | ------------------------------------------------------------------------------ 142 | instance 143 | ( Functor (LayerResult u), Functor (LayerResult v) 144 | , Functor (LayerResult w) 145 | ) 146 | => 147 | Functor (ComposeResult3 u v w) 148 | where 149 | fmap f (ComposeResult3 a) = ComposeResult3 150 | (fmap (first (fmap (first (fmap f)))) a) 151 | {-# INLINE fmap #-} 152 | 153 | 154 | ------------------------------------------------------------------------------ 155 | newtype ComposeResult4 u v w x a = ComposeResult4 156 | (LayerResult x (LayerEffects w (LayerEffects v (LayerEffects u a)))) 157 | 158 | 159 | ------------------------------------------------------------------------------ 160 | instance 161 | ( Functor (LayerResult u), Functor (LayerResult v) 162 | , Functor (LayerResult w), Functor (LayerResult x) 163 | ) 164 | => 165 | Functor (ComposeResult4 u v w x) 166 | where 167 | fmap f (ComposeResult4 a) = ComposeResult4 168 | (fmap (first (fmap (first (fmap (first (fmap f)))))) a) 169 | {-# INLINE fmap #-} 170 | 171 | 172 | ------------------------------------------------------------------------------ 173 | coercePeel :: forall t m. () 174 | => (forall a. t m a -> m (LayerEffects t a)) 175 | -> (forall a. t m a -> m (LayerEffects t a)) 176 | #if __GLASGOW_HASKELL__ >= 704 177 | coercePeel f = f 178 | #else 179 | coercePeel = unsafeCoerce 180 | #endif 181 | {-# INLINE coercePeel #-} 182 | 183 | 184 | ------------------------------------------------------------------------------ 185 | -- | The combined G(layereffect,layer effects) of all the 186 | -- G(outerlayer,outer layers) around @i@ of the monad @m@. 187 | type OuterEffects i m a = (OuterResult i m a, OuterState i m) 188 | 189 | 190 | ------------------------------------------------------------------------------ 191 | -- | The combined G(layerresult,layer results) of all the 192 | -- G(outerlayer,outer layers) around @i@ of the monad @m@. 193 | -- 194 | -- Note: On GHC 7.8 and up, this is implemented as a 195 | -- BWT(NewAxioms/ClosedTypeFamilies, closed type family). Older versions of 196 | -- GHC do not support closed type families, but we use various hacks involving 197 | -- 'Any' and 'unsafeCoerce' to provide the same interface. You should not need 198 | -- to worry about this; I am pretty sure it is safe. 199 | #ifdef ClosedTypeFamilies 200 | type family OuterResult (i :: * -> *) (m :: * -> *) :: * -> * 201 | where 202 | OuterResult m m = Identity 203 | OuterResult i (t m) = ComposeResult i t m 204 | OuterResult i m = OuterResult i (Codomain1 m) 205 | #else 206 | type OuterResult i m = OuterResult_ i m 207 | #endif 208 | 209 | 210 | ------------------------------------------------------------------------------ 211 | -- | The combined G(layerstate,layer states) of all the 212 | -- G(outerlayer,outer layers) around @i@ of the monad @m@. 213 | -- 214 | -- Note: On GHC 7.8 and up, this is implemented as a 215 | -- BWT(NewAxioms/ClosedTypeFamilies, closed type family). Older versions of 216 | -- GHC do not support closed type families, but we use various hacks involving 217 | -- 'GHC.Exts.Any' and 'Unsafe.Coerce.unsafeCoerce' to provide the same 218 | -- interface. You should not need to worry about this; I am pretty sure it is 219 | -- safe. 220 | #ifdef ClosedTypeFamilies 221 | type family OuterState (i :: * -> *) (m :: * -> *) :: * 222 | where 223 | OuterState m m = () 224 | OuterState i (t m) = (LayerState t, OuterState i m) 225 | OuterState i m = OuterState i (Codomain1 m) 226 | #else 227 | type OuterState i m = OuterState_ i m 228 | #endif 229 | 230 | 231 | ------------------------------------------------------------------------------ 232 | newtype ComposeResult i t m a = ComposeResult 233 | (OuterResult i m (LayerResult t a, LayerState t)) 234 | 235 | 236 | ------------------------------------------------------------------------------ 237 | instance (Functor (OuterResult i m), Functor (LayerResult t)) => 238 | Functor (ComposeResult i t m) 239 | where 240 | fmap f (ComposeResult a) = ComposeResult (fmap (first (fmap f)) a) 241 | 242 | 243 | #ifndef ClosedTypeFamilies 244 | ------------------------------------------------------------------------------ 245 | newtype OuterResult_ (i :: * -> *) (m :: * -> *) (a :: *) = OuterResult_ Any 246 | 247 | 248 | ------------------------------------------------------------------------------ 249 | newtype OuterState_ (i :: * -> *) (m :: * -> *) = OuterState_ Any 250 | 251 | 252 | #endif 253 | ------------------------------------------------------------------------------ 254 | #ifdef ClosedTypeFamilies 255 | toS, fromS, toR, fromR :: a -> a 256 | toS = id; fromS = id; toR = id; fromR = id 257 | #else 258 | toS :: x -> OuterState_ i m; toR :: x -> OuterResult_ i m a 259 | toS = OuterState_ . unsafeCoerce; toR = OuterResult_ . unsafeCoerce 260 | fromS :: OuterState_ i m -> x; fromR :: OuterResult_ i m a -> x 261 | fromS (OuterState_ x) = unsafeCoerce x; fromR (OuterResult_ x) = unsafeCoerce x 262 | #endif 263 | {-# INLINE toS #-} 264 | {-# INLINE toR #-} 265 | {-# INLINE fromS #-} 266 | {-# INLINE fromR #-} 267 | 268 | 269 | ------------------------------------------------------------------------------ 270 | coercePeelI :: forall i m. () 271 | => (forall a. m a -> i (OuterEffects i m a)) 272 | -> (forall a. m a -> i (OuterEffects i m a)) 273 | #if __GLASGOW_HASKELL__ >= 704 274 | coercePeelI f = f 275 | #else 276 | coercePeelI = unsafeCoerce 277 | #endif 278 | {-# INLINE coercePeelI #-} 279 | 280 | 281 | ------------------------------------------------------------------------------ 282 | class Iso1 t where 283 | type Codomain1 (t :: * -> *) :: * -> * 284 | to1 :: forall a. t a -> Codomain1 t a 285 | from1 :: forall a. Codomain1 t a -> t a 286 | #if MIN_VERSION_base(4, 7, 0) 287 | -- fails on GHC 7.8 for some reason 288 | #if __GLASGOW_HASKELL__ >= 710 289 | 290 | default to1 :: Coercible t (Codomain1 t) => forall a. t a -> Codomain1 t a 291 | to1 = coerce 292 | 293 | default from1 294 | :: Coercible (Codomain1 t) t => forall a. Codomain1 t a -> t a 295 | from1 = coerce 296 | #endif 297 | #endif 298 | 299 | 300 | #if MIN_VERSION_mmorph(1, 0, 1) 301 | ------------------------------------------------------------------------------ 302 | instance Iso1 (ComposeT f g m) where 303 | type Codomain1 (ComposeT f g m) = f (g m) 304 | to1 (ComposeT m) = m 305 | from1 = ComposeT 306 | 307 | 308 | #endif 309 | -------------------------------------------------------------------------------- /src/Control/Monad/Lift/Layer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MonoLocalBinds #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE OverlappingInstances #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | #ifdef LANGUAGE_SafeHaskell 14 | {-# LANGUAGE Trustworthy #-} 15 | #endif 16 | 17 | #include "newtypec.h" 18 | #include "overlap.h" 19 | 20 | {-| 21 | 22 | 23 | 24 | -} 25 | 26 | module Control.Monad.Lift.Layer 27 | ( MonadLayer 28 | , liftL 29 | , MonadLayerControl 30 | , suspendL 31 | , resumeL 32 | , captureL 33 | , extractL 34 | , liftControlL 35 | , controlL 36 | , liftOpL 37 | , liftOpL_ 38 | , liftDiscardL 39 | , MonadLayerInvariant 40 | , hoistisoL 41 | , MonadLayerFunctor 42 | , hoistL 43 | ) 44 | where 45 | 46 | -- layers -------------------------------------------------------------------- 47 | import Control.Monad.Lift 48 | ( MonadInner 49 | , liftI 50 | , MonadInnerControl 51 | , OuterEffects 52 | , OuterResult 53 | , OuterState 54 | , suspendI 55 | , resumeI 56 | , captureI 57 | , extractI 58 | , liftControlI 59 | , controlI 60 | , liftOpI 61 | , liftOpI_ 62 | , liftDiscardI 63 | , MonadInnerInvariant 64 | , hoistisoI 65 | , MonadInnerFunctor 66 | , hoistI 67 | ) 68 | import Control.Monad.Lift.Internal (coercePeelI) 69 | 70 | 71 | ------------------------------------------------------------------------------ 72 | class (MonadInner (t i) m, MonadInner i (t i)) => MonadLayer i t m 73 | | t m -> i, i m -> t 74 | 75 | 76 | ------------------------------------------------------------------------------ 77 | instance MonadInner i (t i) => MonadLayer i t (t i) 78 | 79 | 80 | ------------------------------------------------------------------------------ 81 | instance __OVERLAPPABLE__ (MonadLayer i s m, MonadInner (s i) (t m)) 82 | => MonadLayer i s (t m) 83 | 84 | 85 | ------------------------------------------------------------------------------ 86 | liftL :: MonadLayer i t m => t i a -> m a 87 | liftL = liftI 88 | 89 | 90 | ------------------------------------------------------------------------------ 91 | newtypeC(MonadLayerControl i t m, 92 | ( MonadInnerControl (t i) m 93 | , MonadLayer i t m 94 | )) 95 | 96 | 97 | ------------------------------------------------------------------------------ 98 | data Pm (m :: * -> *) = Pm 99 | 100 | 101 | ------------------------------------------------------------------------------ 102 | suspendL :: MonadLayerControl i t m 103 | => m a 104 | -> OuterState (t i) m 105 | -> t i (OuterEffects (t i) m a) 106 | suspendL = suspendI 107 | 108 | 109 | ------------------------------------------------------------------------------ 110 | resumeL :: forall i t m a proxy. MonadLayerControl i t m 111 | => proxy t 112 | -> OuterEffects (t i) m a 113 | -> m a 114 | resumeL _ = resumeI (Pm :: Pm (t i)) 115 | 116 | 117 | ------------------------------------------------------------------------------ 118 | captureL :: forall i t m proxy. MonadLayerControl i t m 119 | => proxy t 120 | -> m (OuterState (t i) m) 121 | captureL _ = captureI (Pm :: Pm (t i)) 122 | 123 | 124 | ------------------------------------------------------------------------------ 125 | extractL :: forall i t m a b proxy proxy'. MonadLayerControl i t m 126 | => proxy t 127 | -> proxy' m 128 | -> OuterResult (t i) m a 129 | -> Either (OuterResult (t i) m b) a 130 | extractL _ = extractI (Pm :: Pm (t i)) 131 | 132 | 133 | ------------------------------------------------------------------------------ 134 | liftControlL :: MonadLayerControl i t m 135 | => ((forall b. m b -> t i (OuterEffects (t i) m b)) -> t i a) 136 | -> m a 137 | liftControlL f = liftControlI (\peel -> f (coercePeelI peel)) 138 | 139 | 140 | ------------------------------------------------------------------------------ 141 | controlL :: MonadLayerControl i t m 142 | => ((forall b. m b -> t i (OuterEffects (t i) m b)) 143 | -> t i (OuterEffects (t i) m a)) 144 | -> m a 145 | controlL f = controlI (\peel -> f (coercePeelI peel)) 146 | 147 | 148 | ------------------------------------------------------------------------------ 149 | liftOpL :: MonadLayerControl i t m 150 | => ((a -> t i (OuterEffects (t i) m b)) -> t i (OuterEffects (t i) m c)) 151 | -> (a -> m b) 152 | -> m c 153 | liftOpL = liftOpI 154 | 155 | 156 | ------------------------------------------------------------------------------ 157 | liftOpL_ :: MonadLayerControl i t m 158 | => (t i (OuterEffects (t i) m a) -> t i (OuterEffects (t i) m b)) 159 | -> m a 160 | -> m b 161 | liftOpL_ = liftOpI_ 162 | 163 | 164 | ------------------------------------------------------------------------------ 165 | liftDiscardL :: MonadLayerControl i t m => (t i () -> t i a) -> m () -> m a 166 | liftDiscardL = liftDiscardI 167 | 168 | 169 | ------------------------------------------------------------------------------ 170 | newtypeC(MonadLayerInvariant j n i t m, 171 | ( MonadInnerInvariant j n (t i) m 172 | , MonadLayer i t m 173 | )) 174 | 175 | 176 | ------------------------------------------------------------------------------ 177 | hoistisoL :: MonadLayerInvariant j n i t m 178 | => (forall b. t i b -> j b) 179 | -> (forall b. j b -> t i b) 180 | -> m a 181 | -> n a 182 | hoistisoL = hoistisoI 183 | 184 | 185 | ------------------------------------------------------------------------------ 186 | newtypeC(MonadLayerFunctor j n i t m, 187 | ( MonadInnerFunctor j n (t i) m 188 | , MonadLayer i t m 189 | , MonadLayerInvariant j n i t m 190 | )) 191 | 192 | 193 | ------------------------------------------------------------------------------ 194 | hoistL :: MonadLayerFunctor j n i t m 195 | => (forall b. t i b -> j b) 196 | -> m a 197 | -> n a 198 | hoistL = hoistI 199 | -------------------------------------------------------------------------------- /src/Control/Monad/Lift/Top.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MonoLocalBinds #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | #ifdef LANGUAGE_SafeHaskell 13 | {-# LANGUAGE Trustworthy #-} 14 | #endif 15 | 16 | #include "newtypec.h" 17 | 18 | {-| 19 | 20 | 21 | 22 | -} 23 | 24 | module Control.Monad.Lift.Top 25 | ( MonadTop 26 | , liftT 27 | , MonadTopControl 28 | , suspendT 29 | , resumeT 30 | , captureT 31 | , extractT 32 | , liftControlT 33 | , controlT 34 | , liftOpT 35 | , liftOpT_ 36 | , liftDiscardT 37 | , MonadTopInvariant 38 | , hoistisoT 39 | , MonadTopFunctor 40 | , hoistT 41 | ) 42 | where 43 | 44 | -- layers -------------------------------------------------------------------- 45 | import Control.Monad.Lift 46 | ( MonadInner 47 | , liftI 48 | , MonadInnerControl 49 | , OuterEffects 50 | , OuterResult 51 | , OuterState 52 | , suspendI 53 | , resumeI 54 | , captureI 55 | , extractI 56 | , liftControlI 57 | , controlI 58 | , liftOpI 59 | , liftOpI_ 60 | , liftDiscardI 61 | , MonadInnerInvariant 62 | , hoistisoI 63 | , MonadInnerFunctor 64 | , hoistI 65 | ) 66 | import Control.Monad.Lift.Internal (coercePeelI) 67 | 68 | 69 | ------------------------------------------------------------------------------ 70 | newtypeC(MonadTop t m, MonadInner m (t m)) 71 | 72 | 73 | ------------------------------------------------------------------------------ 74 | liftT :: MonadTop t m => m a -> t m a 75 | liftT = liftI 76 | 77 | 78 | ------------------------------------------------------------------------------ 79 | newtypeC(MonadTopControl t m, (MonadInnerControl m (t m), MonadTop t m)) 80 | 81 | 82 | ------------------------------------------------------------------------------ 83 | data Pm (m :: * -> *) = Pm 84 | 85 | 86 | ------------------------------------------------------------------------------ 87 | suspendT :: MonadTopControl t m 88 | => t m a 89 | -> OuterState m (t m) 90 | -> m (OuterEffects m (t m) a) 91 | suspendT = suspendI 92 | 93 | 94 | ------------------------------------------------------------------------------ 95 | resumeT :: forall t m a. MonadTopControl t m 96 | => OuterEffects m (t m) a 97 | -> t m a 98 | resumeT = resumeI (Pm :: Pm m) 99 | 100 | 101 | ------------------------------------------------------------------------------ 102 | captureT :: forall t m. MonadTopControl t m => t m (OuterState m (t m)) 103 | captureT = captureI (Pm :: Pm m) 104 | 105 | 106 | ------------------------------------------------------------------------------ 107 | extractT :: forall t m a b proxy proxy'. MonadTopControl t m 108 | => proxy t 109 | -> proxy' m 110 | -> OuterResult m (t m) a 111 | -> Either (OuterResult m (t m) b) a 112 | extractT _ proxy = extractI proxy (Pm :: Pm (t m)) 113 | 114 | 115 | ------------------------------------------------------------------------------ 116 | liftControlT :: MonadTopControl t m 117 | => ((forall b. t m b -> m (OuterEffects m (t m) b)) -> m a) 118 | -> t m a 119 | liftControlT f = liftControlI (\peel -> f (coercePeelI peel)) 120 | 121 | 122 | ------------------------------------------------------------------------------ 123 | controlT :: MonadTopControl t m 124 | => ((forall b. t m b -> m (OuterEffects m (t m) b)) 125 | -> m (OuterEffects m (t m) a)) 126 | -> t m a 127 | controlT f = controlI (\peel -> f (coercePeelI peel)) 128 | 129 | 130 | ------------------------------------------------------------------------------ 131 | liftOpT :: MonadTopControl t m 132 | => ((a -> m (OuterEffects m (t m) b)) -> m (OuterEffects m (t m) c)) 133 | -> (a -> t m b) 134 | -> t m c 135 | liftOpT = liftOpI 136 | 137 | 138 | ------------------------------------------------------------------------------ 139 | liftOpT_ :: MonadTopControl t m 140 | => (m (OuterEffects m (t m) a) -> m (OuterEffects m (t m) b)) 141 | -> t m a 142 | -> t m b 143 | liftOpT_ = liftOpI_ 144 | 145 | 146 | ------------------------------------------------------------------------------ 147 | liftDiscardT :: MonadTopControl t m => (m () -> m a) -> t m () -> t m a 148 | liftDiscardT = liftDiscardI 149 | 150 | 151 | ------------------------------------------------------------------------------ 152 | newtypeC(MonadTopInvariant n t m, 153 | ( MonadInnerInvariant n (t n) m (t m) 154 | , MonadTop t m 155 | , MonadTop t n 156 | )) 157 | 158 | 159 | ------------------------------------------------------------------------------ 160 | hoistisoT :: MonadTopInvariant n t m 161 | => (forall b. m b -> n b) 162 | -> (forall b. n b -> m b) 163 | -> t m a 164 | -> t n a 165 | hoistisoT = hoistisoI 166 | 167 | 168 | ------------------------------------------------------------------------------ 169 | newtypeC(MonadTopFunctor n t m, 170 | ( MonadInnerFunctor n (t n) m (t m) 171 | , MonadTop t m 172 | , MonadTop t n 173 | , MonadTopInvariant n t m 174 | )) 175 | 176 | 177 | ------------------------------------------------------------------------------ 178 | hoistT :: MonadTopFunctor n t m 179 | => (forall b. m b -> n b) 180 | -> t m a 181 | -> t n a 182 | hoistT = hoistI 183 | -------------------------------------------------------------------------------- /src/Documentation/Layers/Glossary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | #include 5 | 6 | {-| 7 | 8 | The H(layers) package is not complicated, but it can be very difficult to 9 | understand if you aren't familiar with the jargon used in the documentation 10 | and in the naming. This module attempts to define precisely what is meant by 11 | the different pieces of jargon which I use throughout H(layers). Some of this 12 | jargon is appropriated from other places in the Haskell ecosystem, while some 13 | of it (to the best of my knowledge) is original. Even in the cases where it is 14 | appropriated, the intended meaning in the context of H(layers) may be subtlely 15 | different, and even I get confused sometimes about what I'm talking sometimes. 16 | So hopefully, by defining precisely the terms I use mean, I'll be able think 17 | more clearly and therefore communicate more clearly, and ultimately make 18 | H(layers) easier to understand. 19 | 20 | Each section of the documentation of this module explains a different piece of 21 | jargon, and, if applicable, shows how the concept it refers to is implemented 22 | in H(layers). 23 | 24 | -} 25 | 26 | module Documentation.Layers.Glossary 27 | {-# WARNING "This module exports no types, functions, classes or instances. It exists solely for the Haddock documentation it produces. You should not ever need to import it." #-} 28 | ( -- 29 | -- | #basemonad# 30 | 31 | -- * Base monad 32 | -- $basemonad 33 | 34 | -- | #computation# 35 | 36 | -- * Computation 37 | -- $computation 38 | 39 | -- | #computationalfeature# 40 | 41 | -- * Computational feature 42 | -- $computationalfeature 43 | 44 | -- | #controloperation# 45 | 46 | -- * Control operation 47 | -- $controloperation 48 | 49 | -- | #innermonad# 50 | 51 | -- * Inner monad 52 | -- $innermonad 53 | 54 | -- | #layerffects# 55 | 56 | -- * Layer effects 57 | -- $layereffectss 58 | 59 | -- | #layerresult# 60 | 61 | -- * Layer result 62 | -- $layerresult 63 | 64 | -- | #layerstate# 65 | 66 | -- * Layer state 67 | -- $layerstate 68 | 69 | -- | #morphism# 70 | 71 | -- * Morphism 72 | -- $morphism 73 | 74 | -- | #monadconstructor# 75 | 76 | -- * Monad constructor 77 | -- $monadconstructor 78 | 79 | -- | #monadinterface# 80 | 81 | -- * Monad interface 82 | -- $monadinterface 83 | 84 | -- | #monadlayer# 85 | 86 | -- * Monad layer 87 | -- $monadlayer 88 | 89 | -- | #monadtransformer# 90 | 91 | -- * Monad transformer 92 | -- $monadtransformer 93 | 94 | -- | #monadtransformerstack# 95 | 96 | -- * Monad transformer stack 97 | -- $monadtransformerstack 98 | 99 | -- | #monadictype# 100 | 101 | -- * Monadic type 102 | -- $monadictype 103 | 104 | -- | #opentypeclass# 105 | 106 | -- | #closedtypeclass# 107 | 108 | -- * Open and closed type classes 109 | -- $opentypeclass 110 | 111 | -- | #outerlayers# 112 | 113 | -- * Outer layers 114 | -- $outerlayers 115 | 116 | -- | #passthroughinstance# 117 | 118 | -- * Pass-through instance 119 | -- $passthroughinstance 120 | 121 | -- | #shortcircuit# 122 | 123 | -- * Short circuit 124 | -- $shortcircuit 125 | 126 | -- | #sideeffect# 127 | 128 | -- * Side-effect 129 | -- $sideeffect 130 | 131 | -- | #universalpassthroughinstance# 132 | 133 | -- * Universal pass-through instance 134 | -- $universalpassthroughinstance 135 | ) 136 | where 137 | 138 | {-$basemonad 139 | 140 | A monad is a /base monad/ if it is not built from any monad transformers. 141 | Common base monads are 'System.IO.IO', 'Data.Functor.Identity.Identity' and 142 | 'Data.Maybe.Maybe'. 143 | 144 | It also makes sense to talk about the base monad of a monad which is built 145 | from a stack of monad transformers. 146 | 147 | monad can be build on top of another monad and still be a base monad, just as 148 | long as it's monomorphic 149 | 150 | The /base monad/ of a particular monad is the<#monadtransformerstack transformer stack> is the monad 151 | at the bottom of the stack. 152 | 153 | This concept is implemented using functional dependencies in the module "Control.Monad.Lift.Base". 154 | 155 | -} 156 | 157 | {-$computation 158 | 159 | 160 | 161 | -} 162 | 163 | {-$computationalfeature 164 | 165 | 166 | 167 | -} 168 | 169 | {-$controloperation 170 | 171 | 172 | 173 | -} 174 | 175 | {-$innermonad 176 | 177 | 178 | 179 | -} 180 | 181 | {-$layereffectss 182 | 183 | 184 | 185 | 186 | -} 187 | 188 | {-$layerresult 189 | 190 | The part of the result type of the inner function of @t@ which is not 191 | part of the (updated) 'LayerState'. 192 | 193 | -} 194 | 195 | {-$layerstate 196 | 197 | The parameters needed by the inner function of @t@ to return a computation in 198 | the monad @m@. We call these parameters \"state\", because a component of the 199 | return value of the @m@-computation returned by @t@'s inner function is often 200 | meant to update one or more of these parameters, like a 201 | 'Control.Monad.Trans.State.Strict.State' monad. 202 | 203 | -} 204 | 205 | {-$morphism 206 | 207 | 208 | 209 | -} 210 | 211 | {-$monadconstructor 212 | 213 | 214 | 215 | -} 216 | 217 | {-$monadinterface 218 | 219 | 220 | 221 | -} 222 | 223 | {-$monadlayer 224 | 225 | 226 | 227 | -} 228 | 229 | {-$monadtransformer 230 | 231 | 232 | 233 | -} 234 | 235 | {-$monadtransformerstack 236 | 237 | 238 | 239 | -} 240 | 241 | {-$monadictype 242 | 243 | 244 | 245 | -} 246 | 247 | {-$opentypeclass 248 | 249 | 250 | 251 | -} 252 | 253 | {-$outerlayers 254 | 255 | 256 | 257 | -} 258 | 259 | {-$passthroughinstance 260 | 261 | 262 | 263 | -} 264 | 265 | {-$shortcircuit 266 | 267 | 268 | 269 | -} 270 | 271 | {-$sideeffect 272 | 273 | 274 | 275 | -} 276 | 277 | {-$universalpassthroughinstance 278 | 279 | 280 | 281 | -} 282 | -------------------------------------------------------------------------------- /src/Monad/Abort.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE OverlappingInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 9 | 10 | #include "docmacros.h" 11 | #include "overlap.h" 12 | 13 | {-| 14 | 15 | This module defines the 'MonadAbort' G(monadinterface,interface). It, along 16 | with its sister G(monadinterface,interface) 'MonadRecover', is inspired by 17 | the 18 | 19 | from the 20 | module 21 | module of the H(monad-abort-fd) package. It consists of: 22 | 23 | * The 'MonadAbort' constraint. 24 | * The 'abort' operation. 25 | * Instances of 'MonadAbort': 26 | 27 | * For the following G(basemonad,base monads): 28 | 29 | * 'Either' 30 | * @[@@]@ 31 | * 'Maybe' 32 | * 'IO' 33 | * 'STM' 34 | 35 | * For arbitrary G(innermonad,inner monads) wrapped by one of the 36 | following G(monadlayer,monad layers): 37 | 38 | * 'ErrorT' 39 | * 'ExceptT' 40 | * 'ListT' 41 | * 'MaybeT' 42 | 43 | * G(universalpassthroughinstance,Pass-through instances) for: 44 | 45 | * Any G(innermonad,inner monad) with an existing 'MonadAbort' 46 | instance wrapped by any G(monadlayer,monad layer) implementing 47 | 'Control.Monad.Lift.MonadTrans'. 48 | * The 'Product' of any two G(monadictype,monadic types) which both 49 | have existing 'MonadAbort' instances. 50 | * The 51 | of two G(monadlayer,monad layers) wrapped around an 52 | G(innermonad,inner monad), where either the 53 | G(innermonad,inner monad) or one or more of the composed 54 | G(monadlayer,monad layers) has an existing instance for 55 | 'MonadAbort'. 56 | 57 | The 'Monad.Throw.MonadThrow', 'Monad.Catch.MonadCatch' and 58 | 'Monad.Error.MonadError' G(monadinterface,interfaces) are all built on top of 59 | 'MonadAbort'. 60 | 61 | -} 62 | 63 | module Monad.Abort 64 | ( MonadAbort (abort) 65 | ) 66 | where 67 | 68 | -- base ---------------------------------------------------------------------- 69 | import Control.Exception (SomeException, throwIO) 70 | import Control.Monad (mzero) 71 | #if MIN_VERSION_base(4, 3, 0) 72 | import GHC.Conc.Sync (STM, throwSTM) 73 | #else 74 | import GHC.Conc (STM, unsafeIOToSTM) 75 | #endif 76 | 77 | 78 | -- layers -------------------------------------------------------------------- 79 | import Control.Monad.Lift (MonadTrans, lift) 80 | 81 | 82 | #if MIN_VERSION_mmorph(1, 0, 1) 83 | -- mmorph -------------------------------------------------------------------- 84 | import Control.Monad.Trans.Compose (ComposeT (ComposeT)) 85 | 86 | 87 | #endif 88 | -- transformers -------------------------------------------------------------- 89 | #if !MIN_VERSION_transformers(0, 6, 0) 90 | import Control.Monad.Trans.Error (ErrorT (ErrorT), Error) 91 | #endif 92 | #if MIN_VERSION_transformers(0, 4, 0) 93 | import Control.Monad.Trans.Except (ExceptT (ExceptT)) 94 | #endif 95 | import Control.Monad.Trans.Maybe (MaybeT) 96 | import Control.Monad.Trans.List (ListT) 97 | #if MIN_VERSION_transformers(0, 3, 0) 98 | import Data.Functor.Product (Product (Pair)) 99 | #endif 100 | 101 | 102 | ------------------------------------------------------------------------------ 103 | -- | The @'MonadAbort' e@ constraint matches monads whose 104 | -- G(computation, computations) can \"G(shortcircuit,fail)\" (be aborted), 105 | -- and, if possible, store a value of type @e@ containing information about 106 | -- the nature of the failure. 107 | -- 108 | -- Every monad which permits an instance 'Control.Monad.MonadPlus' trivially 109 | -- permits an instance of 'MonadAbort': for these monads, the @e@ paramater to 110 | -- 'abort' is discarded, and 'abort' is implemented as @'const' 'mzero'@. 111 | -- 112 | -- The other class of monads that permit a 'MonadAbort' instance are the 113 | -- 'Either'-like monads (including 'IO'): these monads actually store the @e@ 114 | -- parameter passed to the 'abort' operation on failure. These monads also 115 | -- generally permit a 'Monad.Recover.MonadRecover' instance that allows the 116 | -- @e@ value to be recovered using the 'Monad.Recover.recover' operation. 117 | -- 118 | -- Minimal complete definition: 'abort'. 119 | class Monad m => MonadAbort e m where 120 | -- | The following law holds for valid instances of 'MonadAbort': 121 | -- 122 | -- [Zero] @'abort' e '>>=' f ≡ 'abort' e@ 123 | -- 124 | -- In other words, 'abort' causes the computation to 125 | -- G(shortcircuit, short-circuit). 126 | abort :: e -> m a 127 | 128 | #ifdef MinimalPragma 129 | {-# MINIMAL abort #-} 130 | 131 | #endif 132 | 133 | ------------------------------------------------------------------------------ 134 | instance MonadAbort e (Either e) where 135 | abort = Left 136 | 137 | 138 | ------------------------------------------------------------------------------ 139 | instance MonadAbort e ([]) where 140 | abort = const mzero 141 | 142 | 143 | ------------------------------------------------------------------------------ 144 | instance MonadAbort e Maybe where 145 | abort = const mzero 146 | 147 | 148 | ------------------------------------------------------------------------------ 149 | instance MonadAbort SomeException IO where 150 | abort = throwIO 151 | 152 | 153 | ------------------------------------------------------------------------------ 154 | instance MonadAbort SomeException STM where 155 | #if MIN_VERSION_base(4, 3, 0) 156 | abort = throwSTM 157 | #else 158 | abort = unsafeIOToSTM . throwIO 159 | #endif 160 | 161 | 162 | ------------------------------------------------------------------------------ 163 | instance Monad m => MonadAbort e (ListT m) where 164 | abort = const mzero 165 | 166 | 167 | ------------------------------------------------------------------------------ 168 | instance Monad m => MonadAbort e (MaybeT m) where 169 | abort = const mzero 170 | 171 | 172 | #if !MIN_VERSION_transformers(0, 6, 0) 173 | ------------------------------------------------------------------------------ 174 | instance (Error e, Monad m) => MonadAbort e (ErrorT e m) where 175 | abort = ErrorT . return . Left 176 | 177 | 178 | #endif 179 | #if MIN_VERSION_transformers(0, 4, 0) 180 | ------------------------------------------------------------------------------ 181 | instance Monad m => MonadAbort e (ExceptT e m) where 182 | abort = ExceptT . return . Left 183 | 184 | 185 | #endif 186 | #if MIN_VERSION_transformers(0, 3, 0) 187 | ------------------------------------------------------------------------------ 188 | instance (MonadAbort e f, MonadAbort e g) => MonadAbort e (Product f g) where 189 | abort e = Pair (abort e) (abort e) 190 | 191 | 192 | #endif 193 | #if MIN_VERSION_mmorph(1, 0, 1) 194 | ------------------------------------------------------------------------------ 195 | instance MonadAbort e (f (g m)) => MonadAbort e (ComposeT f g m) where 196 | abort = ComposeT . abort 197 | 198 | 199 | #endif 200 | ------------------------------------------------------------------------------ 201 | instance __OVERLAPPABLE__ (MonadTrans t, MonadAbort e m, Monad (t m)) => 202 | MonadAbort e (t m) 203 | where 204 | abort = lift . abort 205 | {-# INLINABLE abort #-} 206 | -------------------------------------------------------------------------------- /src/Monad/Catch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | #include "docmacros.h" 11 | #include "newtypec.h" 12 | 13 | {-| 14 | 15 | This module defines the 'MonadCatch' G(monadinterface,interface). The 16 | 'MonadCatch' G(monadinterface,interface) is a specialisation of the 17 | 'MonadRecover' G(monadinterface,interface). It, along with its sister 18 | G(monadinterface,interface) 'MonadThrow', is designed to be largely compatible 19 | with the "Control.Exception" module from H(base). It consists of: 20 | 21 | * The 'MonadCatch' constraint (a specialisation of the 'MonadRecover' 22 | constraint). 23 | * The 'catch' operation (a specialisation of the 'recover' operation). 24 | * The following alternate versions of 'catch' as defined in 25 | "Control.Exception": 26 | 27 | * 'catches' 28 | * 'catchJust' 29 | * 'handle' 30 | * 'handleJust' 31 | * 'try' 32 | * 'tryJust' 33 | 34 | * The helper 'Handler' data type (needed for 'catches'). 35 | 36 | -} 37 | 38 | module Monad.Catch 39 | ( MonadCatch 40 | , catch 41 | , catches 42 | , Handler (Handler) 43 | , catchJust 44 | , handle 45 | , handleJust 46 | , try 47 | , tryJust 48 | ) 49 | where 50 | 51 | -- base ---------------------------------------------------------------------- 52 | import Control.Exception 53 | ( Exception (fromException) 54 | , SomeException 55 | ) 56 | import Control.Monad (liftM) 57 | #if !MIN_VERSION_base(4, 6, 0) 58 | import Prelude hiding (catch) 59 | #endif 60 | 61 | 62 | -- layers -------------------------------------------------------------------- 63 | import Monad.Recover (MonadRecover (recover)) 64 | import Monad.Throw (throw) 65 | 66 | 67 | ------------------------------------------------------------------------------ 68 | -- | 'MonadCatch' is an alias of 'MonadRecover' where the failure state type 69 | -- @e@ is fixed to 'SomeException'. It represents the class of monads which 70 | -- support some sort of 'Control.Exception.catch'-like operation to recover 71 | -- from failures caused by a call to 'Monad.Throw.throw'. 72 | newtypeC(MonadCatch m, MonadRecover SomeException m) 73 | 74 | 75 | ------------------------------------------------------------------------------ 76 | -- | This is the simplest of the exception-catching functions. It takes a 77 | -- single argument, runs it, and if an exception is raised the \"handler\" 78 | -- is executed, with the value of the exception passed as an argument. 79 | -- Otherwise, the result is returned as normal. For example: 80 | -- 81 | -- @'catch' ('readFile' f) 82 | -- (\\e -> do let err = 'show' (e :: 'Control.Exception.IOException') 83 | -- 'System.IO.hPutStr' 'System.IO.stderr' ("Warning: Couldn't open " '++' f '++' ": " '++' err) 84 | -- 'return' "")@ 85 | -- 86 | -- Note that we have to give a type signature to e, or the program will 87 | -- not typecheck as the type is ambiguous. While it is possible to catch 88 | -- exceptions of any type, see the section \"Catching all exceptions\" in 89 | -- "Control.Exception" for an explanation of the problems with doing so. 90 | -- 91 | -- Note that due to Haskell's unspecified evaluation order, an expression 92 | -- may throw one of several possible exceptions: consider the expression 93 | -- @('error' \"urk\") '+' (1 \``div`\` 0)@. Does the expression throw 94 | -- @'Control.Exception.ErrorCall' \"urk\"@, or 95 | -- 'Control.Exception.DivideByZero'? 96 | -- 97 | -- The answer is \"it might throw either\"; the choice is 98 | -- non-deterministic. If you are catching any type of exception then you 99 | -- might catch either. If you are calling catch with type 100 | -- @m 'Int' -> ('Control.Exception.ArithException' -> m 'Int') -> m 'Int'@ 101 | -- then the handler may get run with 'Control.Exception.DivideByZero' as an 102 | -- argument, or an @'Control.Exception.ErrorCall' \"urk\"@ exception may be 103 | -- propogated further up. If you call it again, you might get a the opposite 104 | -- behaviour. This is ok, because 'catch' is a monadic computation. 105 | catch :: (Exception e, MonadCatch m) => m a -> (e -> m a) -> m a 106 | catch m h = recover m (\e -> maybe (throw e) h (fromException e)) 107 | {-# INLINABLE catch #-} 108 | 109 | 110 | ------------------------------------------------------------------------------ 111 | -- | Sometimes you want to catch two different sorts of exception. You could 112 | -- do something like 113 | -- 114 | -- @f = expr \``catch`\` \\(ex :: 'Control.Exception.ArithException') -> handleArith ex 115 | -- \``catch`\` \\(ex :: 'Control.Exception.IOException') -> handleIO ex@ 116 | -- 117 | -- However, there are a couple of problems with this approach. The first is 118 | -- that having two exception handlers is inefficient. However, the more 119 | -- serious issue is that the second exception handler will catch exceptions 120 | -- in the first, e.g. in the example above, if @handleArith@ throws an 121 | -- 'Control.Exception.IOException' then the second exception handler will 122 | -- catch it. 123 | -- 124 | -- Instead, we provide a function 'catches', which would be used thus: 125 | -- 126 | -- @f = expr \``catches`\` ['Handler' (\\(ex :: 'Control.Exception.ArithException') -> handleArith ex), 127 | -- 'Handler' (\\(ex :: 'Control.Exception.IOException') -> handleIO ex)]@ 128 | catches :: MonadCatch m => m a -> [Handler m a] -> m a 129 | catches m handlers = m `catch` go handlers 130 | where 131 | go [] e = throw e 132 | go (Handler handler:xs) e = maybe (go xs e) handler (fromException e) 133 | {-# INLINABLE catches #-} 134 | 135 | 136 | ------------------------------------------------------------------------------ 137 | -- | You need this when using 'catches'. 138 | data Handler m a = forall e. Exception e => Handler (e -> m a) 139 | 140 | 141 | ------------------------------------------------------------------------------ 142 | -- | The function 'catchJust' is like 'catch', but it takes an extra argument 143 | -- which is an /exception predicate/, a function which selects which type of 144 | -- exceptions we're interested in. 145 | -- 146 | -- @'catchJust' (\\e -> if 'System.IO.Error.isDoesNotExistErrorType' ('System.IO.Error.ioeGetErrorType' e) then 'Just' () else 'Nothing') 147 | -- ('readFile' f) 148 | -- (\\_ -> do 'System.IO.hPutStrLn' 'System.IO.stderr' ("No such file: " '++' 'show' f) 149 | -- 'return' "")@ 150 | -- 151 | -- Any other exceptions which are not matched by the predicate are re-raised, 152 | -- and may be caught by an enclosing 'catch', 'catchJust', etc. 153 | catchJust 154 | :: (Exception e, MonadCatch m) 155 | => (e -> Maybe b) 156 | -> m a 157 | -> (b -> m a) 158 | -> m a 159 | catchJust p a handler = catch a (\e -> maybe (throw e) handler (p e)) 160 | {-# INLINABLE catchJust #-} 161 | 162 | 163 | ------------------------------------------------------------------------------ 164 | -- | A version of 'catch' with the arguments swapped around; useful in 165 | -- situations where the code for the handler is shorter. For example: 166 | -- 167 | -- @do 'handle' (\\'Control.Exception.NonTermination' -> 'System.Exit.exitWith' ('System.Exit.ExitFailure' 1)) '$' 168 | -- ...@ 169 | handle :: (Exception e, MonadCatch m) => (e -> m a) -> m a -> m a 170 | handle = flip catch 171 | {-# INLINABLE handle #-} 172 | 173 | 174 | ------------------------------------------------------------------------------ 175 | -- | A version of 'catchJust' with the arguments swapped around (see 176 | -- 'handle'). 177 | handleJust 178 | :: (Exception e, MonadCatch m) 179 | => (e -> Maybe b) 180 | -> (b -> m a) 181 | -> m a 182 | -> m a 183 | handleJust = flip . catchJust 184 | {-# INLINABLE handleJust #-} 185 | 186 | 187 | ------------------------------------------------------------------------------ 188 | -- | Similar to 'catch', but returns an 'Either' result which is @('Right' a)@ 189 | -- if no exception of type @e@ was raised, or @('Left' ex)@ if an exception of 190 | -- type @e@ was raised and its value is @ex@. If any other type of exception 191 | -- is raised than it will be propogated up to the next enclosing exception 192 | -- handler. 193 | -- 194 | -- @'try' a = 'handle' ('return' '.' 'Left') '.' 'liftM' 'Right'@ 195 | try :: (Exception e, MonadCatch m) => m a -> m (Either e a) 196 | try = handle (return . Left) . liftM Right 197 | {-# INLINABLE try #-} 198 | 199 | 200 | ------------------------------------------------------------------------------ 201 | -- | A variant of 'try' that takes an exception predicate to select which 202 | -- exceptions are caught (c.f. 'catchJust'). If the exception does not match 203 | -- the predicate, it is re-thrown. 204 | tryJust 205 | :: (Exception e, MonadCatch m) 206 | => (e -> Maybe b) 207 | -> m a 208 | -> m (Either b a) 209 | tryJust p = handleJust p (return . Left) . liftM Right 210 | {-# INLINABLE tryJust #-} 211 | -------------------------------------------------------------------------------- /src/Monad/Cont.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE OverlappingInstances #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | #include "docmacros.h" 9 | #include "overlap.h" 10 | 11 | {-| 12 | 13 | This module defines the 'MonadCont' G(monadinterface,interface). It is 14 | designed to be compatible with the with the 15 | T(mtl,Control-Monad-Cont-Class,MonadCont) interface from the H(mtl) 16 | package. It consists of: 17 | 18 | * The 'MonadCont' constraint. 19 | * The 'callCC' operation. 20 | * Instances of 'MonadCont': 21 | 22 | * For arbitrary G(innermonad,inner monads) wrapped by 'ContT'. 23 | * G(universalpassthroughinstance,Pass-through instances) for: 24 | 25 | * Any G(innermonad,inner monad) with an existing 'MonadCont' 26 | instance wrapped by any G(monadlayer,monad layer) implementing 27 | 'Control.Monad.Lift.MonadTransControl'. 28 | * The 29 | of two G(monadlayer,monad layers) wrapped around an 30 | G(innermonad,inner monad), where either the 31 | G(innermonad,inner monad) or one or more of the composed 32 | G(monadlayer,monad layers) has an existing instance for 33 | 'MonadCont'. 34 | 35 | -} 36 | 37 | module Monad.Cont 38 | ( MonadCont (callCC) 39 | ) 40 | where 41 | 42 | -- layers -------------------------------------------------------------------- 43 | import Control.Monad.Lift 44 | ( MonadTransControl 45 | , lift, liftControl, resume 46 | ) 47 | 48 | 49 | #if MIN_VERSION_mmorph(1, 0, 1) 50 | -- mmorph -------------------------------------------------------------------- 51 | import Control.Monad.Trans.Compose (ComposeT (ComposeT)) 52 | 53 | 54 | #endif 55 | -- transformers -------------------------------------------------------------- 56 | import Control.Monad.Trans.Cont (ContT (ContT)) 57 | 58 | 59 | ------------------------------------------------------------------------------ 60 | -- | The 'MonadCont' G(monadinterface,interface) represents computations in 61 | -- continuation-passing style (CPS). In continuation-passing style function 62 | -- result is not returned, but instead is passed to another function, received 63 | -- as a parameter (continuation). Computations are built up from sequences of 64 | -- nested continuations, terminated by a final continuation (often 'id') which 65 | -- produces the final result. Since continuations are functions which 66 | -- represent the future of a computation, manipulation of the continuation 67 | -- functions can achieve complex manipulations of the future of the 68 | -- computation, such as interrupting a computation in the middle, aborting a 69 | -- portion of a computation, restarting a computation, and interleaving 70 | -- execution of computations. The 'MonadCont' G(monadinterface,interface) 71 | -- adapts CPS to the structure of a monad. 72 | -- 73 | -- Before using the 'MonadCont' G(monadinterface,interface), be sure that you 74 | -- have a firm understanding of continuation-passing style and that 75 | -- continuations represent the best solution to your particular design 76 | -- problem. Many algorithms which require continuations in other languages do 77 | -- not require them in Haskell, due to Haskell's lazy semantics. Abuse of the 78 | -- 'MonadCont' G(monadinterface,interface) can produce code that is impossible 79 | -- to understand and maintain. 80 | -- 81 | -- Minimal complete definition: 'callCC'. 82 | class Monad m => MonadCont m where 83 | -- | 'callCC' (call-with-current-continuation) calls a function with the 84 | -- current continuation as its argument. Provides an escape continuation 85 | -- mechanism for use with instances of 'MonadCont'. Escape continuations 86 | -- allow to abort the current computation and return a value immediately. 87 | -- They achieve a similar effect to 'Monad.Abort.abort' and 88 | -- 'Monad.Recover.recover' from the 'Monad.Abort.MonadAbort' and 89 | -- 'Monad.Recover.MonadRecover' G(monadinterface,interfaces). Advantage of 90 | -- this function over calling 'return' is that it makes the continuation 91 | -- explicit, allowing more flexibility and better control. 92 | -- 93 | -- The standard idiom used with 'callCC' is to provide a lambda-expression 94 | -- to name the continuation. Then calling the named continuation anywhere 95 | -- within its scope will escape from the computation, even if it is many 96 | -- layers deep within nested computations. 97 | callCC :: ((a -> m b) -> m a) -> m a 98 | 99 | #ifdef MinimalPragma 100 | {-# MINIMAL callCC #-} 101 | 102 | #endif 103 | 104 | ------------------------------------------------------------------------------ 105 | instance MonadCont (ContT r m) where 106 | callCC f = ContT $ \c -> let ContT m = f $ \a -> ContT $ \_ -> c a in m c 107 | {-# INLINABLE callCC #-} 108 | 109 | 110 | #if MIN_VERSION_mmorph(1, 0, 1) 111 | ------------------------------------------------------------------------------ 112 | instance MonadCont (f (g m)) => MonadCont (ComposeT f g m) where 113 | callCC f = 114 | ComposeT (callCC (\c -> let ComposeT m = f (ComposeT . c) in m)) 115 | {-# INLINABLE callCC #-} 116 | 117 | 118 | #endif 119 | ------------------------------------------------------------------------------ 120 | instance __OVERLAPPABLE__ (MonadTransControl t, MonadCont m, Monad (t m)) => 121 | MonadCont (t m) 122 | where 123 | callCC f = liftControl (\peel -> callCC $ \c -> peel . f $ \a -> 124 | lift (peel (return a) >>= c)) >>= resume 125 | {-# INLINABLE callCC #-} 126 | -------------------------------------------------------------------------------- /src/Monad/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MonoLocalBinds #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 9 | 10 | #include "docmacros.h" 11 | #include "newtypec.h" 12 | 13 | {-| 14 | 15 | This module defines the 'MonadError' G(monadinterface,interface). It is 16 | entirely superfluous, consisting only of synonyms and re-exports, but is 17 | provided for compatibility with the 18 | T(mtl,Control-Monad-Error-Class,MonadError) G(monadinterface,interface) from 19 | the H(mtl) package. It consists of: 20 | 21 | * The 'MonadError' constraint (a synonym for 'MonadRecover'). 22 | * The 'throwError' operation (a synonym for 'abort'). 23 | * The 'catchError' operation (a synonym for 'recover'). 24 | #if !MIN_VERSION_transformers(0, 6, 0) 25 | * The 'Error' class and its 'noMsg' and 'strMsg' operations (re-exported 26 | from H(transformers)). 27 | #endif 28 | 29 | -} 30 | 31 | module Monad.Error 32 | ( 33 | #if !MIN_VERSION_transformers(0, 6, 0) 34 | Error (noMsg, strMsg) 35 | , 36 | #endif 37 | MonadError 38 | , catchError 39 | , throwError 40 | ) 41 | where 42 | 43 | -- layers -------------------------------------------------------------------- 44 | import Monad.Abort (MonadAbort (abort)) 45 | import Monad.Recover (MonadRecover (recover)) 46 | 47 | 48 | #if !MIN_VERSION_transformers(0, 6, 0) 49 | -- transformers -------------------------------------------------------------- 50 | #if __GLASGOW_HASKELL__ >= 706 51 | import Control.Monad.Trans.Error (Error (noMsg, strMsg)) 52 | #else 53 | import Control.Monad.Trans.Error (Error (..)) 54 | #endif 55 | 56 | 57 | #endif 58 | ------------------------------------------------------------------------------ 59 | -- | The strategy of combining computations that can throw exceptions by 60 | -- bypassing bound functions from the point an exception is thrown to the 61 | -- point that it is handled. 62 | -- 63 | -- Is parameterized over the type of error information and the monad type 64 | -- constructor. It is common to use @'Either' 'String'@ as the monad type 65 | -- constructor for an error monad in which error descriptions take the form of 66 | -- strings. In that case and many other common cases the resulting monad is 67 | -- already defined as an instance of the 'MonadError' class. 68 | -- 69 | -- You can also define your own error type and\/or use a monad type 70 | -- constructor other than @'Either' 'String'@ or 71 | -- @'Either' 'Control.Exception.IOError'@. In these cases you will have to 72 | -- explicitly define instances of the 'Error' and\/or 'MonadError' classes. 73 | newtypeC(MonadError e m, MonadRecover e m) 74 | 75 | 76 | ------------------------------------------------------------------------------ 77 | -- | Is used within a monadic computation to begin exception processing. 78 | throwError :: MonadError e m => e -> m a 79 | throwError = abort 80 | 81 | 82 | ------------------------------------------------------------------------------ 83 | -- | A handler function to handle previous errors and return to normal 84 | -- execution. 85 | -- 86 | -- A common idiom is: 87 | -- 88 | -- @do { action1; action2; action3 } \``catchError`\` handler@ 89 | -- 90 | -- where the @action@ functions can call 'throwError'. 91 | -- 92 | -- Note that @handler@ and the do-block must have the same return type. 93 | catchError :: MonadError e m => m a -> (e -> m a) -> m a 94 | catchError = recover 95 | -------------------------------------------------------------------------------- /src/Monad/Fork.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE OverlappingInstances #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | #include "docmacros.h" 10 | #include "overlap.h" 11 | 12 | {-| 13 | 14 | This module defines the 'MonadFork' G(monadinterface,interface). It is 15 | designed to be largely compatible with the "Control.Concurrent" module from 16 | H(base). It consists of: 17 | 18 | * The 'MonadFork' constraint. 19 | * The 'fork' operation. 20 | * The 'forkOn' operation. 21 | * Instances of 'MonadFork': 22 | 23 | * For the G(basemonad,base monad) 'IO'. 24 | * G(universalpassthroughinstance,Pass-through instances) for: 25 | 26 | * Any G(innermonad,inner monad) with an existing 'MonadFork' 27 | instance wrapped by any G(monadlayer,monad layer) implementing 28 | 'Control.Monad.Lift.MonadTransControl'. 29 | * The 'Product' of any two G(monadictype,monadic types) which both 30 | have existing 'MonadFork' instances. 31 | * The 32 | of two G(monadlayer, monad layers) wrapped around an 33 | G(innermonad,inner monad), where either the 34 | G(innermonad,inner monad) or one or more of the composed 35 | G(monadlayer,monad layers) has an existing instance for 36 | 'MonadFork'. 37 | 38 | * The 'forkWithUnmask', 'forkOnWithUnmask' and 'forkFinally' utility 39 | operations as provided by "Control.Concurrent". 40 | 41 | -} 42 | 43 | module Monad.Fork 44 | ( MonadFork (fork, forkOn) 45 | , forkWithUnmask, forkOnWithUnmask, forkFinally 46 | ) 47 | where 48 | 49 | -- base ---------------------------------------------------------------------- 50 | import Control.Concurrent (ThreadId, forkIO) 51 | #if MIN_VERSION_base(4, 4, 0) 52 | import qualified Control.Concurrent (forkOn) 53 | #endif 54 | 55 | 56 | -- layers -------------------------------------------------------------------- 57 | import Control.Monad.Lift (MonadTransControl, liftDiscard) 58 | import Monad.Mask 59 | ( MonadMask, mask 60 | , MaskingState (Unmasked), setMaskingState 61 | ) 62 | import Monad.Try (MonadTry, mtry) 63 | 64 | 65 | #if MIN_VERSION_mmorph(1, 0, 1) 66 | -- mmorph -------------------------------------------------------------------- 67 | import Control.Monad.Trans.Compose (ComposeT (ComposeT)) 68 | 69 | 70 | #endif 71 | #if MIN_VERSION_transformers(0, 3, 0) 72 | -- transformers -------------------------------------------------------------- 73 | import Data.Functor.Product (Product (Pair)) 74 | 75 | 76 | #endif 77 | ------------------------------------------------------------------------------ 78 | -- | The 'MonadFork' type class, for monads which support a 'fork' operation. 79 | -- 80 | -- An example of a monad which would permit a 'MonadFork' instance that is not 81 | -- simply a lifted form of 'forkIO' is the 82 | -- @@ 83 | -- monad from the H(resourcet) package, which defines an operation 84 | -- @@. 85 | -- 86 | -- Minimal complete definition: 'fork', 'forkOn'. 87 | class MonadMask m => MonadFork m where 88 | -- | Sparks off a new thread to run the computation passed as the first 89 | -- argument, and returns the 'Control.Concurrent.ThreadId' of the newly 90 | -- created thread. 91 | -- 92 | -- The new thread will be a lightweight thread; if you want to use a 93 | -- foreign library that uses thread-local storage, use 94 | -- 'Control.Concurrent.forkOS' instead. (Note that 95 | -- 'Control.Concurrent.forkOS' is not included in the 'MonadFork' 96 | -- G(monadinterface,interface). To use 'Control.Concurrent.forkOS' in a 97 | -- G(monadtransformerstack,monad transformer stack) you'll want to use 98 | -- @'Control.Monad.Lift.IO.liftDiscardIO' 'Control.Concurrent.forkOS'@ 99 | -- instead.) 100 | -- 101 | -- GHC note: the new thread inherits the masked state of the parent (see 102 | -- 'Monad.Mask.mask'). 103 | -- 104 | -- The newly created thread has an exception handler that discards the 105 | -- exceptions 'Control.Exception.BlockedIndefinitelyOnMVar', 106 | -- 'Control.Exception.BlockedIndefinitelyOnSTM', and 107 | -- 'Control.Exception.ThreadKilled', and passes all other exceptions to 108 | -- the uncaught exception handler. 109 | fork :: m () -> m ThreadId 110 | 111 | -- | Like 'fork', but lets you specify on which processor the thread 112 | -- should run. Unlike a 'fork' thread, a thread created by 'forkOn' will 113 | -- stay on the same processor for its entire lifetime ('fork' threads can 114 | -- migrate between processors according to the scheduling policy). 115 | -- 'forkOn' is useful for overriding the scheduling policy when you know 116 | -- in advance how best to distribute the threads. 117 | -- 118 | -- The 'Int' argument specifies a capability number (see 119 | -- 'Control.Concurrent.getNumCapabilities'). Typically capabilities 120 | -- correspond to physical processors, but the exact behaviour is 121 | -- implementation-dependent. The value passed to 'forkOn' is interpreted 122 | -- modulo the total number of capabilities as returned by 123 | -- 'Control.Concurrent.getNumCapabilities'. 124 | -- 125 | -- GHC note: the number of capabilities is specified by the @+RTS -N@ 126 | -- option when the program is started. Capabilities can be fixed to actual 127 | -- processor cores with @+RTS -qa@ if the underlying operating system 128 | -- supports that, although in practice this is usually unnecessary (and 129 | -- may actually degrade perforamnce in some cases - experimentation is 130 | -- recommended). 131 | forkOn :: Int -> m () -> m ThreadId 132 | 133 | #ifdef MinimalPragma 134 | {-# MINIMAL fork, forkOn #-} 135 | 136 | #endif 137 | 138 | ------------------------------------------------------------------------------ 139 | instance MonadFork IO where 140 | fork = forkIO 141 | #if MIN_VERSION_base(4, 4, 0) 142 | forkOn = Control.Concurrent.forkOn 143 | #else 144 | forkOn _ = forkIO 145 | #endif 146 | 147 | 148 | #if MIN_VERSION_transformers(0, 3, 0) 149 | ------------------------------------------------------------------------------ 150 | instance (MonadFork f, MonadFork g) => MonadFork (Product f g) where 151 | fork (Pair f g) = Pair (fork f) (fork g) 152 | forkOn n (Pair f g) = Pair (forkOn n f) (forkOn n g) 153 | 154 | 155 | #endif 156 | #if MIN_VERSION_mmorph(1, 0, 1) 157 | ------------------------------------------------------------------------------ 158 | instance MonadFork (f (g m)) => MonadFork (ComposeT f g m) where 159 | fork (ComposeT m) = ComposeT (fork m) 160 | forkOn n (ComposeT m) = ComposeT (forkOn n m) 161 | 162 | 163 | #endif 164 | ------------------------------------------------------------------------------ 165 | instance __OVERLAPPABLE__ (MonadTransControl t, MonadFork m, MonadMask (t m)) 166 | => 167 | MonadFork (t m) 168 | where 169 | fork = liftDiscard fork 170 | {-# INLINABLE fork #-} 171 | forkOn = liftDiscard . forkOn 172 | {-# INLINABLE forkOn #-} 173 | 174 | 175 | ------------------------------------------------------------------------------ 176 | -- | Like 'fork', but the child thread is passed a function that can be used 177 | -- to unmask asynchronous exceptions. This function is typically used in the 178 | -- following way 179 | -- 180 | -- @... 'Monad.Mask.mask_' '$' 'forkWithUnmask' '$' \\unmask -> 181 | -- 'Monad.Catch.catch' (unmask ...) handler@ 182 | -- 183 | -- so that the exception handler in the child thread is established with 184 | -- asynchronous exceptions masked, meanwhile the main body of the child thread 185 | -- is executed in the unmasked state. 186 | -- 187 | -- Note that the @unmask@ function passed to the child thread should only be 188 | -- used in that thread; the behaviour is undefined if it is invoked in a 189 | -- different thread. 190 | forkWithUnmask :: MonadFork m 191 | => ((forall a n. MonadMask n => n a -> n a) -> m ()) 192 | -> m ThreadId 193 | forkWithUnmask m = fork $ m (setMaskingState Unmasked) 194 | {-# INLINABLE forkWithUnmask #-} 195 | 196 | 197 | ------------------------------------------------------------------------------ 198 | -- | Like 'forkWithUnmask', but the child thread is pinned to the given CPU, 199 | -- as with 'forkOn'. 200 | forkOnWithUnmask :: MonadFork m 201 | => Int 202 | -> ((forall a n. MonadMask n => n a -> n a) -> m ()) 203 | -> m ThreadId 204 | forkOnWithUnmask c m = forkOn c $ m (setMaskingState Unmasked) 205 | {-# INLINABLE forkOnWithUnmask #-} 206 | 207 | 208 | ------------------------------------------------------------------------------ 209 | -- | @fork@ a thread and call the supplied function when the thread is about 210 | -- to terminate, with an exception or a returned value. The function is called 211 | -- with asynchronous exceptions masked. 212 | -- 213 | -- @'forkFinally' action and_then = 214 | -- 'mask' '$' \\restore -> 215 | -- 'fork' '$' 'mtry' (restore action) '>>=' and_then@ 216 | -- 217 | -- This function is useful for informing the parent when a child terminates, 218 | -- for example. 219 | forkFinally :: (MonadTry m, MonadFork m) 220 | => m a 221 | -> (Either (m a) a -> m ()) 222 | -> m ThreadId 223 | forkFinally m sequel = mask $ \restore -> fork $ mtry (restore m) >>= sequel 224 | {-# INLINABLE forkFinally #-} 225 | -------------------------------------------------------------------------------- /src/Monad/Mask.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverlappingInstances #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | #if __GLASGOW_HASKELL__ >= 707 14 | {-# LANGUAGE ImpredicativeTypes #-} 15 | #endif 16 | 17 | #include "docmacros.h" 18 | #include "overlap.h" 19 | 20 | {-| 21 | 22 | This module defines the 'MonadMask' G(monadinterface,interface). It, along 23 | with its sister G(monadinterface,interface) 'Monad.Try.MonadTry', is designed 24 | to be largely compatible with the "Control.Exception" module from H(base). 25 | It consists of: 26 | 27 | * The 'MonadMask' constraint. 28 | * The 'mask' and 'mask_' operations. 29 | * The 'uninterruptibleMask' and 'uninterruptibleMask_' operations. 30 | * Instances of 'MonadMask': 31 | 32 | * For every G(basemonad,base monad) in the H(base) and H(transformers) 33 | packages: 34 | 35 | * 'Either' 36 | * @-@@>@ 37 | * 'Identity' 38 | * 'IO' 39 | * @[@@]@ 40 | * 'Maybe' 41 | * 'Proxy' 42 | * Lazy 'L.ST' 43 | * Strict 'ST' 44 | * 'STM' 45 | 46 | * G(universalpassthroughinstance,Pass-through instances) for: 47 | 48 | * Any G(innermonad,inner monad) with an existing 'MonadMask' 49 | instance wrapped by any G(monadlayer,monad layer) implementing 50 | 'Control.Monad.Lift.MonadTrans' and 'Control.Monad.Lift.MInvariant'. 51 | * The 'Product' of any two G(monadictype,monadic types) which both 52 | have existing 'MonadMask' instances. 53 | * The 54 | of two G(monadlayer,monad layers) wrapped around an 55 | G(innermonad,inner monad), where either the 56 | G(innermonad,inner monad) or one or more of the composed 57 | G(monadlayer,monad layers) has an existing instance for 'MonadMask'. 58 | 59 | * The 'MaskingState' datatype. 60 | * The 'getMaskingState' and 'setMaskingState' operations (but these are only 61 | for implementing 'mask' and 'uninterruptibleMask', not to be used directly). 62 | 63 | -} 64 | 65 | module Monad.Mask 66 | ( MonadMask (getMaskingState, setMaskingState) 67 | , MaskingState (Unmasked, MaskedInterruptible, MaskedUninterruptible) 68 | , mask 69 | , mask_ 70 | , uninterruptibleMask 71 | , uninterruptibleMask_ 72 | ) 73 | where 74 | 75 | -- base ---------------------------------------------------------------------- 76 | #if MIN_VERSION_base(4, 3, 0) 77 | import Control.Exception 78 | ( MaskingState 79 | ( Unmasked 80 | , MaskedInterruptible 81 | , MaskedUninterruptible 82 | ) 83 | ) 84 | import qualified Control.Exception as E (getMaskingState) 85 | #else 86 | import Control.Exception (block, unblock, blocked) 87 | #endif 88 | import Control.Monad.ST (ST) 89 | import qualified Control.Monad.ST.Lazy as L (ST) 90 | import Data.Functor.Identity (Identity) 91 | #if MIN_VERSION_base(4, 7, 0) 92 | import Data.Proxy (Proxy) 93 | #endif 94 | #if MIN_VERSION_base(4, 3, 0) 95 | import GHC.Base 96 | ( maskAsyncExceptions# 97 | , maskUninterruptible# 98 | , unmaskAsyncExceptions# 99 | ) 100 | import GHC.Conc.Sync (STM) 101 | import GHC.IO (IO (IO)) 102 | #else 103 | import GHC.Conc (STM) 104 | #endif 105 | 106 | 107 | -- layers -------------------------------------------------------------------- 108 | import Control.Monad.Lift (MonadTrans, lift, MInvariant, hoistiso) 109 | 110 | 111 | #if MIN_VERSION_mmorph(1, 0, 1) 112 | -- mmorph -------------------------------------------------------------------- 113 | import Control.Monad.Trans.Compose (ComposeT (ComposeT)) 114 | 115 | 116 | #endif 117 | #if MIN_VERSION_transformers(0, 3, 0) 118 | -- transformers -------------------------------------------------------------- 119 | import Data.Functor.Product (Product (Pair)) 120 | 121 | 122 | #endif 123 | ------------------------------------------------------------------------------ 124 | -- | The 'MonadMask' type class is for dealing with asynchronous exceptions. 125 | -- It contains the 'getMaskingState' and 'setMaskingState' operations for 126 | -- getting and setting the 'MaskingState' of the current thread. However, you 127 | -- should never need to use these operations: in particular, using 128 | -- 'setMaskingState' can violate some invariants which are assumed internally 129 | -- by this library. The only reason these functions are exposed at all is that 130 | -- they are necessary to implement 'mask' (which is what you should use 131 | -- instead), and unlike 'mask', their simpler type signature allows us to 132 | -- define a G(universalpassthroughinstance,universal pass-through instance) 133 | -- of 'MonadMask' through any G(monadlayer,monad layer) implementing 134 | -- 'Control.Monad.Lift.MonadTrans' and 'Control.Monad.Lift.MInvariant' (which 135 | -- in practice should be every monad layer), while 'mask' could only be lifted 136 | -- through G(monadlayer,monad layers) which implement 137 | -- 'Control.Monad.Lift.MonadTransControl'. 138 | -- 139 | -- /Every/ monad should be an instance of 'MonadMask', and we have provided 140 | -- instances for every G(basemonad,base monad) in the H(base) and 141 | -- H(transformers) packages. 'getMaskingState' and 'setMaskingState' have 142 | -- default definitions that only need to be overridden in the case of 'IO' and 143 | -- monads layered on top of 'IO' (which we have already done), so it costs 144 | -- nothing to add an instance of 'MonadMask' to a monad. ('MonadMask' is a 145 | -- prerequisite for implementing 'Monad.Try.MonadTry', which provides the 146 | -- 'Monad.Try.bracket' family of functions, which is perhaps more interesting 147 | -- than 'MonadMask' on its own.) 148 | -- 149 | -- Minimal complete definition: instance head only. 150 | class Monad m => MonadMask m where 151 | -- | Returns the 'MaskingState' for the current thread. 152 | getMaskingState :: m MaskingState 153 | 154 | -- | Sets the 'MaskingState' for the current thread to the given value. 155 | setMaskingState :: MaskingState -> m a -> m a 156 | 157 | getMaskingState = return MaskedInterruptible 158 | setMaskingState = const id 159 | 160 | #ifdef MinimalPragma 161 | {-# MINIMAL #-} 162 | 163 | #endif 164 | 165 | #if !MIN_VERSION_base(4, 3, 0) 166 | ------------------------------------------------------------------------------ 167 | -- | Describes the behaviour of a thread when an asynchronous exception is 168 | -- received. 169 | data MaskingState 170 | = Unmasked 171 | -- ^ asynchronous exceptions are unmasked (the normal state) 172 | | MaskedInterruptible 173 | -- ^ the state during 'mask': asynchronous exceptions are masked, but 174 | -- blocking operations may still be interrupted 175 | | MaskedUninterruptible 176 | -- ^ the state during 'uninterruptibleMask': asynchronous exceptions 177 | -- are masked, and blocking operations may not be interrupted 178 | deriving (Eq, Show) 179 | #endif 180 | 181 | 182 | ------------------------------------------------------------------------------ 183 | instance MonadMask Identity 184 | 185 | 186 | #if MIN_VERSION_transformers(0, 3, 0) 187 | ------------------------------------------------------------------------------ 188 | instance (MonadMask f, MonadMask g) => MonadMask (Product f g) where 189 | getMaskingState = Pair getMaskingState getMaskingState 190 | setMaskingState s (Pair f g) 191 | = Pair (setMaskingState s f) (setMaskingState s g) 192 | 193 | 194 | #endif 195 | #if MIN_VERSION_mmorph(1, 0, 1) 196 | ------------------------------------------------------------------------------ 197 | instance MonadMask (f (g m)) => MonadMask (ComposeT f g m) where 198 | getMaskingState = ComposeT getMaskingState 199 | setMaskingState s (ComposeT m) = ComposeT (setMaskingState s m) 200 | 201 | 202 | #endif 203 | ------------------------------------------------------------------------------ 204 | instance MonadMask Maybe 205 | 206 | 207 | ------------------------------------------------------------------------------ 208 | instance MonadMask (Either e) 209 | 210 | 211 | ------------------------------------------------------------------------------ 212 | instance MonadMask [] 213 | 214 | 215 | ------------------------------------------------------------------------------ 216 | instance MonadMask ((->) r) 217 | 218 | 219 | ------------------------------------------------------------------------------ 220 | instance MonadMask (ST s) 221 | 222 | 223 | ------------------------------------------------------------------------------ 224 | instance MonadMask (L.ST s) 225 | 226 | 227 | ------------------------------------------------------------------------------ 228 | instance MonadMask STM 229 | 230 | 231 | #if MIN_VERSION_base(4, 7, 0) 232 | ------------------------------------------------------------------------------ 233 | instance MonadMask Proxy 234 | 235 | 236 | #endif 237 | ------------------------------------------------------------------------------ 238 | instance MonadMask IO where 239 | #if MIN_VERSION_base(4, 3, 0) 240 | getMaskingState = E.getMaskingState 241 | setMaskingState Unmasked (IO i) = IO $ unmaskAsyncExceptions# i 242 | setMaskingState MaskedInterruptible (IO i) = IO $ maskAsyncExceptions# i 243 | setMaskingState MaskedUninterruptible (IO i) = IO $ maskUninterruptible# i 244 | #else 245 | getMaskingState = fmap (\b -> if b then MaskedInterruptible else Unmasked) 246 | blocked 247 | setMaskingState Unmasked = unblock 248 | setMaskingState MaskedInterruptible = block 249 | setMaskingState MaskedUninterruptible = block 250 | #endif 251 | 252 | 253 | ------------------------------------------------------------------------------ 254 | instance __OVERLAPPABLE__ 255 | (MonadTrans t, MInvariant t, MonadMask m, Monad (t m)) 256 | => 257 | MonadMask (t m) 258 | where 259 | getMaskingState = lift getMaskingState 260 | {-# INLINABLE getMaskingState #-} 261 | setMaskingState s m = lift getMaskingState >>= \s' -> 262 | hoistiso (setMaskingState s) (setMaskingState s') m 263 | {-# INLINABLE setMaskingState #-} 264 | 265 | 266 | ------------------------------------------------------------------------------ 267 | -- | Executes a computation with asynchronous exceptions /masked/. That is, 268 | -- any thread which attempts to raise an exception in the current thread with 269 | -- 'Control.Exception.throwTo' will be blocked until asynchronous exceptions 270 | -- are unmasked again. 271 | -- 272 | -- The argument passed to 'mask' is a function that takes as its argument 273 | -- another function, which can be used to restore the prevailing masking state 274 | -- within the context of the masked computation. For example, a common way to 275 | -- use 'mask' is to protect the acquisition of a resource: 276 | -- 277 | -- @'mask' $ \\restore -> do 278 | -- x <- acquire 279 | -- restore (do_something_with x) \``Monad.Try.finally`\` release@ 280 | -- 281 | -- This code guarantees that @acquire@ is paired with @release@, by masking 282 | -- asynchronous exceptions for the critical parts. (Rather than write this 283 | -- code yourself, it would be better to use 'Monad.Try.bracket' which 284 | -- abstracts the general pattern). 285 | -- 286 | -- Note that the @restore@ action passed to the argument to 'mask' does not 287 | -- necessarily unmask asynchronous exceptions, it just restores the masking 288 | -- state to that of the enclosing context. Thus if asynchronous exceptions are 289 | -- already masked, 'mask' cannot be used to unmask exceptions again. This is 290 | -- so that if you call a library function with exceptions masked, you can be 291 | -- sure that the library call will not be able to unmask exceptions again. If 292 | -- you are writing library code and need to use asynchronous exceptions, the 293 | -- only way is to create a new thread; see 294 | -- 'Monad.Fork.forkWithUnmask'. 295 | -- 296 | -- Asynchronous exceptions may still be received while in the masked state if 297 | -- the masked thread /blocks/ in certain ways; see 298 | -- . 299 | -- 300 | -- Threads created by 'Monad.Fork.fork' inherit the masked 301 | -- state from the parent; that is, to start a thread in blocked mode, use 302 | -- @'mask_' $ 'Monad.Fork.fork' ...@. This is particularly useful if you need 303 | -- to establish an exception handler in the forked thread before any 304 | -- asynchronous exceptions are received. 305 | mask :: MonadMask m => ((forall a n. MonadMask n => n a -> n a) -> m b) -> m b 306 | mask f = getMaskingState >>= \s -> case s of 307 | Unmasked -> setMaskingState MaskedInterruptible (f (setMaskingState s)) 308 | _ -> f id 309 | {-# INLINABLE mask #-} 310 | 311 | 312 | ------------------------------------------------------------------------------ 313 | -- | Like 'mask', but does not pass a @restore@ action to the argument. 314 | mask_ :: MonadMask m => m a -> m a 315 | mask_ = mask . const 316 | {-# INLINABLE mask_ #-} 317 | 318 | 319 | ------------------------------------------------------------------------------ 320 | -- | Like 'mask', but the masked computation is not interruptible (see 321 | -- ). 322 | -- __This should be used with great care__, because if a thread executing in 323 | -- 'uninterruptibleMask' blocks for any reason, then the thread (and possibly 324 | -- the program, if this is the main thread) will be unresponsive and 325 | -- unkillable. This function should only be necessary if you need to mask 326 | -- exceptions around an interruptible operation, and you can guarantee that 327 | -- the interruptible operation will only block for a short period of time. 328 | uninterruptibleMask :: MonadMask m 329 | => ((forall a n. MonadMask n => n a -> n a) -> m b) 330 | -> m b 331 | uninterruptibleMask f = getMaskingState >>= \s -> case s of 332 | MaskedUninterruptible -> f id 333 | _ -> setMaskingState MaskedUninterruptible (f (setMaskingState s)) 334 | {-# INLINABLE uninterruptibleMask #-} 335 | 336 | 337 | ------------------------------------------------------------------------------ 338 | -- | Like 'uninterruptibleMask', but does not pass a @restore@ action to the 339 | -- argument. 340 | uninterruptibleMask_ :: MonadMask m => m a -> m a 341 | uninterruptibleMask_ = uninterruptibleMask . const 342 | {-# INLINABLE uninterruptibleMask_ #-} 343 | -------------------------------------------------------------------------------- /src/Monad/RWS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | #ifdef LANGUAGE_SafeHaskell 8 | {-# LANGUAGE Safe #-} 9 | #endif 10 | 11 | #include "docmacros.h" 12 | #include "newtypec.h" 13 | #include "overlap.h" 14 | 15 | {-| 16 | 17 | This module defines the 'MonadRWS' G(monadinterface,interface), which consists 18 | of: 19 | 20 | * The 'MonadRWS' constraint. 21 | * The "Monad.Reader" module. 22 | * The "Monad.State" module. 23 | * The "Monad.Writer" module. 24 | 25 | The 'MonadRWS' G(monadinterface,interface) is provided for compatibility with 26 | the T(mtl,Control-Monad-RWS-Class,MonadRWS) G(monadinterface,interface) from 27 | the H(mtl) library. 28 | 29 | -} 30 | 31 | module Monad.RWS 32 | ( MonadRWS 33 | , module Monad.Reader 34 | , module Monad.State 35 | , module Monad.Writer 36 | ) 37 | where 38 | 39 | -- layers -------------------------------------------------------------------- 40 | import Monad.Reader 41 | ( MonadReader (reader, ask, local), asks 42 | ) 43 | import Monad.State 44 | ( MonadState (state, get, put), modify, gets 45 | ) 46 | import Monad.Writer 47 | ( MonadWriter (writer, tell, listen, pass) 48 | , listens, censor 49 | ) 50 | 51 | 52 | ------------------------------------------------------------------------------ 53 | -- | 'MonadRWS' is simply a 54 | -- UG(glasgow_exts.html#the-constraint-kind,constraint synonym) for the 55 | -- combination of 'MonadReader', 'MonadState' and 'MonadWriter'. 56 | newtypeC(MonadRWS r w s m, (MonadReader r m, MonadWriter w m, MonadState s m)) 57 | -------------------------------------------------------------------------------- /src/Monad/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverlappingInstances #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | #ifdef LANGUAGE_SafeHaskell 11 | #if __GLASGOW_HASKELL__ >= 704 12 | {-# LANGUAGE Safe #-} 13 | #else 14 | {-# LANGUAGE Trustworthy #-} 15 | #endif 16 | #endif 17 | 18 | #include "docmacros.h" 19 | #include "overlap.h" 20 | 21 | {-| 22 | 23 | This module defines the 'MonadReader' G(monadinterface,interface). It is 24 | designed to be compatible with the with the 25 | T(mtl,Control-Monad-Reader-Class,MonadReader) interface from the H(mtl) 26 | package. It consists of: 27 | 28 | * The 'MonadReader' constraint. 29 | * The 'ask' and 'local' operations. 30 | 31 | * Instances of 'MonadReader': 32 | 33 | * For the base monad @-@@>@. 34 | 35 | * For arbitrary G(innermonad,inner monads) wrapped by one of the 36 | following G(monadlayer,monad layers): 37 | 38 | * 'ReaderT' 39 | * Lazy 'L.RWST' 40 | * Strict 'RWST' 41 | 42 | * G(universalpassthroughinstance,Pass-through instances) for: 43 | 44 | * Any G(innermonad,inner monad) with an existing 'MonadReader' 45 | instance wrapped by any G(monadlayer,monad layer) implementing 46 | 'Control.Monad.Lift.MonadTrans' and 'Control.Monad.Lift.MInvariant'. 47 | * The 'Product' of any two G(monadictype,monadic types) which both 48 | have existing 'MonadReader' instances. 49 | * The 50 | of two G(monadlayer,monad layers) wrapped around an 51 | G(innermonad,inner monad), where either the 52 | G(innermonad,inner monad) or one or more of the composed 53 | G(monadlayer,monad layers) has an existing instance for 54 | 'MonadReader'. 55 | 56 | * The 'asks' and 'reader' utility operations. 57 | 58 | -} 59 | 60 | module Monad.Reader 61 | ( MonadReader (reader, ask, local) 62 | , asks 63 | ) 64 | where 65 | 66 | -- base ---------------------------------------------------------------------- 67 | import Control.Monad (liftM) 68 | #if !MIN_VERSION_base(4, 8, 0) 69 | import Data.Monoid (Monoid (mempty)) 70 | #endif 71 | 72 | 73 | -- layers -------------------------------------------------------------------- 74 | import Control.Monad.Lift (MonadTrans, lift, MInvariant, hoistiso) 75 | 76 | 77 | #if MIN_VERSION_mmorph(1, 0, 1) 78 | -- mmorph -------------------------------------------------------------------- 79 | import Control.Monad.Trans.Compose (ComposeT (ComposeT)) 80 | 81 | 82 | #endif 83 | -- transformers -------------------------------------------------------------- 84 | import Control.Monad.Trans.Reader (ReaderT (ReaderT)) 85 | import qualified Control.Monad.Trans.RWS.Lazy as L (RWST (RWST)) 86 | import Control.Monad.Trans.RWS.Strict (RWST (RWST)) 87 | #if MIN_VERSION_transformers(0, 3, 0) 88 | import Data.Functor.Product (Product (Pair)) 89 | #endif 90 | 91 | 92 | ------------------------------------------------------------------------------ 93 | -- | The 'MonadReader' G(monadinterface,interface) represents 94 | -- G(computation,computations) which can read values from a shared 95 | -- environment, pass values from function to function and execute 96 | -- G(computation,sub-computations) in a modified environment. Using the 97 | -- 'MonadReader' G(monadinterface,interface) for such 98 | -- G(computation,computations) is often clearer and easier 99 | -- than using the 'Monad.State.MonadState' G(monadinterface,interface). 100 | -- 101 | -- Minimal complete definition: 'local' and one of either 'reader' or 'ask'. 102 | class Monad m => MonadReader r m | m -> r where 103 | -- | Embed a simple reader G(computation,action) into the monad. 104 | reader :: (r -> a) -> m a 105 | 106 | -- | Retrieves the monad environment. 107 | ask :: m r 108 | 109 | -- | Executes a G(computation,computation) in a modified environment. 110 | local :: (r -> r) -> m a -> m a 111 | 112 | reader f = liftM f ask 113 | {-# INLINABLE reader #-} 114 | 115 | ask = reader id 116 | {-# INLINABLE ask #-} 117 | 118 | #ifdef MinimalPragma 119 | {-# MINIMAL local, (reader | ask) #-} 120 | 121 | #endif 122 | 123 | ------------------------------------------------------------------------------ 124 | instance MonadReader r ((->) r) where 125 | reader = ($) 126 | ask = id 127 | local = flip (.) 128 | 129 | 130 | ------------------------------------------------------------------------------ 131 | instance Monad m => MonadReader r (ReaderT r m) where 132 | reader = ReaderT . (return .) 133 | ask = ReaderT return 134 | local f (ReaderT m) = ReaderT $ m . f 135 | 136 | 137 | ------------------------------------------------------------------------------ 138 | instance (Monad m, Monoid w) => MonadReader r (L.RWST r w s m) where 139 | reader f = L.RWST $ \r s -> return (f r, s, mempty) 140 | ask = L.RWST $ \r s -> return (r, s, mempty) 141 | local f (L.RWST m) = L.RWST $ \r s -> m (f r) s 142 | 143 | 144 | ------------------------------------------------------------------------------ 145 | instance (Monad m, Monoid w) => MonadReader r (RWST r w s m) where 146 | reader f = RWST $ \r s -> return (f r, s, mempty) 147 | ask = RWST $ \r s -> return (r, s, mempty) 148 | local f (RWST m) = RWST $ \r s -> m (f r) s 149 | 150 | 151 | #if MIN_VERSION_transformers(0, 3, 0) 152 | ------------------------------------------------------------------------------ 153 | instance (MonadReader r f, MonadReader r g) => 154 | MonadReader r (Product f g) 155 | where 156 | reader f = Pair (reader f) (reader f) 157 | ask = Pair ask ask 158 | local t (Pair f g) = Pair (local t f) (local t g) 159 | 160 | 161 | #endif 162 | #if MIN_VERSION_mmorph(1, 0, 1) 163 | ------------------------------------------------------------------------------ 164 | instance MonadReader r (f (g m)) => MonadReader r (ComposeT f g m) where 165 | reader f = ComposeT (reader f) 166 | ask = ComposeT ask 167 | local t (ComposeT m) = ComposeT (local t m) 168 | 169 | 170 | #endif 171 | ------------------------------------------------------------------------------ 172 | instance __OVERLAPPABLE__ 173 | (MonadTrans t, MInvariant t, MonadReader r m, Monad (t m)) 174 | => 175 | MonadReader r (t m) 176 | where 177 | reader = lift . reader 178 | {-# INLINABLE reader #-} 179 | ask = lift ask 180 | {-# INLINABLE ask #-} 181 | local f m = lift ask >>= \r -> hoistiso (local f) (local (const r)) m 182 | {-# INLINABLE local #-} 183 | 184 | 185 | ------------------------------------------------------------------------------ 186 | -- | Retrieves a function of the current environment. 187 | asks :: MonadReader r m => (r -> a) -> m a 188 | asks = reader 189 | -------------------------------------------------------------------------------- /src/Monad/Recover.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverlappingInstances #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 11 | 12 | #include "docmacros.h" 13 | #include "newtypec.h" 14 | #include "overlap.h" 15 | 16 | {-| 17 | 18 | This module defines the 'MonadRecover' G(monadinterface,interface). It, along 19 | with its sister G(monadinterface,interface) 'MonadAbort', is inspired by the 20 | 21 | from the 22 | module 23 | of the H(monad-abort-fd) package. It consists of: 24 | 25 | * The 'MonadRecover' constraint. 26 | * The 'recover' operation. 27 | * Instances of 'MonadRecover': 28 | 29 | * For the following G(basemonad,base monads): 30 | 31 | * 'Either' 32 | * @[@@]@ 33 | * 'Maybe' 34 | * 'IO' 35 | * 'STM' 36 | 37 | * For arbitrary G(innermonad,inner monads) wrapped by one of the 38 | following G(monadlayer,monad layers): 39 | 40 | * 'ErrorT' 41 | * 'ExceptT' 42 | * 'ListT' 43 | * 'MaybeT' 44 | 45 | * G(universalpassthroughinstance,Pass-through instances) for: 46 | 47 | * Any G(innermonad,inner monad) with an existing 'MonadRecover' 48 | instance wrapped by any G(monadlayer,monad layer) implementing 49 | 'Control.Monad.Lift.MonadTransControl'. 50 | * The 'Product' of any two G(monadictype,monadic types) which both 51 | have existing 'MonadRecover' instances. 52 | * The 53 | of two G(monadlayer,monad layers) wrapped around an 54 | G(innermonad,inner monad), where either the 55 | G(innermonad,inner monad) or one or more of the composed 56 | G(monadlayer,monad layers) has an existing instance for 57 | 'MonadRecover'. 58 | 59 | * The following alternate versions of 'recover', analogous to the 'catch' 60 | family of operations (as defined in "Monad.Catch" and "Control.Exception", 61 | modulo the marshalling of 'Control.Exception.Exception's to and from 62 | 'Control.Exception.SomeException'): 63 | 64 | * 'recoverJust' 65 | * 'handle' 66 | * 'handleJust' 67 | * 'try' 68 | * 'tryJust' 69 | 70 | * The \"bracket\" family of operations (as defined in "Monad.Try" and 71 | "Control.Exception"). Unlike the \"bracket\" operations in "Monad.Try", 72 | which can recover from a G(shortcircuit,short-circuit) in any 73 | G(monadlayer,monad layer) anywhere in the G(monadtransformerstack,stack), 74 | these \"bracket\" operations can only recover from an 'abort' in the 75 | G(outerlayers,outermost) G(monadlayer,layer) that implements 'MonadRecover'. 76 | 77 | * 'bracket' 78 | * 'bracket_' 79 | * 'bracketOnError' 80 | * 'finally' 81 | * 'onException' 82 | * 'orElse' (actually from the H(stm) package) 83 | 84 | The 'Monad.Catch.MonadCatch' and 'Monad.Error.MonadError' 85 | G(monadinterface,interfaces) are both built on top of 'MonadRecover'. 86 | 87 | -} 88 | 89 | module Monad.Recover 90 | ( MonadRecover (recover) 91 | 92 | -- * \"catch\" operations 93 | , recoverJust, handle, handleJust, try, tryJust 94 | 95 | -- * \"bracket\" operations 96 | , bracket, bracket_, bracketOnError, finally, onException, orElse 97 | ) 98 | where 99 | 100 | -- base ---------------------------------------------------------------------- 101 | import Control.Exception (SomeException, catch) 102 | import Control.Monad (liftM, mplus) 103 | #if MIN_VERSION_base(4, 3, 0) 104 | import GHC.Conc.Sync (STM, catchSTM) 105 | #else 106 | import GHC.Conc (STM, catchSTM) 107 | #endif 108 | #if !MIN_VERSION_base(4, 6, 0) 109 | import Prelude hiding (catch) 110 | #endif 111 | 112 | 113 | -- layers -------------------------------------------------------------------- 114 | import Control.Monad.Lift (MonadTransControl, control) 115 | import Monad.Abort (MonadAbort, abort) 116 | 117 | 118 | #if MIN_VERSION_mmorph(1, 0, 1) 119 | -- mmorph -------------------------------------------------------------------- 120 | import Control.Monad.Trans.Compose (ComposeT (ComposeT)) 121 | 122 | 123 | #endif 124 | -- transformers -------------------------------------------------------------- 125 | #if !MIN_VERSION_transformers(0, 6, 0) 126 | import Control.Monad.Trans.Error (ErrorT (ErrorT), Error) 127 | #endif 128 | #if MIN_VERSION_transformers(0, 4, 0) 129 | import Control.Monad.Trans.Except (ExceptT (ExceptT)) 130 | #endif 131 | import Control.Monad.Trans.Maybe (MaybeT) 132 | import Control.Monad.Trans.List (ListT) 133 | #if MIN_VERSION_transformers(0, 3, 0) 134 | import Data.Functor.Product (Product (Pair)) 135 | #endif 136 | 137 | 138 | ------------------------------------------------------------------------------ 139 | -- | The @'MonadRecover' e@ constraint matches monads whose 140 | -- G(computation,computations) can 'recover' from a failure caused by a call 141 | -- to 'Monad.Abort.abort'. 142 | -- 143 | -- Every monad which permits an instance 'Control.Monad.MonadPlus' (of the 144 | -- variety) trivially permits an instance of 145 | -- 'MonadRecover': for these instances, the @e@ parameter is fixed to @()@, as 146 | -- there is no @e@ value which can be recovered from a 147 | -- \"G(shortcircuit,zero)\". 148 | -- 149 | -- The other class of monads that permit a 'MonadRecover' instance are the 150 | -- 'Either'-like monads (including 'IO'): these monads actually store the @e@ 151 | -- parameter passed to the 'abort' operation on failure, hence it can later be 152 | -- retrieved using the 'recover' operation. 153 | -- 154 | -- Minimal complete definition: 'recover'. 155 | class MonadAbort e m => MonadRecover e m | m -> e where 156 | -- | In addition to the 'MonadAbort' \"G(shortcircuit,zero)\" law, the 157 | -- following laws hold for valid instances of 'MonadRecover': 158 | -- 159 | -- [Left Identity] @'recover' ('Monad.Abort.abort' e) (\\_ -> m) ≡ m@ 160 | -- [Right Identity] @'recover' m 'Monad.Abort.abort' ≡ m@ 161 | -- [Associativity] @'recover' m (\\_ -> 'recover' n (\\_ -> o)) ≡ 'recover' ('recover' m (\\_ -> n)) (\\_ -> o)@ 162 | -- [Left Catch] @'recover' ('return' a) _ ≡ 'return' a@ 163 | -- [Recoverability] @'recover' ('Monad.Abort.abort' e) 'return' ≡ 'return' e@ 164 | recover :: m a -> (e -> m a) -> m a 165 | 166 | #ifdef MinimalPragma 167 | {-# MINIMAL recover #-} 168 | 169 | #endif 170 | 171 | ------------------------------------------------------------------------------ 172 | instance MonadRecover e (Either e) where 173 | recover m h = either h Right m 174 | 175 | 176 | ------------------------------------------------------------------------------ 177 | instance MonadRecover () ([]) where 178 | recover m h = mplus m (h ()) 179 | 180 | 181 | ------------------------------------------------------------------------------ 182 | instance MonadRecover () Maybe where 183 | recover m h = mplus m (h ()) 184 | 185 | 186 | ------------------------------------------------------------------------------ 187 | instance MonadRecover SomeException IO where 188 | recover = catch 189 | 190 | 191 | ------------------------------------------------------------------------------ 192 | instance MonadRecover SomeException STM where 193 | recover = catchSTM 194 | 195 | 196 | #if !MIN_VERSION_transformers(0, 6, 0) 197 | ------------------------------------------------------------------------------ 198 | instance (Error e, Monad m) => MonadRecover e (ErrorT e m) where 199 | recover (ErrorT m) h = ErrorT $ m >>= either 200 | (\e -> let ErrorT m' = h e in m') 201 | (return . Right) 202 | {-# INLINABLE recover #-} 203 | 204 | 205 | #endif 206 | #if MIN_VERSION_transformers(0, 4, 0) 207 | ------------------------------------------------------------------------------ 208 | instance Monad m => MonadRecover e (ExceptT e m) where 209 | recover (ExceptT m) h = ExceptT $ m >>= either 210 | (\e -> let ExceptT m' = h e in m') 211 | (return . Right) 212 | {-# INLINABLE recover #-} 213 | 214 | 215 | #endif 216 | ------------------------------------------------------------------------------ 217 | instance Monad m => MonadRecover () (ListT m) where 218 | recover m h = mplus m (h ()) 219 | 220 | 221 | ------------------------------------------------------------------------------ 222 | instance Monad m => MonadRecover () (MaybeT m) where 223 | recover m h = mplus m (h ()) 224 | 225 | 226 | #if MIN_VERSION_transformers(0, 3, 0) 227 | ------------------------------------------------------------------------------ 228 | instance (MonadRecover e f, MonadRecover e g) => MonadRecover e (Product f g) 229 | where 230 | recover (Pair f g) h = Pair 231 | (recover f (\e -> let Pair f' _ = h e in f')) 232 | (recover g (\e -> let Pair _ g' = h e in g')) 233 | 234 | 235 | #endif 236 | #if MIN_VERSION_mmorph(1, 0, 1) 237 | ------------------------------------------------------------------------------ 238 | instance MonadRecover e (f (g m)) => MonadRecover e (ComposeT f g m) where 239 | recover (ComposeT m) h = ComposeT 240 | (recover m (\e -> let ComposeT m' = h e in m')) 241 | 242 | 243 | #endif 244 | ------------------------------------------------------------------------------ 245 | instance __OVERLAPPABLE__ 246 | (MonadTransControl t, MonadRecover e m, MonadAbort e (t m)) 247 | => 248 | MonadRecover e (t m) 249 | where 250 | recover m h = control (\peel -> recover (peel m) (peel . h)) 251 | {-# INLINABLE recover #-} 252 | 253 | 254 | ------------------------------------------------------------------------------ 255 | -- | The function 'recoverJust' is like 'recover', but it takes an extra 256 | -- argument which is an /exception predicate/, a function which selects which 257 | -- type of exceptions we're interested in. It is analogous to 258 | -- 'Monad.Catch.catchJust' in "Monad.Catch" and "Control.Exception". 259 | -- 260 | -- Any other exceptions which are not matched by the predicate are re-raised, 261 | -- and may be caught by an enclosing 'recover', 'recoverJust', etc. 262 | recoverJust :: MonadRecover e m => (e -> Maybe b) -> m a -> (b -> m a) -> m a 263 | recoverJust p m handler = recover m (\e -> maybe (abort e) handler (p e)) 264 | {-# INLINABLE recoverJust #-} 265 | 266 | 267 | ------------------------------------------------------------------------------ 268 | -- | A version of 'recover' with the arguments swapped around; useful in 269 | -- situations where the code for the handler is shorter. 270 | handle :: MonadRecover e m => (e -> m a) -> m a -> m a 271 | handle = flip recover 272 | {-# INLINABLE handle #-} 273 | 274 | 275 | ------------------------------------------------------------------------------ 276 | -- | A version of 'recoverJust' with the arguments swapped around (see 277 | -- 'handle'). 278 | handleJust :: MonadRecover e m => (e -> Maybe b) -> (b -> m a) -> m a -> m a 279 | handleJust = flip . recoverJust 280 | {-# INLINABLE handleJust #-} 281 | 282 | 283 | ------------------------------------------------------------------------------ 284 | -- | Similar to 'recover', but returns an 'Either' result which is 285 | -- @('Left' e)@ if the given computation 'abort'ed, or @('Right' a)@ if 286 | -- completed normally. 287 | -- 288 | -- @'try' a = 'handle' ('return' '.' 'Left') '.' 'liftM' 'Right'@ 289 | try :: MonadRecover e m => m a -> m (Either e a) 290 | try = handle (return . Left) . liftM Right 291 | {-# INLINABLE try #-} 292 | 293 | 294 | ------------------------------------------------------------------------------ 295 | -- | A variant of 'try' that takes an exception predicate to select which 296 | -- exceptions are caught (c.f. 'recoverJust'). If the exception does not 297 | -- match the predicate, it is re-thrown. 298 | tryJust :: MonadRecover e m => (e -> Maybe b) -> m a -> m (Either b a) 299 | tryJust p = handleJust p (return . Left) . liftM Right 300 | {-# INLINABLE tryJust #-} 301 | 302 | 303 | ------------------------------------------------------------------------------ 304 | -- | This 'bracket' is analogous to the 'Monad.Try.bracket' in "Monad.Try" and 305 | -- "Control.Monad.Exception". 306 | -- 307 | -- Note: if you are trying to ensure that your release\/finalizer\/cleanup 308 | -- action is always run, you probably want to use the 'Monad.Try.bracket' from 309 | -- "Monad.Try" instead, which can recover from a G(shortcircuit,short-circuit) 310 | -- in any G(monadlayer,monad layer) anywhere in the 311 | -- G(monadtransformerstack,stack). This 'bracket' can only recover from an 312 | -- 'abort' in the G(outerlayers,outermost) G(monadlayer,layer) that implements 313 | -- 'MonadRecover'. 314 | bracket :: MonadRecover e m 315 | => m a -- ^ G(computation,computation) to run first (\"acquire resource\") 316 | -> (a -> m b) -- ^ G(computation,computation) to run last (\"release resource\") 317 | -> (a -> m c) -- ^ G(computation,computation) to run in-between 318 | -> m c -- ^ returns the value from the in-between G(computation,computation) 319 | bracket acquire release run = do 320 | a <- acquire 321 | run a `finally` release a 322 | {-# INLINABLE bracket #-} 323 | 324 | 325 | ------------------------------------------------------------------------------ 326 | -- | A variant of 'bracket' where the return value from the first 327 | -- G(computation,computation) is not required. 328 | bracket_ :: MonadRecover e m => m a -> m b -> m c -> m c 329 | bracket_ acquire release run = bracket acquire (const release) (const run) 330 | {-# INLINABLE bracket_ #-} 331 | 332 | 333 | ------------------------------------------------------------------------------ 334 | -- | Like 'bracket', but only performs the final G(computation,action) if the 335 | -- in-between G(computation,computation) G(shortcircuit,short-circuited). 336 | bracketOnError :: MonadRecover e m => m a -> (a -> m b) -> (a -> m c) -> m c 337 | bracketOnError acquire release run = do 338 | a <- acquire 339 | run a `onException` release a 340 | {-# INLINABLE bracketOnError #-} 341 | 342 | 343 | ------------------------------------------------------------------------------ 344 | -- | A specialised variant of 'bracket' with just a G(computation,computation) 345 | -- to run afterward. 346 | finally :: MonadRecover e m => m a -> m b -> m a 347 | finally m sequel = do 348 | r <- m `onException` sequel 349 | _ <- sequel 350 | return r 351 | {-# INLINABLE finally #-} 352 | 353 | 354 | ------------------------------------------------------------------------------ 355 | -- | Like 'finally', but only performs the final G(computation,action) if 356 | -- the G(computation,computation) G(shortcircuit,short-circuited). 357 | onException :: MonadRecover e m => m a -> m b -> m a 358 | onException m sequel = recover m (\e -> sequel >> abort e) 359 | {-# INLINABLE onException #-} 360 | 361 | 362 | ------------------------------------------------------------------------------ 363 | -- | Tries the first G(computation,action), and if it G(shortcircuit,fails), 364 | -- tries the second G(computation,action). 365 | orElse :: MonadRecover e m => m a -> m a -> m a 366 | orElse a b = recover a (const b) 367 | {-# INLINABLE orElse #-} 368 | -------------------------------------------------------------------------------- /src/Monad/ST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverlappingInstances #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | #include "docmacros.h" 11 | #include "overlap.h" 12 | 13 | {-| 14 | 15 | This module provides the 'MonadST' G(monadinterface,interface). It is designed 16 | to generalise and be largely consistent with the interfaces provided by 17 | "Data.IORef", "Data.STRef.Lazy" and "Data.STRef.Strict". It consists of: 18 | 19 | * The 'MonadST' constraint. 20 | * The 'newRef' operation. 21 | * The 'readRef' and 'writeRef' operations. 22 | * The 'atomicModifyRef' operation. 23 | * Instances of 'MonadST': 24 | 25 | * For the G(basemonad,base monads): 26 | 27 | * 'IO' ('IORef') 28 | * Lazy 'L.ST' ('L.STRef') 29 | * Strict 'ST' ('STRef') 30 | * 'STM' ('TVar') 31 | 32 | * G(universalpassthroughinstance,Pass-through instances) for: 33 | 34 | * Any G(innermonad,inner monad) with an existing 'MonadST' 35 | instance wrapped by any G(monadlayer,monad layer) implementing 36 | 'Control.Monad.Lift.MonadTrans'. 37 | * The 'Product' of any two G(monadictype,monadic types) which both 38 | have existing 'MonadST' instances. 39 | * The 40 | of two G(monadlayer,monad layers) wrapped around an 41 | G(innermonad,inner monad), where either the 42 | G(innermonad,inner monad) or one or more of the composed 43 | G(monadlayer,monad layers) has an existing instance for 'MonadST'. 44 | 45 | * The utility operations 'modifyRef', 'modifyRef'', 'atomicModifyRef'' and 46 | 'atomicWriteRef' (as provided by "Data.IORef"). 47 | 48 | -} 49 | 50 | module Monad.ST 51 | ( MonadST (newRef, readRef, writeRef, atomicModifyRef) 52 | , atomicModifyRef', atomicWriteRef, modifyRef, modifyRef' 53 | ) 54 | where 55 | 56 | -- base --------------------------------------------------------------------- 57 | import Control.Monad.ST (ST) 58 | import qualified Control.Monad.ST.Lazy as L (ST) 59 | import Data.IORef 60 | ( IORef 61 | , newIORef, readIORef, writeIORef, atomicModifyIORef 62 | ) 63 | import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef) 64 | import qualified Data.STRef.Lazy as L (newSTRef, readSTRef, writeSTRef) 65 | #if MIN_VERSION_base(4, 3, 0) 66 | import GHC.Conc.Sync (STM, TVar, newTVar, readTVar, writeTVar) 67 | #else 68 | import GHC.Conc (STM, TVar, newTVar, readTVar, writeTVar) 69 | #endif 70 | 71 | 72 | -- layers -------------------------------------------------------------------- 73 | import Control.Monad.Lift (MonadTrans, lift) 74 | 75 | 76 | #if MIN_VERSION_mmorph(1, 0, 1) 77 | -- mmorph -------------------------------------------------------------------- 78 | import Control.Monad.Trans.Compose (ComposeT (ComposeT)) 79 | 80 | 81 | #endif 82 | #if MIN_VERSION_transformers(0, 3, 0) 83 | -- transformers -------------------------------------------------------------- 84 | import Data.Functor.Product (Product (Pair)) 85 | 86 | 87 | #endif 88 | ------------------------------------------------------------------------------ 89 | -- | The type class 'MonadST' represents the class of \"'ST'-like\" monads 90 | -- (i.e., monads which have mutable variables and operations for mutating the 91 | -- values contained therein). The @ref@ parameter is the type of the mutable 92 | -- variable; e.g., for 'IO', @ref@ is 'IORef'. 93 | -- 94 | -- Minimal complete definition: 'newRef', 'readRef', 'writeRef'. 95 | class Monad m => MonadST ref m | m -> ref where 96 | -- | Create a new mutable variable holding the value supplied. 97 | newRef :: a -> m (ref a) 98 | 99 | -- | Return the current value stored in the mutable variable. 100 | readRef :: ref a -> m a 101 | 102 | -- | Write the supplied value into the mutable variable 103 | writeRef :: ref a -> a -> m () 104 | 105 | -- | Atomically modifies the contents of a mutable variable. 106 | -- 107 | -- This function is useful for using mutable varibales in a safe way in a 108 | -- multithreaded program. If you only have one mutable variable, then 109 | -- using 'atomicModifyRef' to access and modify it will prevent race 110 | -- conditions. 111 | -- 112 | -- Extending the atomicity to multiple mutable variables is problematic, 113 | -- so if you need to do anything more complicated, it is recommended you 114 | -- use an 'Control.Concurrent.MVar.MVar' instead. 115 | -- 116 | -- 'atomicModifyRef' does not apply the function strictly. This is 117 | -- important to know even if all you are doing is replacing the value. 118 | -- For example, this will leak memory: 119 | -- 120 | -- @ref <- 'newRef' 1 121 | --'Control.Monad.forever' $ 'atomicModifyRef' ref (\\_ -> (2, ()))@ 122 | -- 123 | -- Use 'atomicModifyRef'' or 'atomicWriteRef' to avoid this problem. 124 | atomicModifyRef :: ref a -> (a -> (a, b)) -> m b 125 | 126 | atomicModifyRef ref f = do 127 | a <- readRef ref 128 | let (a', b) = f a 129 | writeRef ref a' 130 | return b 131 | {-# INLINABLE atomicModifyRef #-} 132 | 133 | #ifdef MinimalPragma 134 | {-# MINIMAL newRef, readRef, writeRef #-} 135 | 136 | #endif 137 | 138 | ------------------------------------------------------------------------------ 139 | instance MonadST IORef IO where 140 | newRef = newIORef 141 | readRef = readIORef 142 | writeRef = writeIORef 143 | atomicModifyRef = atomicModifyIORef 144 | 145 | 146 | ------------------------------------------------------------------------------ 147 | instance MonadST (STRef s) (L.ST s) where 148 | newRef = L.newSTRef 149 | readRef = L.readSTRef 150 | writeRef = L.writeSTRef 151 | 152 | 153 | ------------------------------------------------------------------------------ 154 | instance MonadST (STRef s) (ST s) where 155 | newRef = newSTRef 156 | readRef = readSTRef 157 | writeRef = writeSTRef 158 | 159 | 160 | ------------------------------------------------------------------------------ 161 | instance MonadST TVar STM where 162 | newRef = newTVar 163 | readRef = readTVar 164 | writeRef = writeTVar 165 | 166 | 167 | #if MIN_VERSION_transformers(0, 3, 0) 168 | ------------------------------------------------------------------------------ 169 | instance (MonadST ref f, MonadST ref g) => MonadST ref (Product f g) where 170 | newRef a = Pair (newRef a) (newRef a) 171 | readRef ref = Pair (readRef ref) (readRef ref) 172 | writeRef ref a = Pair (writeRef ref a) (writeRef ref a) 173 | atomicModifyRef ref f = Pair 174 | (atomicModifyRef ref f) 175 | (atomicModifyRef ref f) 176 | 177 | 178 | #endif 179 | #if MIN_VERSION_mmorph(1, 0, 1) 180 | ------------------------------------------------------------------------------ 181 | instance MonadST ref (f (g m)) => MonadST ref (ComposeT f g m) where 182 | newRef a = ComposeT (newRef a) 183 | readRef ref = ComposeT (readRef ref) 184 | writeRef ref a = ComposeT (writeRef ref a) 185 | atomicModifyRef ref f = ComposeT (atomicModifyRef ref f) 186 | 187 | 188 | #endif 189 | ------------------------------------------------------------------------------ 190 | instance __OVERLAPPABLE__ (MonadTrans t, Monad (t m), MonadST ref m) => 191 | MonadST ref (t m) 192 | where 193 | newRef = lift . newRef 194 | {-# INLINABLE newRef #-} 195 | readRef = lift . readRef 196 | {-# INLINABLE readRef #-} 197 | writeRef ref = lift . writeRef ref 198 | {-# INLINABLE writeRef #-} 199 | atomicModifyRef ref = lift . atomicModifyRef ref 200 | {-# INLINABLE atomicModifyRef #-} 201 | 202 | 203 | ------------------------------------------------------------------------------ 204 | -- | Strict version of 'atomicModifyRef'. This forces both the value stored in 205 | -- the mutable variable as well as the value returned. 206 | atomicModifyRef' :: MonadST ref m => ref a -> (a -> (a, b)) -> m b 207 | atomicModifyRef' ref f = do 208 | b <- atomicModifyRef ref (\x -> let (a, b) = f x in (a, a `seq` b)) 209 | return $! b 210 | {-# INLINABLE atomicModifyRef' #-} 211 | 212 | 213 | ------------------------------------------------------------------------------ 214 | -- | Mutate the contents of a mutable variable. 215 | -- 216 | -- Be warned that 'modifyRef' does not apply the function strictly. This means 217 | -- if the program calls 'modifyRef' many times, but seldomly uses the value, 218 | -- thunks will pile up in memory resulting in a space leak. This is a common 219 | -- mistake made when using a mutable varible as a counter. For example, the 220 | -- following will likely produce a stack overflow: 221 | -- 222 | -- @ref <- 'newRef' 0 223 | --'Control.Monad.replicateM_' 1000000 '$' 'modifyRef' ref ('+'1) 224 | --'readRef' ref '>>=' 'print'@ 225 | -- 226 | -- To avoid this problem, use 'modifyRef'' instead. 227 | modifyRef :: MonadST ref m => ref a -> (a -> a) -> m () 228 | modifyRef ref f = readRef ref >>= writeRef ref . f 229 | {-# INLINABLE modifyRef #-} 230 | 231 | 232 | ------------------------------------------------------------------------------ 233 | -- | Strict version of 'modifyRef'. 234 | modifyRef' :: MonadST ref m => ref a -> (a -> a) -> m () 235 | modifyRef' ref f = do 236 | x <- readRef ref 237 | let x' = f x 238 | x' `seq` writeRef ref x' 239 | {-# INLINABLE modifyRef' #-} 240 | 241 | 242 | ------------------------------------------------------------------------------ 243 | -- | Variant of 'writeRef' with the \"barrier to reordering\" property that 244 | -- 'atomicModifyRef' has. 245 | atomicWriteRef :: MonadST ref m => ref a -> a -> m () 246 | atomicWriteRef ref a = do 247 | x <- atomicModifyRef ref (\_ -> (a, ())) 248 | x `seq` return () 249 | {-# INLINABLE atomicWriteRef #-} 250 | -------------------------------------------------------------------------------- /src/Monad/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverlappingInstances #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | #ifdef LANGUAGE_SafeHaskell 11 | #if __GLASGOW_HASKELL__ >= 704 12 | {-# LANGUAGE Safe #-} 13 | #else 14 | {-# LANGUAGE Trustworthy #-} 15 | #endif 16 | #endif 17 | 18 | #include "docmacros.h" 19 | #include "overlap.h" 20 | 21 | {-| 22 | 23 | This module defines the 'MonadState' G(monadinterface,interface). It is 24 | designed to be compatible with the with the 25 | T(mtl,Control-Monad-State-Class,Monadstate) interface from the H(mtl) 26 | package. It consists of: 27 | 28 | * The 'MonadState' constraint. 29 | * The 'get' and 'put' operations. 30 | 31 | * Instances of 'MonadState': 32 | 33 | * For arbitrary G(innermonad,inner monads) wrapped by one of the 34 | following G(monadlayer,monad layers): 35 | 36 | * Lazy 'L.StateT' 37 | * Strict 'StateT' 38 | * Lazy 'L.RWST' 39 | * Strict 'RWST' 40 | 41 | * G(universalpassthroughinstance,Pass-through instances) for: 42 | 43 | * Any G(innermonad,inner monad) with an existing 'MonadState' 44 | instance wrapped by any G(monadlayer,monad layer) implementing 45 | 'Control.Monad.Lift.MonadTrans'. 46 | * The 'Product' of any two G(monadictype,monadic types) which both 47 | have existing 'MonadState' instances. 48 | * The 49 | of two G(monadlayer,monad layers) wrapped around an 50 | G(innermonad,inner monad), where either the 51 | G(innermonad,inner monad) or one or more of the composed 52 | G(monadlayer,monad layers) has an existing instance for 53 | 'MonadState'. 54 | 55 | * The 'gets', 'modify' and 'modify'' utility operations. 56 | 57 | -} 58 | 59 | module Monad.State 60 | ( MonadState (state, get, put) 61 | , modify, modify' 62 | , gets 63 | ) 64 | where 65 | 66 | -- base ---------------------------------------------------------------------- 67 | import Control.Monad (liftM) 68 | #if !MIN_VERSION_base(4, 8, 0) 69 | import Data.Monoid (Monoid (mempty)) 70 | #endif 71 | 72 | 73 | -- layers -------------------------------------------------------------------- 74 | import Control.Monad.Lift (MonadTrans, lift) 75 | 76 | 77 | #if MIN_VERSION_mmorph(1, 0, 1) 78 | -- mmorph -------------------------------------------------------------------- 79 | import Control.Monad.Trans.Compose (ComposeT (ComposeT)) 80 | 81 | 82 | #endif 83 | -- transformers -------------------------------------------------------------- 84 | import qualified Control.Monad.Trans.State.Lazy as L (StateT (StateT)) 85 | import Control.Monad.Trans.State.Strict (StateT (StateT)) 86 | import qualified Control.Monad.Trans.RWS.Lazy as L (RWST (RWST)) 87 | import Control.Monad.Trans.RWS.Strict (RWST (RWST)) 88 | #if MIN_VERSION_transformers(0, 3, 0) 89 | import Data.Functor.Product (Product (Pair)) 90 | #endif 91 | 92 | 93 | ------------------------------------------------------------------------------ 94 | -- | A pure functional language cannot update values in place because it 95 | -- violates referential transparency. A common idiom to simulate such stateful 96 | -- G(computation,computations) is to \"thread\" a state parameter through a 97 | -- sequence of functions. 98 | -- 99 | -- This approach works, but such code can be error-prone, messy and difficult 100 | -- to maintain. The 'MonadState' G(monadinterface,interface) hides the 101 | -- threading of the state parameter inside the binding operation, 102 | -- simultaneously making the code easier to write, easier to read and easier 103 | -- to modify. 104 | -- 105 | -- Minimal complete definition: 'state' or both 'get' and 'put'. 106 | class Monad m => MonadState s m | m -> s where 107 | -- | Embed a simple state G(computation,action) into the monad. 108 | state :: (s -> (a, s)) -> m a 109 | 110 | -- | Return the state from the internals of the monad. 111 | get :: m s 112 | 113 | -- | Replace the state inside the monad. 114 | put :: s -> m () 115 | 116 | state f = do 117 | s <- get 118 | let ~(a, s') = f s 119 | put s' 120 | return a 121 | {-# INLINABLE state #-} 122 | 123 | get = state (\s -> (s, s)) 124 | 125 | put s = state (\_ -> ((), s)) 126 | 127 | #ifdef MinimalPragma 128 | {-# MINIMAL state | (get, put) #-} 129 | 130 | #endif 131 | 132 | ------------------------------------------------------------------------------ 133 | instance Monad m => MonadState s (L.StateT s m) where 134 | state = L.StateT . (return .) 135 | get = L.StateT $ \s -> return (s, s) 136 | put s = L.StateT $ \_ -> return ((), s) 137 | 138 | 139 | ------------------------------------------------------------------------------ 140 | instance Monad m => MonadState s (StateT s m) where 141 | state = StateT . (return .) 142 | get = StateT $ \s -> return (s, s) 143 | put s = StateT $ \_ -> return ((), s) 144 | 145 | 146 | ------------------------------------------------------------------------------ 147 | instance (Monad m, Monoid w) => MonadState s (L.RWST r w s m) where 148 | state f = L.RWST $ \_ s -> let (a, s') = f s in return (a, s', mempty) 149 | get = L.RWST $ \_ s -> return (s, s, mempty) 150 | put s = L.RWST $ \_ _ -> return ((), s, mempty) 151 | 152 | 153 | ------------------------------------------------------------------------------ 154 | instance (Monad m, Monoid w) => MonadState s (RWST r w s m) where 155 | state f = RWST $ \_ s -> case f s of (a, s') -> return (a, s', mempty) 156 | get = RWST $ \_ s -> return (s, s, mempty) 157 | put s = RWST $ \_ _ -> return ((), s, mempty) 158 | 159 | 160 | #if MIN_VERSION_transformers(0, 3, 0) 161 | ------------------------------------------------------------------------------ 162 | instance (MonadState s f, MonadState s g) => MonadState s (Product f g) where 163 | state f = Pair (state f) (state f) 164 | get = Pair get get 165 | put s = Pair (put s) (put s) 166 | 167 | 168 | #endif 169 | #if MIN_VERSION_mmorph(1, 0, 1) 170 | ------------------------------------------------------------------------------ 171 | instance MonadState s (f (g m)) => MonadState s (ComposeT f g m) where 172 | state f = ComposeT (state f) 173 | get = ComposeT get 174 | put s = ComposeT (put s) 175 | 176 | 177 | #endif 178 | ------------------------------------------------------------------------------ 179 | instance __OVERLAPPABLE__ (MonadTrans t, MonadState s m, Monad (t m)) => 180 | MonadState s (t m) 181 | where 182 | state = lift . state 183 | {-# INLINABLE state #-} 184 | get = lift get 185 | {-# INLINABLE get #-} 186 | put = lift . put 187 | {-# INLINABLE put #-} 188 | 189 | 190 | ------------------------------------------------------------------------------ 191 | -- | Monadic state transformer. 192 | -- 193 | -- Maps an old state to a new state inside a state monad. The old state is 194 | -- thrown away. 195 | -- 196 | -- @>>> __:t 'modify' ('++'\"?\")__ 197 | --'modify' (...) :: ('MonadState' 'String' a) => a ()@ 198 | -- 199 | -- This says that @'modify' ('++'\"?\")@ acts over any monad that is a member 200 | -- of the 'MonadState' class with a 'String' state. 201 | modify :: MonadState s m => (s -> s) -> m () 202 | modify f = state (\s -> ((), f s)) 203 | {-# INLINABLE modify #-} 204 | 205 | 206 | ------------------------------------------------------------------------------ 207 | -- | A variant of 'modify' in which the computation is strict in the 208 | -- new state. 209 | modify' :: MonadState s m => (s -> s) -> m () 210 | modify' f = state (\s -> let s' = f s in s' `seq` ((), s')) 211 | 212 | 213 | ------------------------------------------------------------------------------ 214 | -- | Gets specific component of the state, using a projection function 215 | -- supplied. 216 | gets :: MonadState s m => (s -> a) -> m a 217 | gets f = liftM f get 218 | {-# INLINABLE gets #-} 219 | -------------------------------------------------------------------------------- /src/Monad/Throw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MonoLocalBinds #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 9 | 10 | #include "docmacros.h" 11 | #include "newtypec.h" 12 | 13 | {-| 14 | 15 | This module defines the 'MonadThrow' G(monadinterface,interface). The 16 | 'MonadThrow' G(monadinterface,interface) is a specialisation of the 17 | 'MonadAbort' G(monadinterface,interface). It, along with its sister 18 | G(monadinterface,interface) 'Monad.Catch.MonadCatch', is designed to be 19 | largely compatible with the "Control.Exception" module from H(base). It 20 | consists of: 21 | 22 | * The 'MonadThrow' constraint (a specialisation of the 'MonadAbort' 23 | constraint). 24 | * The 'throw' operation (a specialisation of the 'abort' operation). 25 | 26 | -} 27 | 28 | module Monad.Throw 29 | ( MonadThrow, throw 30 | ) 31 | where 32 | 33 | -- base ---------------------------------------------------------------------- 34 | import Control.Exception 35 | ( Exception, SomeException, toException 36 | #if !MIN_VERSION_transformers(0, 6, 0) 37 | , PatternMatchFail (PatternMatchFail) 38 | #endif 39 | ) 40 | 41 | 42 | -- layers -------------------------------------------------------------------- 43 | import Monad.Abort (MonadAbort, abort) 44 | #if !MIN_VERSION_transformers(0, 6, 0) 45 | import Control.Monad.Trans.Error (Error, noMsg, strMsg) 46 | #endif 47 | 48 | 49 | ------------------------------------------------------------------------------ 50 | -- | 'MonadThrow' is an alias of 'MonadAbort' where the failure state type @e@ 51 | -- is fixed to 'SomeException'. It represents the class of monads which 52 | -- support some sort of 'Control.Exception.throwIO'-like operation. 53 | newtypeC(MonadThrow m, MonadAbort SomeException m) 54 | 55 | 56 | ------------------------------------------------------------------------------ 57 | -- | A version of 'Control.Exception.throwIO' for arbitrary instances of 58 | -- 'MonadThrow'. 59 | throw :: (Exception e, MonadThrow m) => e -> m a 60 | throw = abort . toException 61 | #if !MIN_VERSION_transformers(0, 6, 0) 62 | 63 | 64 | ------------------------------------------------------------------------------ 65 | -- | Cheeky orphan instance of 'Error' for 'SomeException'. This allows 66 | -- 'SomeException' to be used with the 'Control.Monad.Trans.Error.ErrorT' 67 | -- G(monadtransformer,monad transformer), and thus 'Monad.Throw.MonadThrow' 68 | -- and 'Monad.Catch.MonadCatch' instances to be defined for 69 | -- @'Control.Monad.Trans.Error.ErrorT' 'SomeException'@. 70 | instance Error SomeException where 71 | noMsg = strMsg "mzero" 72 | strMsg = toException . PatternMatchFail 73 | #endif 74 | -------------------------------------------------------------------------------- /src/Monad/Try.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverlappingInstances #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | #include "docmacros.h" 12 | #include "overlap.h" 13 | 14 | {-| 15 | 16 | This module defines the 'MonadTry' G(monadinterface,interface). It, along with 17 | its sister G(monadinterface,interface) 'Monad.Mask.MonadMask', is designed to 18 | be largely compatible with the "Control.Exception" module from H(base). It 19 | consists of: 20 | 21 | * The 'MonadTry' constraint. 22 | * The 'mtry' operation. 23 | 24 | * Instances of 'MonadTry': 25 | 26 | * For every G(basemonad,base monad) in the H(base) and H(transformers) 27 | packages: 28 | 29 | * 'Either' 30 | * @-@@>@ 31 | * 'Identity' 32 | * 'IO' 33 | * @[@@]@ 34 | * 'Maybe' 35 | * 'Proxy' 36 | * Lazy 'L.ST' 37 | * Strict 'ST' 38 | * 'STM' 39 | 40 | * G(universalpassthroughinstance,Pass-through instances) for: 41 | 42 | * Any G(innermonad,inner monad) with an existing 'MonadTry' 43 | instance wrapped by any G(monadlayer,monad layer) implementing 44 | 'Control.Monad.Lift.MonadTransControl'. 45 | * The 46 | of two G(monadlayer,monad layers) wrapped around an 47 | G(innermonad,inner monad), where either the 48 | G(innermonad,inner monad) or one or more of the composed 49 | G(monadlayer,monad layers) has an existing instance for 50 | 'MonadTry'. 51 | 52 | * The \"bracket\" family of operations (as defined in "Control.Exception"): 53 | 54 | * 'bracket' 55 | * 'bracket_' 56 | * 'bracketOnError' 57 | * 'finally' 58 | * 'onException' 59 | * 'orElse' (actually from the H(stm) package) 60 | 61 | -} 62 | 63 | module Monad.Try 64 | ( MonadTry (mtry) 65 | , bracket, bracket_, bracketOnError 66 | , finally, onException 67 | , orElse 68 | ) 69 | where 70 | 71 | -- base ---------------------------------------------------------------------- 72 | #if MIN_VERSION_mmorph(1, 0, 1) 73 | import Control.Arrow (left) 74 | #endif 75 | import Control.Exception (SomeException, throwIO, try) 76 | import Control.Monad (liftM) 77 | import Control.Monad.ST (ST) 78 | import qualified Control.Monad.ST.Lazy as L (ST) 79 | import Data.Functor.Identity (Identity) 80 | #if MIN_VERSION_base(4, 3, 0) 81 | import GHC.Conc.Sync (STM, catchSTM, throwSTM) 82 | #else 83 | import GHC.Conc (STM, catchSTM, unsafeIOToSTM) 84 | #endif 85 | #if MIN_VERSION_base(4, 7, 0) 86 | import Data.Proxy (Proxy) 87 | #endif 88 | 89 | 90 | -- layers -------------------------------------------------------------------- 91 | import Monad.Mask (MonadMask, mask) 92 | import Control.Monad.Lift 93 | ( MonadTransControl 94 | , extract, lift, suspend, resume, capture 95 | ) 96 | 97 | 98 | #if MIN_VERSION_mmorph(1, 0, 1) 99 | -- mmorph -------------------------------------------------------------------- 100 | import Control.Monad.Trans.Compose (ComposeT (ComposeT)) 101 | 102 | 103 | #endif 104 | ------------------------------------------------------------------------------ 105 | -- | The 'MonadTry' type class provides a single operation 'mtry', which is a 106 | -- generalised way to observe G(shortcircuit,short-circuiting) in monads. 107 | -- The name refers to the fact that 'mtry' is a generalised version of 108 | -- 'Monad.Exception.try': whereas 'try' guards against the specific case of a 109 | -- monad G(shortcircuit,short-circuiting) from a call to 'Monad.Throw.throw', 110 | -- there can be other ways that a monad can G(shortcircuit,short-circuit). 111 | -- For example, the monad @'Control.Monad.Trans.Maybe.MaybeT' 'IO'@ can be 112 | -- G(shortcircuit,short-circuited) by calling 'Control.Monad.mzero' 113 | -- ('Nothing') or by raising an exception in the underlying 'IO' monad. The 114 | -- G(computation,computation) returned by 'mtry' is guaranteed never to 115 | -- G(shortcircuit,short-circuit), even if the G(monadtransformerstack,stack) 116 | -- is built from many G(shortcircuit,short-circuiting) different 117 | -- G(monadlayer,layers). 118 | -- 119 | -- Nearly every monad should permit an instance of 'MonadTry', with the 120 | -- exception of CPS-style monads whose (possible) 121 | -- G(shortcircuit,short-circuiting) is impossible to observe. Instances are 122 | -- provided for every G(basemonad, base monad) in the H(base) and 123 | -- H(transformers) packages. 'mtry' has a default definition that only needs 124 | -- to be overridden for monads which actually G(shortcircuit,short-circuit), 125 | -- so it costs very little to add an instance of 'MonadTry' to a monad. 126 | -- 127 | -- Minimal complete definition: instance head only. 128 | class MonadMask m => MonadTry m where 129 | -- | 'mtry' takes a G(computation,computation) in @m@ and returns a new 130 | -- monadic value in @m@ which is guaranteed not to 131 | -- G(shortcircuit,short-circuit). If the original 132 | -- G(computation,computation) @m@ 133 | -- given to 'mtry' would have G(shortcircuit,short-circuited), the 134 | -- resulting value returned by 'mtry' is @'Left' m@. 135 | -- Otherwise, 'mtry' returns @'Right' a@, where @a@ is the value returned 136 | -- by the computation @m@. 137 | -- 138 | -- Instances should satisfy the following laws: 139 | -- 140 | -- [Preserve-Unit] 141 | -- @'mtry' ('return' a) ≡ 'return' ('Right' a)@ 142 | -- 143 | -- [Implies-Non-Zero] 144 | -- @('mtry' m ≡ 'liftM' 'Right' m) ∧ ((a ≢ b) ⇒ ('return' a ≢ 'return' b)) ⇒ (∃f. m '>>=' f ≢ m)@ 145 | -- 146 | -- [Implies-Zero] 147 | -- @('mtry' m ≡ 'return' ('Left' m)) ⇒ (∀f. m '>>=' f ≡ m)@ 148 | mtry :: m a -> m (Either (m b) a) 149 | mtry = liftM Right 150 | 151 | #ifdef MinimalPragma 152 | {-# MINIMAL #-} 153 | 154 | #endif 155 | 156 | ------------------------------------------------------------------------------ 157 | instance MonadTry Identity 158 | 159 | 160 | #if MIN_VERSION_mmorph(1, 0, 1) 161 | ------------------------------------------------------------------------------ 162 | instance MonadTry (f (g m)) => MonadTry (ComposeT f g m) where 163 | mtry (ComposeT m) = ComposeT (liftM (left ComposeT) (mtry m)) 164 | 165 | 166 | #endif 167 | ------------------------------------------------------------------------------ 168 | instance MonadTry Maybe where 169 | mtry = return . maybe (Left Nothing) Right 170 | 171 | 172 | ------------------------------------------------------------------------------ 173 | instance MonadTry (Either e) where 174 | mtry = return . either (Left . Left) Right 175 | 176 | 177 | ------------------------------------------------------------------------------ 178 | instance MonadTry [] where 179 | mtry [] = [Left []] 180 | mtry (x:xs) = Right x : map Right xs 181 | 182 | 183 | ------------------------------------------------------------------------------ 184 | instance MonadTry ((->) r) 185 | 186 | 187 | ------------------------------------------------------------------------------ 188 | instance MonadTry IO where 189 | mtry m = try' m >>= return . either (Left . throwIO) Right 190 | where 191 | try' :: IO a -> IO (Either SomeException a) 192 | try' = try 193 | 194 | 195 | ------------------------------------------------------------------------------ 196 | instance MonadTry (ST s) 197 | 198 | 199 | ------------------------------------------------------------------------------ 200 | instance MonadTry (L.ST s) 201 | 202 | 203 | ------------------------------------------------------------------------------ 204 | instance MonadTry STM where 205 | mtry m = try' m >>= return . either (Left . throwSTM) Right 206 | where 207 | #if !MIN_VERSION_base(4, 3, 0) 208 | throwSTM = unsafeIOToSTM . throwIO 209 | #endif 210 | try' :: STM a -> STM (Either SomeException a) 211 | try' m' = catchSTM (liftM Right m') (return . Left) 212 | 213 | 214 | #if MIN_VERSION_base(4, 7, 0) 215 | ------------------------------------------------------------------------------ 216 | instance MonadTry Proxy 217 | 218 | 219 | #endif 220 | ------------------------------------------------------------------------------ 221 | data Pt (t :: (* -> *) -> * -> *) = Pt 222 | 223 | 224 | ------------------------------------------------------------------------------ 225 | instance __OVERLAPPABLE__ (MonadTransControl t, MonadMask (t m), MonadTry m) 226 | => 227 | MonadTry (t m) 228 | where 229 | mtry m = do 230 | state <- capture 231 | ma <- lift . mtry $ suspend m state 232 | case ma of 233 | Left m' -> return . Left $ lift m' 234 | Right (result, state') -> case extract (Pt :: Pt t) result of 235 | Left result' -> return . Left $ resume (result', state') 236 | Right _ -> liftM Right $ resume (result, state') 237 | {-# INLINE mtry #-} 238 | 239 | 240 | ------------------------------------------------------------------------------ 241 | -- | When you want to acquire a resource, do some work with it, and then 242 | -- release the resource, it is a good idea to use 'bracket', because 'bracket' 243 | -- will install the necessary handler to release the resource in the event 244 | -- that the G(computation,computation) G(shortcircuit,short-circuits). In such 245 | -- a case, 'bracket' will re-return the G(computation,computation) in its 246 | -- G(shortcircuit,short-circuited) state (after performing the release). 247 | -- 248 | -- A common example is opening a file: 249 | -- 250 | -- @'bracket' 251 | -- ('System.IO.openFile' "filename" 'System.IO.ReadMode') 252 | -- ('System.IO.hClose') 253 | -- (\\fileHandle -> do { ... })@ 254 | -- 255 | -- The arguments to @bracket@ are in this order so that we can partially apply 256 | -- it, e.g.: 257 | -- 258 | -- @'System.IO.withFile' name mode = 'bracket' ('System.IO.openFile' name mode) 'System.IO.hClose'@ 259 | -- 260 | bracket :: MonadTry m 261 | => m a -- ^ G(computation,computation) to run first (\"acquire resource\") 262 | -> (a -> m b) -- ^ G(computation,computation) to run last (\"release resource\") 263 | -> (a -> m c) -- ^ G(computation,computation) to run in-between 264 | -> m c -- ^ returns the value from the in-between G(computation,computation) 265 | bracket acquire release run = mask $ \restore -> do 266 | a <- acquire 267 | restore (run a) `finally` release a 268 | {-# INLINABLE bracket #-} 269 | 270 | 271 | ------------------------------------------------------------------------------ 272 | -- | A variant of 'bracket' where the return value from the first 273 | -- G(computation,computation) is not required. 274 | bracket_ :: MonadTry m => m a -> m b -> m c -> m c 275 | bracket_ acquire release run = bracket acquire (const release) (const run) 276 | {-# INLINABLE bracket_ #-} 277 | 278 | 279 | ------------------------------------------------------------------------------ 280 | -- | Like 'bracket', but only performs the final G(computation,action) if the 281 | -- monad G(shortcircuit,short-circuited) during the in-between 282 | -- G(computation,computation). 283 | bracketOnError :: MonadTry m => m a -> (a -> m b) -> (a -> m c) -> m c 284 | bracketOnError acquire release run = mask $ \restore -> do 285 | a <- acquire 286 | restore (run a) `onException` release a 287 | {-# INLINABLE bracketOnError #-} 288 | 289 | 290 | ------------------------------------------------------------------------------ 291 | -- | A specialised variant of 'bracket' with just a G(computation,computation) 292 | -- to run afterward. 293 | finally :: MonadTry m => m a -> m b -> m a 294 | finally m sequel = mask $ \restore -> do 295 | r <- restore m `onException` sequel 296 | _ <- sequel 297 | return r 298 | {-# INLINABLE finally #-} 299 | 300 | 301 | ------------------------------------------------------------------------------ 302 | -- | Like 'finally', but only performs the final G(computation,action) if 303 | -- the monad G(shortcircuit,short-circuited) during the 304 | -- G(computation,computation). 305 | onException :: MonadTry m => m a -> m b -> m a 306 | onException m sequel = mask $ \restore -> do 307 | mtry (restore m) >>= either (sequel >>) return 308 | {-# INLINABLE onException #-} 309 | 310 | 311 | ------------------------------------------------------------------------------ 312 | -- | Tries the first G(computation,action), and if it G(shortcircuit,fails), 313 | -- tries the second G(computation,action). 314 | orElse :: MonadTry m => m a -> m a -> m a 315 | orElse a b = mask $ \restore -> mtry (restore a) >>= either (const b) return 316 | {-# INLINABLE orElse #-} 317 | -------------------------------------------------------------------------------- /src/Monad/Writer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverlappingInstances #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | #ifdef LANGUAGE_SafeHaskell 11 | #if __GLASGOW_HASKELL__ >= 704 12 | {-# LANGUAGE Safe #-} 13 | #else 14 | {-# LANGUAGE Trustworthy #-} 15 | #endif 16 | #endif 17 | 18 | #include "docmacros.h" 19 | #include "overlap.h" 20 | 21 | {-| 22 | 23 | This module defines the 'MonadWriter' G(monadinterface,interface). It is 24 | designed to be compatible with the with the 25 | T(mtl,Control-Monad-Writer-Class,MonadWriter) interface from the H(mtl) 26 | package. It consists of: 27 | 28 | * The 'MonadWriter' constraint. 29 | * The 'tell', 'listen' and 'pass' operations. 30 | 31 | * Instances of 'MonadWriter': 32 | 33 | * For arbitrary G(innermonad,inner monads) wrapped by one of the 34 | following G(monadlayer,monad layers): 35 | 36 | * Lazy 'L.WriterT' 37 | * Strict 'WriterT' 38 | * Lazy 'L.RWST' 39 | * Strict 'RWST' 40 | 41 | * G(universalpassthroughinstance,Pass-through instances) for: 42 | 43 | * Any G(innermonad,inner monad) with an existing 'MonadWriter' 44 | instance wrapped by any G(monadlayer,monad layer) implementing 45 | 'Control.Monad.Lift.MonadTrans'. 46 | * The 'Product' of any two G(monadictype,monadic types) which both 47 | have existing 'MonadWriter' instances. 48 | * The 49 | of two G(monadlayer,monad layers) wrapped around an 50 | G(innermonad,inner monad), where either the 51 | G(innermonad,inner monad) or one or more of the composed 52 | G(monadlayer,monad layers) has an existing instance for 53 | 'MonadWriter'. 54 | 55 | * The 'writer', 'listens' and and 'censor' utility operations. 56 | 57 | -} 58 | 59 | module Monad.Writer 60 | ( MonadWriter (writer, tell, listen, pass) 61 | , listens, censor 62 | ) 63 | where 64 | 65 | -- base ---------------------------------------------------------------------- 66 | import Control.Monad (liftM) 67 | #if !MIN_VERSION_base(4, 8, 0) 68 | import Data.Monoid (Monoid) 69 | #endif 70 | 71 | 72 | -- layers -------------------------------------------------------------------- 73 | import Control.Monad.Lift (MonadTrans, lift) 74 | 75 | 76 | #if MIN_VERSION_mmorph(1, 0, 1) 77 | -- mmorph -------------------------------------------------------------------- 78 | import Control.Monad.Trans.Compose (ComposeT (ComposeT)) 79 | 80 | 81 | #endif 82 | -- transformers -------------------------------------------------------------- 83 | import qualified Control.Monad.Trans.RWS.Lazy as L (RWST (RWST)) 84 | import Control.Monad.Trans.RWS.Strict (RWST (RWST)) 85 | import qualified Control.Monad.Trans.Writer.Lazy as L (WriterT (WriterT)) 86 | import Control.Monad.Trans.Writer.Strict (WriterT (WriterT)) 87 | #if MIN_VERSION_transformers(0, 3, 0) 88 | import Data.Functor.Product (Product (Pair)) 89 | #endif 90 | 91 | 92 | ------------------------------------------------------------------------------ 93 | -- | It is often desirable for a G(computation,computation) to generate output 94 | -- \"on the side\". Logging and tracing are the most common examples in which 95 | -- data is generated during a G(computation,computation) that we want to 96 | -- retain but is not the primary result of the G(computaiton,computation). 97 | -- 98 | -- Explicitly managing the logging or tracing data can clutter up the code and 99 | -- invite subtle bugs such as missed log entries. The 'MonadWriter' 100 | -- G(monadinterface,interface) provides a cleaner way to manage the output 101 | -- without cluttering the main G(computation,computation). 102 | -- 103 | -- Minimal complete definition: 'listen', 'pass' and one of either 'writer' or 104 | -- 'tell'. 105 | class (Monad m, Monoid w) => MonadWriter w m | m -> w where 106 | -- | @'writer' (a,w)@ embeds a simple writer G(computation,action). 107 | writer :: (a, w) -> m a 108 | 109 | -- | @'tell' w@ is an G(computation,action) that produces the output @w@. 110 | tell :: w -> m () 111 | 112 | -- | @'listen' m@ is an G(computation,action) that executes the 113 | -- G(computation,action) @m@ and adds its output to the value of the 114 | -- G(compuation,computation). 115 | listen :: m a -> m (a, w) 116 | 117 | -- | @'pass' m@ is an G(computation,action) that executes the 118 | -- G(computation,action) @m@, which returns a value and a function, and 119 | -- returns the value, applying the function to the output. 120 | pass :: m (a, w -> w) -> m a 121 | 122 | writer ~(a, w) = tell w >> return a 123 | {-# INLINABLE writer #-} 124 | 125 | tell w = writer ((), w) 126 | {-# INLINABLE tell #-} 127 | 128 | #ifdef MinimalPragma 129 | {-# MINIMAL listen, pass, (writer | tell) #-} 130 | 131 | #endif 132 | 133 | ------------------------------------------------------------------------------ 134 | instance (Monad m, Monoid w) => MonadWriter w (L.WriterT w m) where 135 | writer = L.WriterT . return 136 | tell w = L.WriterT $ return ((), w) 137 | listen (L.WriterT m) = L.WriterT $ liftM (\(a, w) -> ((a, w), w)) m 138 | pass (L.WriterT m) = L.WriterT $ liftM (\((a, f), w) -> (a, f w)) m 139 | 140 | 141 | ------------------------------------------------------------------------------ 142 | instance (Monad m, Monoid w) => MonadWriter w (WriterT w m) where 143 | writer = WriterT . return 144 | tell w = WriterT $ return ((), w) 145 | listen (WriterT m) = WriterT $ liftM (\(a, w) -> ((a, w), w)) m 146 | pass (WriterT m) = WriterT $ liftM (\((a, f), w) -> (a, f w)) m 147 | 148 | 149 | ------------------------------------------------------------------------------ 150 | instance (Monad m, Monoid w) => MonadWriter w (L.RWST r w s m) where 151 | writer (a, w) = L.RWST $ \_ s -> return (a, s, w) 152 | tell w = L.RWST $ \_ s -> return ((), s, w) 153 | listen (L.RWST m) = L.RWST $ \r s -> 154 | liftM (\(~(a, s', w)) -> ((a, w), s', w)) (m r s) 155 | pass (L.RWST m) = L.RWST $ \r s -> 156 | liftM (\(~((a, f), s', w)) -> (a, s', f w)) (m r s) 157 | 158 | 159 | ------------------------------------------------------------------------------ 160 | instance (Monad m, Monoid w) => MonadWriter w (RWST r w s m) where 161 | writer (a, w) = RWST $ \_ s -> return (a, s, w) 162 | tell w = RWST $ \_ s -> return ((), s, w) 163 | listen (RWST m) = RWST $ \r s -> 164 | liftM (\(a, s', w) -> ((a, w), s', w)) (m r s) 165 | pass (RWST m) = RWST $ \r s -> 166 | liftM (\((a, f), s', w) -> (a, s', f w)) (m r s) 167 | 168 | 169 | #if MIN_VERSION_transformers(0, 3, 0) 170 | ------------------------------------------------------------------------------ 171 | instance (MonadWriter w f, MonadWriter w g) => MonadWriter w (Product f g) 172 | where 173 | writer f = Pair (writer f) (writer f) 174 | tell w = Pair (tell w) (tell w) 175 | listen (Pair f g) = Pair (listen f) (listen g) 176 | pass (Pair f g) = Pair (pass f) (pass g) 177 | 178 | 179 | #endif 180 | #if MIN_VERSION_mmorph(1, 0, 1) 181 | ------------------------------------------------------------------------------ 182 | instance MonadWriter w (f (g m)) => MonadWriter w (ComposeT f g m) where 183 | writer f = ComposeT (writer f) 184 | tell w = ComposeT (tell w) 185 | listen (ComposeT m) = ComposeT (listen m) 186 | pass (ComposeT m) = ComposeT (pass m) 187 | 188 | 189 | #endif 190 | ------------------------------------------------------------------------------ 191 | instance __OVERLAPPABLE__ (MonadTrans t, Monad (t m), MonadWriter w m) => 192 | MonadWriter w (t m) 193 | where 194 | writer = lift . writer 195 | {-# INLINABLE writer #-} 196 | tell = lift . tell 197 | {-# INLINABLE tell #-} 198 | listen m = m >>= lift . listen . return 199 | {-# INLINABLE listen #-} 200 | pass m = m >>= lift . pass . return 201 | {-# INLINABLE pass #-} 202 | 203 | 204 | ------------------------------------------------------------------------------ 205 | -- | @'listens' f m@ is an G(computation,action) that executes the 206 | -- G(computation,action) @m@ and adds the result of applying @f@ to the output 207 | -- to the value of the G(computation,computation). 208 | -- 209 | -- @'listens' f m = 'liftM' (\\(~(a, w)) -> (a, f w)) ('listen' m)@ 210 | listens :: MonadWriter w m => (w -> b) -> m a -> m (a, b) 211 | listens f = liftM (\(~(a, w)) -> (a, f w)) . listen 212 | {-# INLINABLE listens #-} 213 | 214 | 215 | ------------------------------------------------------------------------------ 216 | -- | @'censor' f m@ is an G(computation,action) that executes the 217 | -- G(computation,action) @m@ and applies the function @f@ to its output, 218 | -- leaving the return value unchanged. 219 | -- 220 | -- @'censor' f m = 'pass' ('liftM' (\\a -> (a,f)) m)@ 221 | censor :: MonadWriter w m => (w -> w) -> m a -> m a 222 | censor f = pass . liftM (\a -> (a, f)) 223 | {-# INLINABLE censor #-} 224 | --------------------------------------------------------------------------------