From a458251c451c74752517d50253d8ea4cb8afe253 Mon Sep 17 00:00:00 2001 From: ross Date: Thu, 23 Jan 2003 17:45:42 +0000 Subject: [PATCH] [project @ 2003-01-23 17:45:40 by ross] Hugs now uses most of Control.Exception. --- Control/Concurrent/MVar.hs | 7 ------- Control/Exception.hs | 32 +++++++------------------------- Data/Dynamic.hs | 9 ++++++++- System/Exit.hs | 14 ++++++++------ 4 files changed, 23 insertions(+), 39 deletions(-) diff --git a/Control/Concurrent/MVar.hs b/Control/Concurrent/MVar.hs index 4dfac5a..ea037ba 100644 --- a/Control/Concurrent/MVar.hs +++ b/Control/Concurrent/MVar.hs @@ -37,7 +37,6 @@ module Control.Concurrent.MVar import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar, tryTakeMVar, tryPutMVar, isEmptyMVar, ) -import Hugs.Exception ( throwIO ) #endif #ifdef __GLASGOW_HASKELL__ @@ -49,12 +48,6 @@ import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar, import Prelude import Control.Exception as Exception -#ifdef __HUGS__ --- This is as close as Hugs gets to providing throw -throw :: Exception -> IO a -throw = throwIO -#endif - {-| This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value from the 'MVar', puts it back, and also returns it. diff --git a/Control/Exception.hs b/Control/Exception.hs index dc01d93..c766002 100644 --- a/Control/Exception.hs +++ b/Control/Exception.hs @@ -17,20 +17,16 @@ 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 throwIO, -- :: Exception -> IO a -#ifndef __HUGS__ throw, -- :: Exception -> a -#endif ioError, -- :: IOError -> IO a -#ifndef __HUGS__ +#ifdef __GLASGOW_HASKELL__ throwTo, -- :: ThreadId -> Exception -> a #endif @@ -63,23 +59,21 @@ 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 +#ifdef __GLASGOW_HASKELL__ throwDynTo, -- :: Typeable ex => ThreadId -> ex -> b - catchDyn, -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a #endif + catchDyn, -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a -- * Asynchronous Exceptions @@ -132,18 +126,10 @@ 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 @@ -286,7 +272,6 @@ tryJust p a = do Nothing -> throw e Just b -> return (Left b) -#ifdef __GLASGOW_HASKELL__ ----------------------------------------------------------------------------- -- Dynamic exceptions @@ -301,10 +286,12 @@ tryJust p a = do throwDyn :: Typeable exception => exception -> b throwDyn exception = throw (DynException (toDyn exception)) +#ifdef __GLASGOW_HASKELL__ -- | A variant of 'throwDyn' that throws the dynamic exception to an -- arbitrary thread (c.f. 'throwTo'). throwDynTo :: Typeable exception => ThreadId -> exception -> IO () throwDynTo t exception = throwTo t (DynException (toDyn exception)) +#endif /* __GLASGOW_HASKELL__ */ -- | Catch dynamic exceptions of the required type. All other -- exceptions are re-thrown, including dynamic exceptions of the wrong @@ -322,7 +309,6 @@ catchDyn m k = catchException m handle Just exception -> k exception Nothing -> throw ex _ -> throw ex -#endif /* __GLASGOW_HASKELL__ */ ----------------------------------------------------------------------------- -- Exception Predicates @@ -332,17 +318,14 @@ 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 -dynExceptions :: Exception -> Maybe Dynamic assertions :: Exception -> Maybe String +dynExceptions :: Exception -> Maybe Dynamic asyncExceptions :: Exception -> Maybe AsyncException userErrors :: Exception -> Maybe String -#endif /* __GLASGOW_HASKELL__ */ -#ifdef __GLASGOW_HASKELL__ ioErrors (IOException e) = Just e ioErrors _ = Nothing @@ -363,7 +346,6 @@ asyncExceptions _ = Nothing userErrors (IOException e) | isUserError e = Just (ioeGetErrorString e) userErrors _ = Nothing -#endif /* __GLASGOW_HASKELL__ */ ----------------------------------------------------------------------------- -- Some Useful Functions @@ -518,5 +500,5 @@ assert :: Bool -> a -> a #ifndef __GLASGOW_HASKELL__ assert :: Bool -> a -> a assert True x = x -assert False _ = error "Assertion failure" +assert False _ = throw (AssertionFailed "") #endif diff --git a/Data/Dynamic.hs b/Data/Dynamic.hs index e603933..2ca4689 100644 --- a/Data/Dynamic.hs +++ b/Data/Dynamic.hs @@ -79,6 +79,7 @@ import GHC.IOBase #endif #ifdef __HUGS__ +import Hugs.Prelude import Hugs.IO import Hugs.IORef import Hugs.IOExts @@ -106,7 +107,9 @@ import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO) 'Show'ing a value of type 'Dynamic' returns a pretty-printed representation of the object\'s type; useful for debugging. -} +#ifndef __HUGS__ data Dynamic = Dynamic TypeRep Obj +#endif instance Show Dynamic where -- the instance just prints the type representation. @@ -126,16 +129,18 @@ type Obj = forall a . a -- the other hand, if we use a polymorphic type, GHC will use -- a fallback convention for evaluating it that works for all types. -- (using a function type here would also work). -#else +#elif !defined(__HUGS__) data Obj = Obj #endif -- | A concrete representation of a (monomorphic) type. 'TypeRep' -- supports reasonably efficient equality. +#ifndef __HUGS__ data TypeRep = App TyCon [TypeRep] | Fun TypeRep TypeRep deriving ( Eq ) +#endif instance Show TypeRep where showsPrec p (App tycon tys) = @@ -156,10 +161,12 @@ instance Show TypeRep where -- | An abstract representation of a type constructor. 'TyCon' objects can -- be built using 'mkTyCon'. +#ifndef __HUGS__ data TyCon = TyCon Int String instance Eq TyCon where (TyCon t1 _) == (TyCon t2 _) = t1 == t2 +#endif instance Show TyCon where showsPrec _ (TyCon _ s) = showString s diff --git a/System/Exit.hs b/System/Exit.hs index 3c0ecb8..23bfbdb 100644 --- a/System/Exit.hs +++ b/System/Exit.hs @@ -26,7 +26,7 @@ import GHC.IOBase #endif #ifdef __HUGS__ -import Hugs.System +import Hugs.Prelude #endif #ifdef __NHC__ @@ -43,13 +43,15 @@ import System -- program's caller. Before it terminates, any open or semi-closed -- handles are first closed. -#ifdef __GLASGOW_HASKELL__ +#ifndef __NHC__ exitWith :: ExitCode -> IO a exitWith ExitSuccess = throw (ExitException ExitSuccess) -exitWith code@(ExitFailure n) - | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing) - | otherwise = throw (ExitException code) -#endif /* __GLASGOW_HASKELL__ */ +exitWith code@(ExitFailure n) + | n /= 0 = throw (ExitException code) +#ifdef __GLASGOW_HASKELL__ + | otherwise = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing) +#endif +#endif /* ! __NHC__ */ exitFailure :: IO a exitFailure = exitWith (ExitFailure 1) -- 1.7.10.4