[project @ 2003-01-23 17:45:40 by ross]

Hugs now uses most of Control.Exception.

4 files changed, 23 insertions, 39 deletions

diff --git a/libraries/base/Control/Concurrent/MVar.hs b/libraries/base/Control/Concurrent/MVar.hs
index 4dfac5aaf7..ea037baea3 100644
--- a/libraries/base/Control/Concurrent/MVar.hs
+++ b/libraries/base/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/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs
index dc01d93057..c766002f89 100644
--- a/libraries/base/Control/Exception.hs
+++ b/libraries/base/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/libraries/base/Data/Dynamic.hs b/libraries/base/Data/Dynamic.hs
index e603933fee..2ca46895a6 100644
--- a/libraries/base/Data/Dynamic.hs
+++ b/libraries/base/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/libraries/base/System/Exit.hs b/libraries/base/System/Exit.hs
index 3c0ecb80c0..23bfbdb98f 100644
--- a/libraries/base/System/Exit.hs
+++ b/libraries/base/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)