diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,1 @@ +:set -isrc -idist/build/autogen -optPdist/build/autogen/cabal_macros.h diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,13 @@ +dist +docs +wiki +TAGS +tags +wip +.DS_Store +.*.swp +.*.swo +*.o +*.hi +*~ +*# diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,26 @@ +language: haskell +before_install: + # Uncomment whenever hackage is down. + # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update + - cabal update + + # Try installing some of the build-deps with apt-get for speed. + - travis/cabal-apt-install $mode + +install: + - cabal configure -flib-Werror $mode + - cabal build + +script: + - $script && hlint src --cpp-define HLINT + +notifications: + irc: + channels: + - "irc.freenode.org#haskell-lens" + skip_join: true + template: + - "\x0313exceptions\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" + +env: + - mode="--enable-tests" script="cabal test --show-details=always" diff --git a/.vim.custom b/.vim.custom new file mode 100644 --- /dev/null +++ b/.vim.custom @@ -0,0 +1,31 @@ +" Add the following to your .vimrc to automatically load this on startup + +" if filereadable(".vim.custom") +" so .vim.custom +" endif + +function StripTrailingWhitespace() + let myline=line(".") + let mycolumn = col(".") + silent %s/ *$// + call cursor(myline, mycolumn) +endfunction + +" enable syntax highlighting +syntax on + +" search for the tags file anywhere between here and / +set tags=TAGS;/ + +" highlight tabs and trailing spaces +set listchars=tab:‗‗,trail:‗ +set list + +" f2 runs hasktags +map :exec ":!hasktags -x -c --ignore src" + +" strip trailing whitespace before saving +" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() + +" rebuild hasktags after saving +au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" diff --git a/AUTHORS.markdown b/AUTHORS.markdown new file mode 100644 --- /dev/null +++ b/AUTHORS.markdown @@ -0,0 +1,1 @@ +`exceptions` is based on code contributed by [Mark Lentzcner](http://github.com/mzero). diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,3 @@ +0.1 +--- +* Repository initialized diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + +TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + +1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + +2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + +3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + +4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + +5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + +6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + +7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + +8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + +9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + +END OF TERMS AND CONDITIONS + +APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + +Copyright [yyyy] [name of copyright owner] + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,15 @@ +exceptions +========== + +[![Build Status](https://secure.travis-ci.org/ekmett/exceptions.png?branch=master)](http://travis-ci.org/ekmett/exceptions) + +This package provides (optionally pure) extensible exceptions that are compatible with the monad transformer library. + +Contact Information +------------------- + +Contributions and bug reports are welcome! + +Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. + +-Edward Kmett diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/runhaskell +> module Main (main) where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/exceptions.cabal b/exceptions.cabal new file mode 100644 --- /dev/null +++ b/exceptions.cabal @@ -0,0 +1,58 @@ +name: exceptions +category: Control, Exceptions, Monad +version: 0.1 +cabal-version: >= 1.8 +license: OtherLicense +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett +stability: provisional +homepage: http://github.com/ekmett/exceptions/ +bug-reports: http://github.com/ekmett/exceptions/issues +copyright: Copyright (C) 2013 Edward A. Kmett + Copyright (C) 2012 Google Inc. +build-type: Simple +tested-with: GHC == 7.4.1, GHC == 7.6.1 +synopsis: Extensible optionally-pure exceptions +description: Extensible optionally-pure exceptions + +extra-source-files: + .travis.yml + .ghci + .gitignore + .vim.custom + travis/cabal-apt-install + travis/config + AUTHORS.markdown + README.markdown + CHANGELOG.markdown + +source-repository head + type: git + location: git://github.com/ekmett/exceptions.git + +library + build-depends: + base >= 4.3 && < 5, + transformers >= 0.2 && < 0.4, + mtl >= 2.0 && < 2.2 + + exposed-modules: + Control.Monad.Catch + + ghc-options: -Wall -fwarn-tabs -O2 + hs-source-dirs: src + +test-suite exceptions-tests + main-is: Tests.hs + hs-source-dirs: src, tests + ghc-options: -Wall -fwarn-tabs + type: exitcode-stdio-1.0 + build-depends: + base >= 4.3 && < 5, + transformers >= 0.2 && < 0.4, + mtl >= 2.0 && < 2.2, + + test-framework >= 0.8 && < 0.9, + test-framework-quickcheck2 >= 0.3 && < 0.4, + QuickCheck >= 2.5 && < 2.6 diff --git a/src/Control/Monad/Catch.hs b/src/Control/Monad/Catch.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Catch.hs @@ -0,0 +1,389 @@ +{- +Copyright 2012 Google Inc. All Rights Reserved. + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +#ifndef MIN_VERSION_transformers +#define MIN_VERSION_transformers(x,y,z) 1 +#endif + +#ifndef MIN_VERSION_mtl +#define MIN_VERSION_mtl(x,y,z) 1 +#endif + +-------------------------------------------------------------------- +-- | +-- Copyright : (c) Edward Kmett 2013, (c) Google Inc. 2012 +-- License : BSD3 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +-- This module supports monads that can throw extensible exceptions. The +-- exceptions are the very same from "Control.Exception", and the operations +-- offered very similar, but here they are not limited to 'IO'. +-- +-- This code is in the style of both transformers and mtl, and is compatible +-- with them, though doesn't mimic the module structure or offer the complete +-- range of features in those packages. +-- +-- This is very similar to 'ErrorT' and 'MonadError', but based on features of +-- "Control.Exception". In particular, it handles the complex case of +-- asynchronous exceptions by including 'mask' in the typeclass. Note that the +-- extensible extensions feature relies the RankNTypes language extension. +-------------------------------------------------------------------- + +module Control.Monad.Catch ( + -- * Typeclass + -- $mtl + MonadCatch(..) + + -- * Transformer + -- $transformer + , CatchT(..), Catch + , runCatch + , mapCatchT + + -- * Utilities + -- $utilities + , catchAll + , catchIOError + , catchJust + , catchIf + , Handler(..), catches + , handle + , handleJust + , try + , tryJust + , onException + , bracket + , bracket_ + , finally + , bracketOnError + -- * Re-exports from Control.Exception + , Exception(..) + , SomeException(..) + ) where + +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 706) +import Prelude hiding (foldr) +#else +import Prelude hiding (catch, foldr) +#endif + +import Control.Applicative +import Control.Exception (Exception(..), SomeException(..)) +import qualified Control.Exception as ControlException +import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS +import qualified Control.Monad.Trans.RWS.Strict as StrictRWS +import qualified Control.Monad.Trans.State.Lazy as LazyS +import qualified Control.Monad.Trans.State.Strict as StrictS +import qualified Control.Monad.Trans.Writer.Lazy as LazyW +import qualified Control.Monad.Trans.Writer.Strict as StrictW +import Control.Monad.Trans.Identity +import Control.Monad.Reader as Reader +import Control.Monad.RWS +import Data.Foldable +import Data.Functor.Identity +import Data.Traversable as Traversable + +------------------------------------------------------------------------------ +-- $mtl +-- The mtl style typeclass +------------------------------------------------------------------------------ + +class Monad m => MonadCatch m where + -- | Throw an exception. Note that this throws when this action is run in + -- the monad @m@, not when it is applied. It is a generalization of + -- "Control.Exception"'s 'ControlException.throwIO'. + throwM :: Exception e => e -> m a + + -- | Provide a handler for exceptions thrown during execution of the first + -- action. Note that type of the type of the argument to the handler will + -- constrain which exceptions are caught. See "Control.Exception"'s + -- 'ControlException.catch'. + catch :: Exception e => m a -> (e -> m a) -> m a + + -- | Runs an action with asynchronous exceptions diabled. The action is + -- provided a method for restoring the async. environment to what it was + -- at the 'mask' call. See "Control.Exception"'s 'ControlException.mask'. + mask :: ((forall a. m a -> m a) -> m b) -> m b + +instance MonadCatch IO where + throwM = ControlException.throwIO + catch = ControlException.catch + mask = ControlException.mask + +instance MonadCatch m => MonadCatch (IdentityT m) where + throwM e = lift $ throwM e + catch (IdentityT m) f = IdentityT (catch m (runIdentityT . f)) + mask a = IdentityT $ mask $ \u -> runIdentityT (a $ q u) + where q u = IdentityT . u . runIdentityT + +instance MonadCatch m => MonadCatch (LazyS.StateT s m) where + throwM e = lift $ throwM e + catch = LazyS.liftCatch catch + mask a = LazyS.StateT $ \s -> mask $ \u -> LazyS.runStateT (a $ q u) s + where q u (LazyS.StateT b) = LazyS.StateT (u . b) + +instance MonadCatch m => MonadCatch (StrictS.StateT s m) where + throwM e = lift $ throwM e + catch = StrictS.liftCatch catch + mask a = StrictS.StateT $ \s -> mask $ \u -> StrictS.runStateT (a $ q u) s + where q u (StrictS.StateT b) = StrictS.StateT (u . b) + +instance MonadCatch m => MonadCatch (ReaderT r m) where + throwM e = lift $ throwM e + catch (ReaderT m) c = ReaderT $ \r -> m r `catch` \e -> runReaderT (c e) r + mask a = ReaderT $ \e -> mask $ \u -> Reader.runReaderT (a $ q u) e + where q u (ReaderT b) = ReaderT (u . b) + +instance (MonadCatch m, Monoid w) => MonadCatch (StrictW.WriterT w m) where + throwM e = lift $ throwM e + catch (StrictW.WriterT m) h = StrictW.WriterT $ m `catch ` \e -> StrictW.runWriterT (h e) + mask a = StrictW.WriterT $ mask $ \u -> StrictW.runWriterT (a $ q u) + where q u b = StrictW.WriterT $ u (StrictW.runWriterT b) + +instance (MonadCatch m, Monoid w) => MonadCatch (LazyW.WriterT w m) where + throwM e = lift $ throwM e + catch (LazyW.WriterT m) h = LazyW.WriterT $ m `catch ` \e -> LazyW.runWriterT (h e) + mask a = LazyW.WriterT $ mask $ \u -> LazyW.runWriterT (a $ q u) + where q u b = LazyW.WriterT $ u (LazyW.runWriterT b) + +instance (MonadCatch m, Monoid w) => MonadCatch (LazyRWS.RWST r w s m) where + throwM e = lift $ throwM e + catch (LazyRWS.RWST m) h = LazyRWS.RWST $ \r s -> m r s `catch` \e -> LazyRWS.runRWST (h e) r s + mask a = LazyRWS.RWST $ \r s -> mask $ \u -> LazyRWS.runRWST (a $ q u) r s + where q u (LazyRWS.RWST b) = LazyRWS.RWST $ \ r s -> u (b r s) + +instance (MonadCatch m, Monoid w) => MonadCatch (StrictRWS.RWST r w s m) where + throwM e = lift $ throwM e + catch (StrictRWS.RWST m) h = StrictRWS.RWST $ \r s -> m r s `catch` \e -> StrictRWS.runRWST (h e) r s + mask a = StrictRWS.RWST $ \r s -> mask $ \u -> StrictRWS.runRWST (a $ q u) r s + where q u (StrictRWS.RWST b) = StrictRWS.RWST $ \ r s -> u (b r s) + +------------------------------------------------------------------------------ +-- $transformer +-- The @transformers@-style monad transfomer +------------------------------------------------------------------------------ + +-- | Add 'Exception' handling abilities to a 'Monad'. +newtype CatchT m a = CatchT { runCatchT :: m (Either SomeException a) } + +type Catch = CatchT Identity + +runCatch :: Catch a -> Either SomeException a +runCatch = runIdentity . runCatchT + +instance Monad m => Functor (CatchT m) where + fmap f (CatchT m) = CatchT (liftM (fmap f) m) + +instance Monad m => Applicative (CatchT m) where + pure a = CatchT (return (Right a)) + (<*>) = ap + +instance Monad m => Monad (CatchT m) where + return a = CatchT (return (Right a)) + CatchT m >>= k = CatchT $ m >>= \ea -> case ea of + Left e -> return (Left e) + Right a -> runCatchT (k a) + fail = CatchT . return . Left . toException . userError + +instance MonadFix m => MonadFix (CatchT m) where + mfix f = CatchT $ mfix $ \a -> runCatchT $ f $ case a of + Right r -> r + _ -> error "empty mfix argument" + +instance Foldable m => Foldable (CatchT m) where + foldMap f (CatchT m) = foldMap (foldMapEither f) m where + foldMapEither g (Right a) = g a + foldMapEither _ (Left _) = mempty + +instance (Monad m, Traversable m) => Traversable (CatchT m) where + traverse f (CatchT m) = CatchT <$> Traversable.traverse (traverseEither f) m where + traverseEither g (Right a) = Right <$> g a + traverseEither _ (Left e) = pure (Left e) + +instance Monad m => Alternative (CatchT m) where + empty = mzero + (<|>) = mplus + +instance Monad m => MonadPlus (CatchT m) where + mzero = CatchT $ return $ Left $ toException $ userError "" + mplus (CatchT m) (CatchT n) = CatchT $ m >>= \ea -> case ea of + Left _ -> n + Right a -> return (Right a) + +instance MonadTrans CatchT where + lift m = CatchT $ do + a <- m + return $ Right a + +instance MonadIO m => MonadIO (CatchT m) where + liftIO m = CatchT $ do + a <- liftIO m + return $ Right a + +instance Monad m => MonadCatch (CatchT m) where + throwM = CatchT . return . Left . toException + catch (CatchT m) c = CatchT $ m >>= \ea -> case ea of + Left e -> case fromException e of + Just e' -> runCatchT (c e') + Nothing -> return (Left e) + Right a -> return (Right a) + mask a = a id + +instance MonadState s m => MonadState s (CatchT m) where + get = lift get + put = lift . put +#if MIN_VERSION_mtl(2,1,0) + state = lift . state +#endif + +instance MonadReader e m => MonadReader e (CatchT m) where + ask = lift ask + local f (CatchT m) = CatchT (local f m) + +instance MonadWriter w m => MonadWriter w (CatchT m) where + tell = lift . tell + listen = mapCatchT $ \ m -> do + (a, w) <- listen m + return $! fmap (\ r -> (r, w)) a + pass = mapCatchT $ \ m -> pass $ do + a <- m + return $! case a of + Left l -> (Left l, id) + Right (r, f) -> (Right r, f) +#if MIN_VERSION_mtl(2,1,0) + writer aw = CatchT (Right `liftM` writer aw) +#endif + +instance MonadRWS r w s m => MonadRWS r w s (CatchT m) + +-- | Map the unwrapped computation using the given function. +-- +-- * @'runErrorT' ('mapErrorT' f m) = f ('runErrorT' m@) +mapCatchT :: (m (Either SomeException a) -> n (Either SomeException b)) + -> CatchT m a + -> CatchT n b +mapCatchT f m = CatchT $ f (runCatchT m) + +------------------------------------------------------------------------------ +-- $utilities +-- These functions follow those from "Control.Exception", except that they are +-- based on methods from the 'MonadCatch' typeclass. See +-- "Control.Exception" for API usage. +------------------------------------------------------------------------------ + +-- | Catches all exceptions, and somewhat defeats the purpose of the extensible +-- exception system. Use sparingly. +catchAll :: MonadCatch m => m a -> (SomeException -> m a) -> m a +catchAll = catch + +-- | Catch all 'IOError' (eqv. 'IOException') exceptions. Still somewhat too +-- general, but better than using 'catchAll'. See 'catchIf' for an easy way +-- of catching specific 'IOError's based on the predicates in "System.IO.Error". +catchIOError :: MonadCatch m => m a -> (IOError -> m a) -> m a +catchIOError = catch + +-- | Catch exceptions only if they pass some predicate. Often useful with the +-- predicates for testing 'IOError' values in "System.IO.Error". +catchIf :: (MonadCatch m, Exception e) => + (e -> Bool) -> m a -> (e -> m a) -> m a +catchIf f a b = a `catch` \e -> if f e then b e else throwM e + +-- | A more generalized way of determining which exceptions to catch at +-- run time. +catchJust :: (MonadCatch m, Exception e) => + (e -> Maybe b) -> m a -> (b -> m a) -> m a +catchJust f a b = a `catch` \e -> maybe (throwM e) b $ f e + +-- | Flipped 'catch'. See "Control.Exception"'s 'ControlException.handle'. +handle :: (MonadCatch m, Exception e) => (e -> m a) -> m a -> m a +handle = flip catch +{-# INLINE handle #-} + +-- | Flipped 'catchJust'. See "Control.Exception"'s 'ControlException.handleJust'. +handleJust :: (MonadCatch m, Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a +handleJust f = flip (catchJust f) +{-# INLINE handleJust #-} + +-- | Similar to 'catch', but returns an 'Either' result. See "Control.Exception"'s +-- 'Control.Exception.try'. +try :: (MonadCatch m, Exception e) => m a -> m (Either e a) +try a = catch (Right `liftM` a) (return . Left) + +-- | A variant of 'try' that takes an exception predicate to select +-- which exceptions are caught. See "Control.Exception"'s 'ControlException.tryJust' +tryJust :: (MonadCatch m, Exception e) => + (e -> Maybe b) -> m a -> m (Either b a) +tryJust f a = catch (Right `liftM` a) (\e -> maybe (throwM e) (return . Left) (f e)) + +-- | Generalized version of 'ControlException.Handler' +data Handler m a = forall e . ControlException.Exception e => Handler (e -> m a) + +instance Monad m => Functor (Handler m) where + fmap f (Handler h) = Handler (liftM f . h) + +-- | Catches different sorts of exceptions. See "Control.Exception"'s 'ControlException.catches' +catches :: (Foldable f, MonadCatch m) => m a -> f (Handler m a) -> m a +catches a hs = a `catch` handler + where + handler e = foldr probe (throwM e) hs + where + probe (Handler h) xs = maybe xs h (ControlException.fromException e) + +-- | Run an action only if an exception is thrown in the main action. The +-- exception is not caught, simply rethrown. +onException :: MonadCatch m => m a -> m b -> m a +onException action handler = action `catchAll` \e -> handler >> throwM e + +-- | Generalized abstracted pattern of safe resource acquisition and release +-- in the face of exceptions. The first action \"acquires\" some value, which +-- is \"released\" by the second action at the end. The third action \"uses\" +-- the value and its result is the result of the 'bracket'. +-- +-- If an exception occurs during the use, the release still happens before the +-- exception is rethrown. +bracket :: MonadCatch m => m a -> (a -> m b) -> (a -> m c) -> m c +bracket acquire release use = mask $ \unmasked -> do + resource <- acquire + result <- unmasked (use resource) `onException` release resource + _ <- release resource + return result + +-- | Version of 'bracket' without any value being passed to the second and +-- third actions. +bracket_ :: MonadCatch m => m a -> m b -> m c -> m c +bracket_ before after action = bracket before (const after) (const action) + +-- | Perform an action with a finalizer action that is run, even if an +-- exception occurs. +finally :: MonadCatch m => m a -> m b -> m a +finally action finalizer = bracket_ (return ()) finalizer action + +-- | Like 'bracket', but only performs the final action if there was an +-- exception raised by the in-between computation. +bracketOnError :: MonadCatch m => m a -> (a -> m b) -> (a -> m c) -> m c +bracketOnError acquire release use = mask $ \unmasked -> do + resource <- acquire + unmasked (use resource) `onException` release resource diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,10 @@ +module Main where + +import Test.Framework (defaultMain) + +import qualified Control.Monad.Catch.Tests + +main :: IO () +main = defaultMain + [ Control.Monad.Catch.Tests.tests + ] diff --git a/travis/cabal-apt-install b/travis/cabal-apt-install new file mode 100644 --- /dev/null +++ b/travis/cabal-apt-install @@ -0,0 +1,27 @@ +#! /bin/bash +set -eu + +APT="sudo apt-get -q -y" +CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" + +$APT update +$APT install dctrl-tools + +# Find potential system packages to satisfy cabal dependencies +deps() +{ + local M='^\([^ ]\+\)-[0-9.]\+ (.*$' + local G=' -o ( -FPackage -X libghc-\L\1\E-dev )' + local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \ + | sed -ne "s/$M/$G/p" | sort -u)" + grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u +} + +$APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special +$CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage + +if ! $APT install hlint ; then + $APT install $(deps hlint) + cabal install hlint +fi + diff --git a/travis/config b/travis/config new file mode 100644 --- /dev/null +++ b/travis/config @@ -0,0 +1,16 @@ +-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix +-- +-- This is particularly useful for travis-ci to get it to stop complaining +-- about a broken build when everything is still correct on our end. +-- +-- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead +-- +-- To enable this, uncomment the before_script in .travis.yml + +remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive +remote-repo-cache: ~/.cabal/packages +world-file: ~/.cabal/world +build-summary: ~/.cabal/logs/build.log +remote-build-reporting: anonymous +install-dirs user +install-dirs global