diff --git a/Control/Exception/Extensible.hs b/Control/Exception/Extensible.hs new file mode 100644 --- /dev/null +++ b/Control/Exception/Extensible.hs @@ -0,0 +1,382 @@ + +#if __GLASGOW_HASKELL__ >= 609 +module Control.Exception.Extensible (module Control.Exception) where + +import Control.Exception + +#else +module Control.Exception.Extensible ( + Exception(..), + SomeException(..), + throwIO, + throw, + throwTo, + catch, + try, + E.block, + E.unblock, + E.evaluate, + bracket, + onException, + finally, + E.ArithException(..), + E.ArrayException(..), + AssertionFailed(..), + E.AsyncException(..), + BlockedOnDeadMVar(..), + BlockedIndefinitely(..), + NestedAtomically(..), + Deadlock(..), + ErrorCall(..), + ExitCode(..), + E.IOException, + NoMethodError(..), + NonTermination(..), + PatternMatchFail(..), + RecConError(..), + RecSelError(..), + RecUpdError(..) + ) where + +import Prelude hiding (catch) +import Control.Concurrent hiding (throwTo) +import qualified Control.Exception as E +import Data.Dynamic +import Data.Typeable +import System.Exit + +class (Typeable e, Show e) => Exception e where + toException :: e -> SomeException + fromException :: SomeException -> Maybe e + + toException = SomeException + fromException (SomeException e) = cast e + +data SomeException = forall e . Exception e => SomeException e + deriving Typeable + +instance Show SomeException where + showsPrec p (SomeException e) = showsPrec p e + +instance Exception SomeException where + toException se = se + fromException = Just + +mkOldException :: Exception e => e -> E.Exception +mkOldException e = let e' = toException e + in case fromException e' of + Just e'' -> -- If the exception is actually a legacy exception + -- then throw it directly so the legacy functions + -- catch it as they expect + e'' + Nothing -> -- Otherwise, throw it as a dynamic + E.DynException (toDyn e') + +throw :: Exception e => e -> a +throw e = E.throw (mkOldException e) + +throwIO :: Exception e => e -> IO a +throwIO e = E.throwIO (mkOldException e) + +throwTo :: Exception e => ThreadId -> e -> IO () +throwTo tid e = E.throwTo tid (mkOldException e) + +-- XXX Dyn +catch :: Exception e => IO a -> (e -> IO a) -> IO a +catch io poly_handler = io `E.catch` handler' + where + -- First look for "new style" exceptions, which are thrown + -- as E.DynException (SomeException e) + + -- needs scoped TVs: handler' :: E.Exception -> IO a + handler' e = case e of + E.DynException dyn -> + case fromDynamic dyn of + Just se@(SomeException _) -> + case fromException se of + Just e' -> poly_handler e' + Nothing -> E.throw e + Nothing -> try_old e + _ -> try_old e + + -- If it's a legacy exception (E.Exception or one of the + -- types that make up E.Exception), check for a handler than + -- can handle them: + + -- needs scoped TVs: try_old :: E.Exception -> IO a + try_old e = case fromException (toException e) of + Just e' -> poly_handler e' + Nothing -> E.throw e + + +bracket + :: IO a -- ^ computation to run first (\"acquire resource\") + -> (a -> IO b) -- ^ computation to run last (\"release resource\") + -> (a -> IO c) -- ^ computation to run in-between + -> IO c -- returns the value from the in-between computation +bracket before after thing = + E.block (do + a <- before + r <- E.unblock (thing a) `onException` after a + after a + return r + ) + +onException :: IO a -> IO b -> IO a +onException io what = io `catch` \e -> do what + throw (e :: SomeException) + +finally :: IO a -- ^ computation to run first + -> IO b -- ^ computation to run afterward (even if an exception + -- was raised) + -> IO a -- returns the value from the first computation +a `finally` sequel = + E.block (do + r <- E.unblock a `onException` sequel + sequel + return r + ) + +try :: Exception e => IO a -> IO (Either e a) +try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e)) + +---------------------------------------------------------------------- +-- Exception instance for the legacy Exception type + +instance Exception E.Exception + +---------------------------------------------------------------------- +-- The new Exception types. These need to map to/from E.Exception so +-- that uses of legacy catch/throw functions work. + +---- + +instance Exception E.ArithException where + toException ae = toException (E.ArithException ae) + fromException (SomeException e) = case cast e of + Just (E.ArithException ae) -> + Just ae + _ -> Nothing +---- + +instance Exception E.ArrayException where + toException ae = toException (E.ArrayException ae) + fromException (SomeException e) = case cast e of + Just (E.ArrayException ae) -> + Just ae + _ -> Nothing + +---- + +data AssertionFailed = AssertionFailed String + deriving Typeable + +instance Exception AssertionFailed where + toException (AssertionFailed str) = toException (E.AssertionFailed str) + fromException (SomeException e) = case cast e of + Just (E.AssertionFailed str) -> + Just (AssertionFailed str) + _ -> Nothing + +instance Show AssertionFailed where + showsPrec _ (AssertionFailed err) = showString err + +----- + +instance Exception E.AsyncException where + toException ae = toException (E.AsyncException ae) + fromException (SomeException e) = case cast e of + Just (E.AsyncException ae) -> + Just ae + _ -> Nothing + +---- + +data BlockedOnDeadMVar = BlockedOnDeadMVar + deriving Typeable + +instance Exception BlockedOnDeadMVar where + toException BlockedOnDeadMVar = toException (E.BlockedOnDeadMVar) + fromException (SomeException e) = case cast e of + Just E.BlockedOnDeadMVar -> + Just BlockedOnDeadMVar + _ -> Nothing +instance Show BlockedOnDeadMVar where + showsPrec n BlockedOnDeadMVar = showsPrec n E.BlockedOnDeadMVar + +---- + +data BlockedIndefinitely = BlockedIndefinitely + deriving Typeable + +instance Exception BlockedIndefinitely where + toException BlockedIndefinitely = toException E.BlockedIndefinitely + fromException (SomeException e) = case cast e of + Just E.BlockedIndefinitely -> + Just BlockedIndefinitely + _ -> Nothing + +instance Show BlockedIndefinitely where + showsPrec n BlockedIndefinitely = showsPrec n E.BlockedIndefinitely + +---- + +data NestedAtomically = NestedAtomically + deriving Typeable + +instance Exception NestedAtomically where + toException NestedAtomically = toException E.NestedAtomically + fromException (SomeException e) = case cast e of + Just E.NestedAtomically -> + Just NestedAtomically + _ -> Nothing + +instance Show NestedAtomically where + showsPrec n NestedAtomically = showsPrec n E.NestedAtomically + +---- + +data Deadlock = Deadlock + deriving Typeable + +instance Exception Deadlock where + toException Deadlock = toException E.Deadlock + fromException (SomeException e) = case cast e of + Just E.Deadlock -> + Just Deadlock + _ -> Nothing + +instance Show Deadlock where + showsPrec n Deadlock = showsPrec n E.Deadlock + +----- + +data ErrorCall = ErrorCall String + deriving Typeable + +instance Exception ErrorCall where + toException (ErrorCall str) = toException (E.ErrorCall str) + fromException (SomeException e) = case cast e of + Just (E.ErrorCall str) -> + Just (ErrorCall str) + _ -> Nothing + +instance Show ErrorCall where + showsPrec _ (ErrorCall err) = showString err + +----- + +instance Typeable ExitCode where + typeOf _ = mkTyConApp (mkTyCon "ExitCode") [] + +instance Exception ExitCode where + toException ee = toException (E.ExitException ee) + fromException (SomeException e) = case cast e of + Just (E.ExitException ee) -> + Just ee + _ -> Nothing +----- + +instance Exception E.IOException where + toException ioe = toException (E.IOException ioe) + fromException (SomeException e) = case cast e of + Just (E.IOException ioe) -> + Just ioe + _ -> Nothing + +---- + +data NoMethodError = NoMethodError String + deriving Typeable + +instance Exception NoMethodError where + toException (NoMethodError str) = toException (E.NoMethodError str) + fromException (SomeException e) = case cast e of + Just (E.NoMethodError str) -> + Just (NoMethodError str) + _ -> Nothing + +instance Show NoMethodError where + showsPrec _ (NoMethodError str) = showString str + +---- + +data NonTermination = NonTermination + deriving Typeable + +instance Exception NonTermination where + toException NonTermination = toException E.NonTermination + fromException (SomeException e) = case cast e of + Just E.NonTermination -> + Just NonTermination + _ -> Nothing + +instance Show NonTermination where + showsPrec n NonTermination = showsPrec n E.NonTermination + +---- + +data PatternMatchFail = PatternMatchFail String + deriving Typeable + +instance Exception PatternMatchFail where + toException (PatternMatchFail str) = toException (E.PatternMatchFail str) + fromException (SomeException e) = case cast e of + Just (E.PatternMatchFail str) -> + Just (PatternMatchFail str) + _ -> Nothing + +instance Show PatternMatchFail where + showsPrec _ (PatternMatchFail str) = showString str + + +---- + +data RecConError = RecConError String + deriving Typeable + +instance Exception RecConError where + toException (RecConError str) = toException (E.RecConError str) + fromException (SomeException e) = case cast e of + Just (E.RecConError str) -> + Just (RecConError str) + _ -> Nothing + +instance Show RecConError where + showsPrec _ (RecConError str) = showString str + + + +---- + +data RecSelError = RecSelError String + deriving Typeable + +instance Exception RecSelError where + toException (RecSelError str) = toException (E.RecSelError str) + fromException (SomeException e) = case cast e of + Just (E.RecSelError str) -> + Just (RecSelError str) + _ -> Nothing + +instance Show RecSelError where + showsPrec _ (RecSelError str) = showString str + +---- + +data RecUpdError = RecUpdError String + deriving Typeable + +instance Exception RecUpdError where + toException (RecUpdError str) = toException (E.RecUpdError str) + fromException (SomeException e) = case cast e of + Just (E.RecUpdError str) -> + Just (RecUpdError str) + _ -> Nothing + +instance Show RecUpdError where + showsPrec _ (RecUpdError str) = showString str + + +#endif + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,83 @@ +This library (libraries/extensible-exceptions) is derived from code from several +sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + + * Code from the Haskell Foreign Function Interface specification, + which is (c) Manuel M. T. Chakravarty and freely redistributable + (but see the full license for restrictions). + +The full text of these licenses is reproduced below. All of the +licenses are BSD-style or compatible. + +----------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +----------------------------------------------------------------------------- + +Code derived from the document "Report on the Programming Language +Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + +----------------------------------------------------------------------------- + +Code derived from the document "The Haskell 98 Foreign Function +Interface, An Addendum to the Haskell 98 Report" is distributed under +the following license: + + Copyright (c) 2002 Manuel M. T. Chakravarty + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Foreign Function Interface. + +----------------------------------------------------------------------------- diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/extensible-exceptions.cabal b/extensible-exceptions.cabal new file mode 100644 --- /dev/null +++ b/extensible-exceptions.cabal @@ -0,0 +1,20 @@ +name: extensible-exceptions +version: 0.1.0.1 +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +synopsis: Extensible exceptions +description: + Extensible exceptions for old implementations (e.g. GHC < 6.10). + This package is being lazily implemented, i.e. not all the new + exception types or all the exception functions are necessarily + implemented yet. +cabal-version: >=1.2 +build-type: Simple + +Library { + build-depends: base + exposed-modules: + Control.Exception.Extensible + extensions: CPP, ExistentialQuantification, DeriveDataTypeable +}