├── CHANGELOG.markdown ├── .ghci ├── AUTHORS.markdown ├── .gitignore ├── Setup.lhs ├── tests ├── Tests.hs └── Control │ └── Monad │ └── Catch │ └── Tests.hs ├── README.markdown ├── travis ├── config └── cabal-apt-install ├── .travis.yml ├── .vim.custom ├── exceptions.cabal ├── LICENSE └── src └── Control └── Monad └── Catch.hs /CHANGELOG.markdown: -------------------------------------------------------------------------------- 1 | 0.1 2 | --- 3 | * Repository initialized 4 | -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc -idist/build/autogen -optPdist/build/autogen/cabal_macros.h 2 | -------------------------------------------------------------------------------- /AUTHORS.markdown: -------------------------------------------------------------------------------- 1 | `exceptions` is based on code contributed by [Mark Lentzcner](http://github.com/mzero). 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | docs 3 | wiki 4 | TAGS 5 | tags 6 | wip 7 | .DS_Store 8 | .*.swp 9 | .*.swo 10 | *.o 11 | *.hi 12 | *~ 13 | *# 14 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/runhaskell 2 | > module Main (main) where 3 | 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /tests/Tests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Framework (defaultMain) 4 | 5 | import qualified Control.Monad.Catch.Tests 6 | 7 | main :: IO () 8 | main = defaultMain 9 | [ Control.Monad.Catch.Tests.tests 10 | ] 11 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | exceptions 2 | ========== 3 | 4 | [![Build Status](https://secure.travis-ci.org/ekmett/exceptions.png?branch=master)](http://travis-ci.org/ekmett/exceptions) 5 | 6 | This package provides (optionally pure) extensible exceptions that are compatible with the monad transformer library. 7 | 8 | Contact Information 9 | ------------------- 10 | 11 | Contributions and bug reports are welcome! 12 | 13 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 14 | 15 | -Edward Kmett 16 | -------------------------------------------------------------------------------- /travis/config: -------------------------------------------------------------------------------- 1 | -- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix 2 | -- 3 | -- This is particularly useful for travis-ci to get it to stop complaining 4 | -- about a broken build when everything is still correct on our end. 5 | -- 6 | -- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead 7 | -- 8 | -- To enable this, uncomment the before_script in .travis.yml 9 | 10 | remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive 11 | remote-repo-cache: ~/.cabal/packages 12 | world-file: ~/.cabal/world 13 | build-summary: ~/.cabal/logs/build.log 14 | remote-build-reporting: anonymous 15 | install-dirs user 16 | install-dirs global 17 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | before_install: 3 | # Uncomment whenever hackage is down. 4 | # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update 5 | - cabal update 6 | 7 | # Try installing some of the build-deps with apt-get for speed. 8 | - travis/cabal-apt-install $mode 9 | 10 | install: 11 | - cabal configure -flib-Werror $mode 12 | - cabal build 13 | 14 | script: 15 | - $script && hlint src --cpp-define HLINT 16 | 17 | notifications: 18 | irc: 19 | channels: 20 | - "irc.freenode.org#haskell-lens" 21 | skip_join: true 22 | template: 23 | - "\x0313exceptions\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" 24 | 25 | env: 26 | - mode="--enable-tests" script="cabal test --show-details=always" 27 | -------------------------------------------------------------------------------- /travis/cabal-apt-install: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | set -eu 3 | 4 | APT="sudo apt-get -q -y" 5 | CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" 6 | 7 | $APT update 8 | $APT install dctrl-tools 9 | 10 | # Find potential system packages to satisfy cabal dependencies 11 | deps() 12 | { 13 | local M='^\([^ ]\+\)-[0-9.]\+ (.*$' 14 | local G=' -o ( -FPackage -X libghc-\L\1\E-dev )' 15 | local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \ 16 | | sed -ne "s/$M/$G/p" | sort -u)" 17 | grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u 18 | } 19 | 20 | $APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special 21 | $CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage 22 | 23 | if ! $APT install hlint ; then 24 | $APT install $(deps hlint) 25 | cabal install hlint 26 | fi 27 | 28 | -------------------------------------------------------------------------------- /.vim.custom: -------------------------------------------------------------------------------- 1 | " Add the following to your .vimrc to automatically load this on startup 2 | 3 | " if filereadable(".vim.custom") 4 | " so .vim.custom 5 | " endif 6 | 7 | function StripTrailingWhitespace() 8 | let myline=line(".") 9 | let mycolumn = col(".") 10 | silent %s/ *$// 11 | call cursor(myline, mycolumn) 12 | endfunction 13 | 14 | " enable syntax highlighting 15 | syntax on 16 | 17 | " search for the tags file anywhere between here and / 18 | set tags=TAGS;/ 19 | 20 | " highlight tabs and trailing spaces 21 | set listchars=tab:‗‗,trail:‗ 22 | set list 23 | 24 | " f2 runs hasktags 25 | map :exec ":!hasktags -x -c --ignore src" 26 | 27 | " strip trailing whitespace before saving 28 | " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() 29 | 30 | " rebuild hasktags after saving 31 | au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" 32 | -------------------------------------------------------------------------------- /exceptions.cabal: -------------------------------------------------------------------------------- 1 | name: exceptions 2 | category: Control, Exceptions, Monad 3 | version: 0.1 4 | cabal-version: >= 1.8 5 | license: OtherLicense 6 | license-file: LICENSE 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/exceptions/ 11 | bug-reports: http://github.com/ekmett/exceptions/issues 12 | copyright: Copyright (C) 2013 Edward A. Kmett 13 | Copyright (C) 2012 Google Inc. 14 | build-type: Simple 15 | tested-with: GHC == 7.4.1, GHC == 7.6.1 16 | synopsis: Extensible optionally-pure exceptions 17 | description: Extensible optionally-pure exceptions 18 | 19 | extra-source-files: 20 | .travis.yml 21 | .ghci 22 | .gitignore 23 | .vim.custom 24 | travis/cabal-apt-install 25 | travis/config 26 | AUTHORS.markdown 27 | README.markdown 28 | CHANGELOG.markdown 29 | 30 | source-repository head 31 | type: git 32 | location: git://github.com/ekmett/exceptions.git 33 | 34 | library 35 | build-depends: 36 | base >= 4.3 && < 5, 37 | transformers >= 0.2 && < 0.4, 38 | mtl >= 2.0 && < 2.2 39 | 40 | exposed-modules: 41 | Control.Monad.Catch 42 | 43 | ghc-options: -Wall -fwarn-tabs -O2 44 | hs-source-dirs: src 45 | 46 | test-suite exceptions-tests 47 | main-is: Tests.hs 48 | hs-source-dirs: src, tests 49 | ghc-options: -Wall -fwarn-tabs 50 | type: exitcode-stdio-1.0 51 | build-depends: 52 | base >= 4.3 && < 5, 53 | transformers >= 0.2 && < 0.4, 54 | mtl >= 2.0 && < 2.2, 55 | 56 | test-framework >= 0.8 && < 0.9, 57 | test-framework-quickcheck2 >= 0.3 && < 0.4, 58 | QuickCheck >= 2.5 && < 2.6 59 | -------------------------------------------------------------------------------- /tests/Control/Monad/Catch/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE CPP #-} 6 | 7 | module Control.Monad.Catch.Tests (tests) where 8 | 9 | #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706) 10 | import Prelude hiding (catch) 11 | #endif 12 | 13 | import Control.Applicative ((<*>)) 14 | import Data.Data (Data, Typeable) 15 | 16 | import Control.Monad.Trans.Identity (IdentityT(..)) 17 | import Control.Monad.Reader (ReaderT(..)) 18 | import Test.Framework (Test, testGroup) 19 | import Test.Framework.Providers.QuickCheck2 (testProperty) 20 | import Test.QuickCheck (Property, once) 21 | import Test.QuickCheck.Monadic (monadic, run, assert) 22 | import Test.QuickCheck.Property (morallyDubiousIOProperty) 23 | import qualified Control.Monad.State.Lazy as LazyState 24 | import qualified Control.Monad.State.Strict as StrictState 25 | import qualified Control.Monad.Writer.Lazy as LazyWriter 26 | import qualified Control.Monad.Writer.Strict as StrictWriter 27 | import qualified Control.Monad.RWS.Lazy as LazyRWS 28 | import qualified Control.Monad.RWS.Strict as StrictRWS 29 | 30 | import Control.Monad.Catch (Exception, MonadCatch(..), runCatch, 31 | catchJust) 32 | 33 | data TestException = TestException String 34 | deriving (Show, Eq, Data, Typeable) 35 | 36 | instance Exception TestException 37 | 38 | data MSpec = forall m. (MonadCatch m) => MSpec 39 | { mspecName :: String 40 | , mspecRunner :: (m Property -> Property) 41 | } 42 | 43 | testMonadCatch :: MSpec -> Property 44 | testMonadCatch MSpec { mspecRunner } = monadic mspecRunner $ 45 | run $ catch failure handler 46 | where 47 | failure = throwM (TestException "foo") >> error "testMonadCatch" 48 | handler (_ :: TestException) = return () 49 | 50 | testCatchJust :: MSpec -> Property 51 | testCatchJust MSpec { mspecRunner } = monadic mspecRunner $ do 52 | nice <- run $ catchJust testException posFailure posHandler 53 | assert $ nice == ("pos", True) 54 | bad <- run $ catch (catchJust testException negFailure posHandler) negHandler 55 | assert $ bad == ("neg", True) 56 | where 57 | testException (TestException s) = if s == "pos" then Just True else Nothing 58 | posHandler x = return ("pos", x) 59 | negHandler (_ :: TestException) = return ("neg", True) 60 | posFailure = throwM (TestException "pos") >> error "testCatchJust pos" 61 | negFailure = throwM (TestException "neg") >> error "testCatchJust neg" 62 | 63 | tests :: Test 64 | tests = testGroup "Control.Monad.Catch.Tests" $ 65 | [ mkMonadCatch 66 | , mkCatchJust 67 | ] <*> mspecs 68 | where 69 | mspecs = 70 | [ MSpec "IO" io 71 | , MSpec "IdentityT IO" $ io . runIdentityT 72 | , MSpec "LazyState.StateT IO" $ io . flip LazyState.evalStateT () 73 | , MSpec "StrictState.StateT IO" $ io . flip StrictState.evalStateT () 74 | , MSpec "ReaderT IO" $ io . flip runReaderT () 75 | , MSpec "LazyWriter.WriterT IO" $ io . fmap tfst . LazyWriter.runWriterT 76 | , MSpec "StrictWriter.WriterT IO" $ io . fmap tfst . StrictWriter.runWriterT 77 | , MSpec "LazyRWS.RWST IO" $ \m -> io $ fmap tfst $ LazyRWS.evalRWST m () () 78 | , MSpec "StrictRWS.RWST IO" $ \m -> io $ fmap tfst $ StrictRWS.evalRWST m () () 79 | 80 | , MSpec "CatchT Indentity" $ fromRight . runCatch 81 | ] 82 | 83 | tfst :: (Property, ()) -> Property = fst 84 | fromRight (Left _) = error "fromRight" 85 | fromRight (Right a) = a 86 | io = morallyDubiousIOProperty 87 | 88 | mkMonadCatch = mkTestType "MonadCatch" testMonadCatch 89 | mkCatchJust = mkTestType "catchJust" testCatchJust 90 | 91 | mkTestType name test = \spec -> 92 | testProperty (name ++ " " ++ mspecName spec) $ once $ test spec 93 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /src/Control/Monad/Catch.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright 2012 Google Inc. All Rights Reserved. 3 | 4 | Licensed under the Apache License, Version 2.0 (the "License"); 5 | you may not use this file except in compliance with the License. 6 | You may obtain a copy of the License at 7 | 8 | http://www.apache.org/licenses/LICENSE-2.0 9 | 10 | Unless required by applicable law or agreed to in writing, software 11 | distributed under the License is distributed on an "AS IS" BASIS, 12 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | See the License for the specific language governing permissions and 14 | limitations under the License. 15 | -} 16 | 17 | {-# LANGUAGE CPP #-} 18 | {-# LANGUAGE ExistentialQuantification #-} 19 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 20 | {-# LANGUAGE RankNTypes #-} 21 | {-# LANGUAGE FlexibleInstances #-} 22 | {-# LANGUAGE MultiParamTypeClasses #-} 23 | {-# LANGUAGE UndecidableInstances #-} 24 | 25 | #ifndef MIN_VERSION_transformers 26 | #define MIN_VERSION_transformers(x,y,z) 1 27 | #endif 28 | 29 | #ifndef MIN_VERSION_mtl 30 | #define MIN_VERSION_mtl(x,y,z) 1 31 | #endif 32 | 33 | -------------------------------------------------------------------- 34 | -- | 35 | -- Copyright : (c) Edward Kmett 2013, (c) Google Inc. 2012 36 | -- License : BSD3 37 | -- Maintainer: Edward Kmett 38 | -- Stability : experimental 39 | -- Portability: non-portable 40 | -- 41 | -- This module supports monads that can throw extensible exceptions. The 42 | -- exceptions are the very same from "Control.Exception", and the operations 43 | -- offered very similar, but here they are not limited to 'IO'. 44 | -- 45 | -- This code is in the style of both transformers and mtl, and is compatible 46 | -- with them, though doesn't mimic the module structure or offer the complete 47 | -- range of features in those packages. 48 | -- 49 | -- This is very similar to 'ErrorT' and 'MonadError', but based on features of 50 | -- "Control.Exception". In particular, it handles the complex case of 51 | -- asynchronous exceptions by including 'mask' in the typeclass. Note that the 52 | -- extensible extensions feature relies the RankNTypes language extension. 53 | -------------------------------------------------------------------- 54 | 55 | module Control.Monad.Catch ( 56 | -- * Typeclass 57 | -- $mtl 58 | MonadCatch(..) 59 | 60 | -- * Transformer 61 | -- $transformer 62 | , CatchT(..), Catch 63 | , runCatch 64 | , mapCatchT 65 | 66 | -- * Utilities 67 | -- $utilities 68 | , catchAll 69 | , catchIOError 70 | , catchJust 71 | , catchIf 72 | , Handler(..), catches 73 | , handle 74 | , handleJust 75 | , try 76 | , tryJust 77 | , onException 78 | , bracket 79 | , bracket_ 80 | , finally 81 | , bracketOnError 82 | -- * Re-exports from Control.Exception 83 | , Exception(..) 84 | , SomeException(..) 85 | ) where 86 | 87 | #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 706) 88 | import Prelude hiding (foldr) 89 | #else 90 | import Prelude hiding (catch, foldr) 91 | #endif 92 | 93 | import Control.Applicative 94 | import Control.Exception (Exception(..), SomeException(..)) 95 | import qualified Control.Exception as ControlException 96 | import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS 97 | import qualified Control.Monad.Trans.RWS.Strict as StrictRWS 98 | import qualified Control.Monad.Trans.State.Lazy as LazyS 99 | import qualified Control.Monad.Trans.State.Strict as StrictS 100 | import qualified Control.Monad.Trans.Writer.Lazy as LazyW 101 | import qualified Control.Monad.Trans.Writer.Strict as StrictW 102 | import Control.Monad.Trans.Identity 103 | import Control.Monad.Reader as Reader 104 | import Control.Monad.RWS 105 | import Data.Foldable 106 | import Data.Functor.Identity 107 | import Data.Traversable as Traversable 108 | 109 | ------------------------------------------------------------------------------ 110 | -- $mtl 111 | -- The mtl style typeclass 112 | ------------------------------------------------------------------------------ 113 | 114 | class Monad m => MonadCatch m where 115 | -- | Throw an exception. Note that this throws when this action is run in 116 | -- the monad @m@, not when it is applied. It is a generalization of 117 | -- "Control.Exception"'s 'ControlException.throwIO'. 118 | throwM :: Exception e => e -> m a 119 | 120 | -- | Provide a handler for exceptions thrown during execution of the first 121 | -- action. Note that type of the type of the argument to the handler will 122 | -- constrain which exceptions are caught. See "Control.Exception"'s 123 | -- 'ControlException.catch'. 124 | catch :: Exception e => m a -> (e -> m a) -> m a 125 | 126 | -- | Runs an action with asynchronous exceptions diabled. The action is 127 | -- provided a method for restoring the async. environment to what it was 128 | -- at the 'mask' call. See "Control.Exception"'s 'ControlException.mask'. 129 | mask :: ((forall a. m a -> m a) -> m b) -> m b 130 | 131 | instance MonadCatch IO where 132 | throwM = ControlException.throwIO 133 | catch = ControlException.catch 134 | mask = ControlException.mask 135 | 136 | instance MonadCatch m => MonadCatch (IdentityT m) where 137 | throwM e = lift $ throwM e 138 | catch (IdentityT m) f = IdentityT (catch m (runIdentityT . f)) 139 | mask a = IdentityT $ mask $ \u -> runIdentityT (a $ q u) 140 | where q u = IdentityT . u . runIdentityT 141 | 142 | instance MonadCatch m => MonadCatch (LazyS.StateT s m) where 143 | throwM e = lift $ throwM e 144 | catch = LazyS.liftCatch catch 145 | mask a = LazyS.StateT $ \s -> mask $ \u -> LazyS.runStateT (a $ q u) s 146 | where q u (LazyS.StateT b) = LazyS.StateT (u . b) 147 | 148 | instance MonadCatch m => MonadCatch (StrictS.StateT s m) where 149 | throwM e = lift $ throwM e 150 | catch = StrictS.liftCatch catch 151 | mask a = StrictS.StateT $ \s -> mask $ \u -> StrictS.runStateT (a $ q u) s 152 | where q u (StrictS.StateT b) = StrictS.StateT (u . b) 153 | 154 | instance MonadCatch m => MonadCatch (ReaderT r m) where 155 | throwM e = lift $ throwM e 156 | catch (ReaderT m) c = ReaderT $ \r -> m r `catch` \e -> runReaderT (c e) r 157 | mask a = ReaderT $ \e -> mask $ \u -> Reader.runReaderT (a $ q u) e 158 | where q u (ReaderT b) = ReaderT (u . b) 159 | 160 | instance (MonadCatch m, Monoid w) => MonadCatch (StrictW.WriterT w m) where 161 | throwM e = lift $ throwM e 162 | catch (StrictW.WriterT m) h = StrictW.WriterT $ m `catch ` \e -> StrictW.runWriterT (h e) 163 | mask a = StrictW.WriterT $ mask $ \u -> StrictW.runWriterT (a $ q u) 164 | where q u b = StrictW.WriterT $ u (StrictW.runWriterT b) 165 | 166 | instance (MonadCatch m, Monoid w) => MonadCatch (LazyW.WriterT w m) where 167 | throwM e = lift $ throwM e 168 | catch (LazyW.WriterT m) h = LazyW.WriterT $ m `catch ` \e -> LazyW.runWriterT (h e) 169 | mask a = LazyW.WriterT $ mask $ \u -> LazyW.runWriterT (a $ q u) 170 | where q u b = LazyW.WriterT $ u (LazyW.runWriterT b) 171 | 172 | instance (MonadCatch m, Monoid w) => MonadCatch (LazyRWS.RWST r w s m) where 173 | throwM e = lift $ throwM e 174 | catch (LazyRWS.RWST m) h = LazyRWS.RWST $ \r s -> m r s `catch` \e -> LazyRWS.runRWST (h e) r s 175 | mask a = LazyRWS.RWST $ \r s -> mask $ \u -> LazyRWS.runRWST (a $ q u) r s 176 | where q u (LazyRWS.RWST b) = LazyRWS.RWST $ \ r s -> u (b r s) 177 | 178 | instance (MonadCatch m, Monoid w) => MonadCatch (StrictRWS.RWST r w s m) where 179 | throwM e = lift $ throwM e 180 | catch (StrictRWS.RWST m) h = StrictRWS.RWST $ \r s -> m r s `catch` \e -> StrictRWS.runRWST (h e) r s 181 | mask a = StrictRWS.RWST $ \r s -> mask $ \u -> StrictRWS.runRWST (a $ q u) r s 182 | where q u (StrictRWS.RWST b) = StrictRWS.RWST $ \ r s -> u (b r s) 183 | 184 | ------------------------------------------------------------------------------ 185 | -- $transformer 186 | -- The @transformers@-style monad transfomer 187 | ------------------------------------------------------------------------------ 188 | 189 | -- | Add 'Exception' handling abilities to a 'Monad'. 190 | newtype CatchT m a = CatchT { runCatchT :: m (Either SomeException a) } 191 | 192 | type Catch = CatchT Identity 193 | 194 | runCatch :: Catch a -> Either SomeException a 195 | runCatch = runIdentity . runCatchT 196 | 197 | instance Monad m => Functor (CatchT m) where 198 | fmap f (CatchT m) = CatchT (liftM (fmap f) m) 199 | 200 | instance Monad m => Applicative (CatchT m) where 201 | pure a = CatchT (return (Right a)) 202 | (<*>) = ap 203 | 204 | instance Monad m => Monad (CatchT m) where 205 | return a = CatchT (return (Right a)) 206 | CatchT m >>= k = CatchT $ m >>= \ea -> case ea of 207 | Left e -> return (Left e) 208 | Right a -> runCatchT (k a) 209 | fail = CatchT . return . Left . toException . userError 210 | 211 | instance MonadFix m => MonadFix (CatchT m) where 212 | mfix f = CatchT $ mfix $ \a -> runCatchT $ f $ case a of 213 | Right r -> r 214 | _ -> error "empty mfix argument" 215 | 216 | instance Foldable m => Foldable (CatchT m) where 217 | foldMap f (CatchT m) = foldMap (foldMapEither f) m where 218 | foldMapEither g (Right a) = g a 219 | foldMapEither _ (Left _) = mempty 220 | 221 | instance (Monad m, Traversable m) => Traversable (CatchT m) where 222 | traverse f (CatchT m) = CatchT <$> Traversable.traverse (traverseEither f) m where 223 | traverseEither g (Right a) = Right <$> g a 224 | traverseEither _ (Left e) = pure (Left e) 225 | 226 | instance Monad m => Alternative (CatchT m) where 227 | empty = mzero 228 | (<|>) = mplus 229 | 230 | instance Monad m => MonadPlus (CatchT m) where 231 | mzero = CatchT $ return $ Left $ toException $ userError "" 232 | mplus (CatchT m) (CatchT n) = CatchT $ m >>= \ea -> case ea of 233 | Left _ -> n 234 | Right a -> return (Right a) 235 | 236 | instance MonadTrans CatchT where 237 | lift m = CatchT $ do 238 | a <- m 239 | return $ Right a 240 | 241 | instance MonadIO m => MonadIO (CatchT m) where 242 | liftIO m = CatchT $ do 243 | a <- liftIO m 244 | return $ Right a 245 | 246 | instance Monad m => MonadCatch (CatchT m) where 247 | throwM = CatchT . return . Left . toException 248 | catch (CatchT m) c = CatchT $ m >>= \ea -> case ea of 249 | Left e -> case fromException e of 250 | Just e' -> runCatchT (c e') 251 | Nothing -> return (Left e) 252 | Right a -> return (Right a) 253 | mask a = a id 254 | 255 | instance MonadState s m => MonadState s (CatchT m) where 256 | get = lift get 257 | put = lift . put 258 | #if MIN_VERSION_mtl(2,1,0) 259 | state = lift . state 260 | #endif 261 | 262 | instance MonadReader e m => MonadReader e (CatchT m) where 263 | ask = lift ask 264 | local f (CatchT m) = CatchT (local f m) 265 | 266 | instance MonadWriter w m => MonadWriter w (CatchT m) where 267 | tell = lift . tell 268 | listen = mapCatchT $ \ m -> do 269 | (a, w) <- listen m 270 | return $! fmap (\ r -> (r, w)) a 271 | pass = mapCatchT $ \ m -> pass $ do 272 | a <- m 273 | return $! case a of 274 | Left l -> (Left l, id) 275 | Right (r, f) -> (Right r, f) 276 | #if MIN_VERSION_mtl(2,1,0) 277 | writer aw = CatchT (Right `liftM` writer aw) 278 | #endif 279 | 280 | instance MonadRWS r w s m => MonadRWS r w s (CatchT m) 281 | 282 | -- | Map the unwrapped computation using the given function. 283 | -- 284 | -- * @'runErrorT' ('mapErrorT' f m) = f ('runErrorT' m@) 285 | mapCatchT :: (m (Either SomeException a) -> n (Either SomeException b)) 286 | -> CatchT m a 287 | -> CatchT n b 288 | mapCatchT f m = CatchT $ f (runCatchT m) 289 | 290 | ------------------------------------------------------------------------------ 291 | -- $utilities 292 | -- These functions follow those from "Control.Exception", except that they are 293 | -- based on methods from the 'MonadCatch' typeclass. See 294 | -- "Control.Exception" for API usage. 295 | ------------------------------------------------------------------------------ 296 | 297 | -- | Catches all exceptions, and somewhat defeats the purpose of the extensible 298 | -- exception system. Use sparingly. 299 | catchAll :: MonadCatch m => m a -> (SomeException -> m a) -> m a 300 | catchAll = catch 301 | 302 | -- | Catch all 'IOError' (eqv. 'IOException') exceptions. Still somewhat too 303 | -- general, but better than using 'catchAll'. See 'catchIf' for an easy way 304 | -- of catching specific 'IOError's based on the predicates in "System.IO.Error". 305 | catchIOError :: MonadCatch m => m a -> (IOError -> m a) -> m a 306 | catchIOError = catch 307 | 308 | -- | Catch exceptions only if they pass some predicate. Often useful with the 309 | -- predicates for testing 'IOError' values in "System.IO.Error". 310 | catchIf :: (MonadCatch m, Exception e) => 311 | (e -> Bool) -> m a -> (e -> m a) -> m a 312 | catchIf f a b = a `catch` \e -> if f e then b e else throwM e 313 | 314 | -- | A more generalized way of determining which exceptions to catch at 315 | -- run time. 316 | catchJust :: (MonadCatch m, Exception e) => 317 | (e -> Maybe b) -> m a -> (b -> m a) -> m a 318 | catchJust f a b = a `catch` \e -> maybe (throwM e) b $ f e 319 | 320 | -- | Flipped 'catch'. See "Control.Exception"'s 'ControlException.handle'. 321 | handle :: (MonadCatch m, Exception e) => (e -> m a) -> m a -> m a 322 | handle = flip catch 323 | {-# INLINE handle #-} 324 | 325 | -- | Flipped 'catchJust'. See "Control.Exception"'s 'ControlException.handleJust'. 326 | handleJust :: (MonadCatch m, Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a 327 | handleJust f = flip (catchJust f) 328 | {-# INLINE handleJust #-} 329 | 330 | -- | Similar to 'catch', but returns an 'Either' result. See "Control.Exception"'s 331 | -- 'Control.Exception.try'. 332 | try :: (MonadCatch m, Exception e) => m a -> m (Either e a) 333 | try a = catch (Right `liftM` a) (return . Left) 334 | 335 | -- | A variant of 'try' that takes an exception predicate to select 336 | -- which exceptions are caught. See "Control.Exception"'s 'ControlException.tryJust' 337 | tryJust :: (MonadCatch m, Exception e) => 338 | (e -> Maybe b) -> m a -> m (Either b a) 339 | tryJust f a = catch (Right `liftM` a) (\e -> maybe (throwM e) (return . Left) (f e)) 340 | 341 | -- | Generalized version of 'ControlException.Handler' 342 | data Handler m a = forall e . ControlException.Exception e => Handler (e -> m a) 343 | 344 | instance Monad m => Functor (Handler m) where 345 | fmap f (Handler h) = Handler (liftM f . h) 346 | 347 | -- | Catches different sorts of exceptions. See "Control.Exception"'s 'ControlException.catches' 348 | catches :: (Foldable f, MonadCatch m) => m a -> f (Handler m a) -> m a 349 | catches a hs = a `catch` handler 350 | where 351 | handler e = foldr probe (throwM e) hs 352 | where 353 | probe (Handler h) xs = maybe xs h (ControlException.fromException e) 354 | 355 | -- | Run an action only if an exception is thrown in the main action. The 356 | -- exception is not caught, simply rethrown. 357 | onException :: MonadCatch m => m a -> m b -> m a 358 | onException action handler = action `catchAll` \e -> handler >> throwM e 359 | 360 | -- | Generalized abstracted pattern of safe resource acquisition and release 361 | -- in the face of exceptions. The first action \"acquires\" some value, which 362 | -- is \"released\" by the second action at the end. The third action \"uses\" 363 | -- the value and its result is the result of the 'bracket'. 364 | -- 365 | -- If an exception occurs during the use, the release still happens before the 366 | -- exception is rethrown. 367 | bracket :: MonadCatch m => m a -> (a -> m b) -> (a -> m c) -> m c 368 | bracket acquire release use = mask $ \unmasked -> do 369 | resource <- acquire 370 | result <- unmasked (use resource) `onException` release resource 371 | _ <- release resource 372 | return result 373 | 374 | -- | Version of 'bracket' without any value being passed to the second and 375 | -- third actions. 376 | bracket_ :: MonadCatch m => m a -> m b -> m c -> m c 377 | bracket_ before after action = bracket before (const after) (const action) 378 | 379 | -- | Perform an action with a finalizer action that is run, even if an 380 | -- exception occurs. 381 | finally :: MonadCatch m => m a -> m b -> m a 382 | finally action finalizer = bracket_ (return ()) finalizer action 383 | 384 | -- | Like 'bracket', but only performs the final action if there was an 385 | -- exception raised by the in-between computation. 386 | bracketOnError :: MonadCatch m => m a -> (a -> m b) -> (a -> m c) -> m c 387 | bracketOnError acquire release use = mask $ \unmasked -> do 388 | resource <- acquire 389 | unmasked (use resource) `onException` release resource 390 | --------------------------------------------------------------------------------