Nabble - Haskell

{-# LANGUAGE ExistentialQuantification, Rank2Types, UnboxedTuples,

             DeriveDataTypeable, MagicHash #-}

module NewException (

    Exception(..), SomeException(..),

    throwIO, throw, ioError, throwTo,

    catch, catches, Handler(..), catchAny, catchJust,

    handle, handleAny, handleJust,

    try, tryJust, ignoreExceptions,

    evaluate, mapException, block, unblock, assert,

    bracket, bracket_, bracketOnError, finally,

    ) where

import Data.Typeable (Typeable, cast)

import GHC.Base (raise#, catch#, raiseIO#,

                 blockAsyncExceptions#, unblockAsyncExceptions#)

import GHC.IOBase (IO(IO), unIO, IOException)

import GHC.Conc (ThreadId)

import Prelude (Show(show), ($), Maybe(..), undefined, foldr, IOError,

                flip, seq, Either(..), Monad(..), const, Bool)

import System.IO.Unsafe (unsafePerformIO)

----------------------------------------------------------------------

-- The Extensible Exceptions library

data SomeException = forall e . Exception e => SomeException e

    deriving Typeable

instance Show SomeException where

    show (SomeException e) = show e

class (Typeable e, Show e) => Exception e where

    toException   :: e -> SomeException

    fromException :: SomeException -> Maybe e

    toException = SomeException

    fromException (SomeException e) = cast e

instance Exception SomeException where

    toException se = se

    fromException = Just

instance Exception IOException

throw :: Exception e => e -> a

throw e = raise# (toException e)

catch :: Exception e => IO a -> (e -> IO a) -> IO a

catch (IO io) handler = IO $ catch# io handler'

    where handler' e = case fromException e of

                       Just e' -> unIO (handler e')

                       Nothing -> raise# e

catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a

catchAny (IO io) handler = IO $ catch# io handler'

    where handler' (SomeException e) = unIO (handler e)

throwIO :: Exception e => e -> IO a

throwIO e = IO (raiseIO# (toException e))

ioError         :: IOError -> IO a

ioError         =  throwIO

throwTo :: Exception e => ThreadId -> e -> IO ()

throwTo = undefined

catches :: IO a -> [Handler a] -> IO a

catches io handlers = io `catch` catchesHandler handlers

catchesHandler :: [Handler a] -> SomeException -> IO a

catchesHandler handlers e = foldr tryHandler (throw e) handlers

    where tryHandler (Handler handler) res

              = case fromException e of

                Just e' -> handler e'

                Nothing -> res

data Handler a = forall e . Exception e => Handler (e -> IO a)

catchJust

        :: Exception e

        => (e -> Maybe b)         -- ^ Predicate to select exceptions

        -> IO a                   -- ^ Computation to run

        -> (b -> IO a)            -- ^ Handler

        -> IO a

catchJust p a handler = catch a handler'

  where handler' e = case p e of

                        Nothing -> throw e

                        Just b  -> handler b

handle     :: Exception e => (e -> IO a) -> IO a -> IO a

handle     =  flip catch

handleAny  :: (forall e . Exception e => e -> IO a) -> IO a -> IO a

handleAny  =  flip catchAny

handleJust :: Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a

handleJust p =  flip (catchJust p)

mapException :: Exception e => (e -> e) -> a -> a

mapException f v = unsafePerformIO (catch (evaluate v)

                                          (\x -> throw (f x)))

evaluate :: a -> IO a

evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #)

try :: Exception e => IO a -> IO (Either e a)

try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))

tryJust :: Exception e => (e -> Maybe b) -> IO a -> IO (Either b a)

tryJust p a = do

  r <- try a

  case r of

        Right v -> return (Right v)

        Left  e -> case p e of

                        Nothing -> throw e

                        Just b  -> return (Left b)

ignoreExceptions :: IO () -> IO ()

ignoreExceptions io = io `catchAny` \_ -> return ()

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 =

  block (do

    a <- before 

    r <- catchAny

           (unblock (thing a))

           (\e -> do { after a; throw e })

    after a

    return r

 )

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 =

  block (do

    r <- catchAny

             (unblock a)

             (\e -> do { sequel; throw e })

    sequel

    return r

  )

bracket_ :: IO a -> IO b -> IO c -> IO c

bracket_ before after thing = bracket before (const after) (const thing)

bracketOnError

        :: 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

bracketOnError before after thing =

  block (do

    a <- before

    catchAny

        (unblock (thing a))

        (\e -> do { after a; throw e })

 )

block :: IO a -> IO a

block (IO io) = IO $ blockAsyncExceptions# io

unblock :: IO a -> IO a

unblock (IO io) = IO $ unblockAsyncExceptions# io

assert :: Bool -> a -> a

assert _ r = r

Nabble - Haskell

Re: [GHC] #2146: Decomposition rule for equalities is too weak in case of higher-kinded type families

Re: [GHC] #2418: desugaring type function application to constraint makes bug disappear

Re: FPGA / Lava and haskell

Re: FPGA / Lava and haskell

Re: Qualified import syntax badly designed (?)

FPGA / Lava and haskell

[GHC] #2429: error building full dll name to be loaded in ghci

Qualified import syntax badly designed (?)

Re: Re: Interesting feature

Re: Proposal: Extensible exceptions

Re: [GHC] #2146: Decomposition rule for equalities is too weak in case of higher-kinded type families

Re: Re: What is a rigid type variable?

Re: What is a rigid type variable?

Re: on starting Haskell-Edu, a new education-related Haskell-related mailing list

Re: more database issues

Re: data Color3 a = Color3 !a !a !a

Re: Cabal and external dependencies

Re: data Color3 a = Color3 !a !a !a

Cabal and external dependencies

Re: [GHC] #2411: RaiseAsync and STM segfault with stop_at_atomically in some circumstances.

Re: Re[2]: Proposal: Extensible exceptions

Re: Re[2]: Proposal: Extensible exceptions

Re: Re[2]: Proposal: Extensible exceptions

Re[2]: Proposal: Extensible exceptions

Re[2]: Proposal: Extensible exceptions

Re[2]: Proposal: Extensible exceptions

Re: Swapping Monads

Re: more database issues

Re: Associative Commutative Unification

Re: extensible data types in Haskell?

Re: Associative Commutative Unification

ANN: Uniplate 1.2

Re: data Color3 a = Color3 !a !a !a

data Color3 a = Color3 !a !a !a

Re: Interesting feature