[project @ 2002-11-08 09:04:35 by simonpj]

[ghc-base.git] / Control / Exception.hs

diff --git a/Control/Exception.hs b/Control/Exception.hs
index be7595e..5b653e2 100644 (file)
--- a/Control/Exception.hs
+++ b/Control/Exception.hs
@@ -17,15 +17,21 @@ module Control.Exception (
 
        -- * The Exception type
        Exception(..),          -- instance Eq, Ord, Show, Typeable
+#ifdef __GLASGOW_HASKELL__
        IOException,            -- instance Eq, Ord, Show, Typeable
        ArithException(..),     -- instance Eq, Ord, Show, Typeable
        ArrayException(..),     -- instance Eq, Ord, Show, Typeable
        AsyncException(..),     -- instance Eq, Ord, Show, Typeable
+#endif
 
        -- * Throwing exceptions
+#ifdef __HUGS__
+       throwIO,        -- :: Exception -> IO a
+#else
        throw,          -- :: Exception -> a
        ioError,        -- :: Exception -> IO a
        throwTo,        -- :: ThreadId -> Exception -> a
+#endif
 
        -- * Catching Exceptions
 
@@ -53,19 +59,23 @@ module Control.Exception (
        -- $preds
 
        ioErrors,               -- :: Exception -> Maybe IOError
+#ifndef __HUGS__
        arithExceptions,        -- :: Exception -> Maybe ArithException
        errorCalls,             -- :: Exception -> Maybe String
        dynExceptions,          -- :: Exception -> Maybe Dynamic
        assertions,             -- :: Exception -> Maybe String
        asyncExceptions,        -- :: Exception -> Maybe AsyncException
+#endif /* __HUGS__ */
        userErrors,             -- :: Exception -> Maybe String
 
+#ifdef __GLASGOW_HASKELL__
        -- * Dynamic exceptions
 
        -- $dynamic
        throwDyn,       -- :: Typeable ex => ex -> b
        throwDynTo,     -- :: Typeable ex => ThreadId -> ex -> b
        catchDyn,       -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a
+#endif
        
        -- * Asynchronous Exceptions
 
@@ -101,33 +111,34 @@ module Control.Exception (
   ) where
 
 #ifdef __GLASGOW_HASKELL__
-import Prelude                 hiding (catch)
-import System.IO.Error
 import GHC.Base                ( assert )
-import GHC.Exception   hiding (try, catch, bracket, bracket_)
+import GHC.Exception   as ExceptionBase hiding (try, catch, bracket, bracket_)
 import GHC.Conc                ( throwTo, ThreadId )
 import GHC.IOBase      ( IO(..) )
 #endif
 
 #ifdef __HUGS__
-import Prelude hiding ( catch )
-import PrelPrim        ( catchException 
-               , Exception(..)
-               , throw
-               , ArithException(..)
-               , AsyncException(..)
-               , assert
-               )
+import Hugs.Exception  as ExceptionBase
 #endif
 
+import Prelude                 hiding ( catch )
+import System.IO.Error
 import Data.Dynamic
 
 #include "Dynamic.h"
 INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
+#ifdef __GLASGOW_HASKELL__
 INSTANCE_TYPEABLE0(IOException,ioExceptionTc,"IOException")
 INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")
 INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException")
 INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")
+#endif
+
+#ifdef __HUGS__
+-- This is as close as Hugs gets to providing throw
+throw :: Exception -> IO a
+throw = throwIO
+#endif
 
 -----------------------------------------------------------------------------
 -- Catching exceptions
@@ -174,7 +185,7 @@ INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")
 catch          :: IO a                 -- ^ The computation to run
        -> (Exception -> IO a)  -- ^ Handler to invoke if an exception is raised
        -> IO a                 
-catch =  GHC.Exception.catchException
+catch =  ExceptionBase.catchException
 
 -- | The function 'catchJust' is like 'catch', but it takes an extra
 -- argument which is an /exception predicate/, a function which
@@ -223,10 +234,14 @@ handleJust p =  flip (catchJust p)
 --
 -- NOTE: @(evaluate a)@ is /not/ the same as @(a \`seq\` return a)@.
 evaluate :: a -> IO a
+#if defined(__GLASGOW_HASKELL__)
 evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #)
        -- NB. can't write  
        --      a `seq` (# s, a #)
        -- because we can't have an unboxed tuple as a function argument
+#elif defined(__HUGS__)
+evaluate a = a `seq` return a  -- dummy implementation: to be fixed
+#endif
 
 -----------------------------------------------------------------------------
 -- 'try' and variations.
@@ -256,11 +271,12 @@ tryJust p a = do
                        Nothing -> throw e
                        Just b  -> return (Left b)
 
+#ifdef __GLASGOW_HASKELL__
 -----------------------------------------------------------------------------
 -- Dynamic exceptions
 
 -- $dynamic
--- Because the 'Exception' datatype is not extensible, there is an
+--  #DynamicExceptions# Because the 'Exception' datatype is not extensible, there is an
 -- interface for throwing and catching exceptions of type 'Dynamic'
 -- (see "Data.Dynamic") which allows exception values of any type in
 -- the 'Typeable' class to be thrown and caught.
@@ -291,6 +307,7 @@ catchDyn m k = catchException m handle
                                    Just exception  -> k exception
                                    Nothing -> throw ex
                           _ -> throw ex
+#endif /* __GLASGOW_HASKELL__ */
 
 -----------------------------------------------------------------------------
 -- Exception Predicates
@@ -300,6 +317,7 @@ catchDyn m k = catchException m handle
 -- 'catchJust', 'tryJust', or 'handleJust' to select certain common
 -- classes of exceptions.
 
+#ifdef __GLASGOW_HASKELL__
 ioErrors               :: Exception -> Maybe IOError
 arithExceptions        :: Exception -> Maybe ArithException
 errorCalls             :: Exception -> Maybe String
@@ -307,7 +325,9 @@ dynExceptions               :: Exception -> Maybe Dynamic
 assertions             :: Exception -> Maybe String
 asyncExceptions        :: Exception -> Maybe AsyncException
 userErrors             :: Exception -> Maybe String
+#endif /* __GLASGOW_HASKELL__ */
 
+#ifdef __GLASGOW_HASKELL__
 ioErrors e@(IOException _) = Just e
 ioErrors _ = Nothing
 
@@ -326,8 +346,9 @@ dynExceptions _ = Nothing
 asyncExceptions (AsyncException e) = Just e
 asyncExceptions _ = Nothing
 
-userErrors e | isUserError e = Just (ioeGetErrorString e)
+userErrors e@IOException{} | isUserError e = Just (ioeGetErrorString e)
 userErrors _ = Nothing
+#endif /* __GLASGOW_HASKELL__ */
 
 -----------------------------------------------------------------------------
 -- Some Useful Functions
@@ -393,7 +414,7 @@ bracket_ before after thing = bracket before (const after) (const thing)
 
 {- $async
 
-Asynchronous exceptions are so-called because they arise due to
+ #AsynchronousExceptions# Asynchronous exceptions are so-called because they arise due to
 external influences, and can be raised at any point during execution.
 'StackOverflow' and 'HeapOverflow' are two examples of
 system-generated asynchronous exceptions.
@@ -478,3 +499,9 @@ Similar arguments apply for other interruptible operations like
 -- returned as the result.
 assert :: Bool -> a -> a
 #endif
+
+#ifndef __GLASGOW_HASKELL__
+assert :: Bool -> a -> a
+assert True x = x
+assert False _ = error "Assertion failure"
+#endif