X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIOBase.lhs;h=0a19d80d1a44784d021da4f9acce8b5ee07328e7;hb=e5cae33016a7dc093608aecfe4e737e814d0afa6;hp=f50c7752124bc7a35153f21c8f922daf77a8a6b7;hpb=b9152b3523862840a0b682ffa55cf55281c93185;p=ghc-base.git

diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs
index f50c775..0a19d80 100644
--- a/GHC/IOBase.lhs
+++ b/GHC/IOBase.lhs
@@ -27,7 +27,8 @@ module GHC.IOBase(
 
         -- References
     IORef(..), newIORef, readIORef, writeIORef, 
-    IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray,
+    IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, 
+    unsafeWriteIOArray, boundsIOArray,
     MVar(..),
 
         -- Handles, file descriptors,
@@ -46,8 +47,9 @@ module GHC.IOBase(
     ExitCode(..),
     throwIO, block, unblock, blocked, catchAny, catchException,
     evaluate,
-    ErrorCall(..), ArithException(..), AsyncException(..),
-    BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..)
+    ErrorCall(..), AssertionFailed(..), assertError, untangle,
+    BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..),
+    blockedOnDeadMVar, blockedIndefinitely
   ) where
 
 import GHC.ST
@@ -64,8 +66,7 @@ import Foreign.C.Types (CInt)
 import GHC.Exception
 
 #ifndef __HADDOCK__
-import {-# SOURCE #-} Data.Typeable     ( Typeable, showsTypeRep )
-import {-# SOURCE #-} Data.Dynamic      ( Dynamic, dynTypeRep )
+import {-# SOURCE #-} Data.Typeable     ( Typeable )
 #endif
 
 -- ---------------------------------------------------------------------------
@@ -140,7 +141,7 @@ bindIO (IO m) k = IO ( \ s ->
 thenIO :: IO a -> IO b -> IO b
 thenIO (IO m) k = IO ( \ s ->
   case m s of 
-    (# new_s, a #) -> unIO k new_s
+    (# new_s, _ #) -> unIO k new_s
   )
 
 returnIO :: a -> IO a
@@ -471,15 +472,18 @@ data HandleType
  | AppendHandle
  | ReadWriteHandle
 
+isReadableHandleType :: HandleType -> Bool
 isReadableHandleType ReadHandle         = True
 isReadableHandleType ReadWriteHandle    = True
 isReadableHandleType _                  = False
 
+isWritableHandleType :: HandleType -> Bool
 isWritableHandleType AppendHandle    = True
 isWritableHandleType WriteHandle     = True
 isWritableHandleType ReadWriteHandle = True
 isWritableHandleType _               = False
 
+isReadWriteHandleType :: HandleType -> Bool
 isReadWriteHandleType ReadWriteHandle{} = True
 isReadWriteHandleType _                 = False
 
@@ -583,7 +587,7 @@ instance Eq (IOArray i e) where
 -- |Build a new 'IOArray'
 newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e)
 {-# INLINE newIOArray #-}
-newIOArray lu init  = stToIO $ do {marr <- newSTArray lu init; return (IOArray marr)}
+newIOArray lu initial  = stToIO $ do {marr <- newSTArray lu initial; return (IOArray marr)}
 
 -- | Read a value from an 'IOArray'
 unsafeReadIOArray  :: Ix i => IOArray i e -> Int -> IO e
@@ -603,6 +607,9 @@ readIOArray (IOArray marr) i = stToIO (readSTArray marr i)
 writeIOArray :: Ix i => IOArray i e -> i -> e -> IO ()
 writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e)
 
+{-# INLINE boundsIOArray #-}
+boundsIOArray :: IOArray i e -> (i,i)  
+boundsIOArray (IOArray marr) = boundsSTArray marr
 
 -- ---------------------------------------------------------------------------
 -- Show instance for Handles
@@ -612,7 +619,7 @@ writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e)
 -- than the derived one.
 
 instance Show HandleType where
-  showsPrec p t =
+  showsPrec _ t =
     case t of
       ClosedHandle      -> showString "closed"
       SemiClosedHandle  -> showString "semi-closed"
@@ -622,24 +629,17 @@ instance Show HandleType where
       ReadWriteHandle   -> showString "read-writable"
 
 instance Show Handle where 
-  showsPrec p (FileHandle   file _)   = showHandle file
-  showsPrec p (DuplexHandle file _ _) = showHandle file
+  showsPrec _ (FileHandle   file _)   = showHandle file
+  showsPrec _ (DuplexHandle file _ _) = showHandle file
 
+showHandle :: FilePath -> String -> String
 showHandle file = showString "{handle: " . showString file . showString "}"
 
 -- ------------------------------------------------------------------------
 -- Exception datatypes and operations
 
-data ErrorCall = ErrorCall String
-    deriving Typeable
-
-instance Exception ErrorCall
-
-instance Show ErrorCall where
-    showsPrec _ (ErrorCall err) = showString err
-
------
-
+-- |The thread is blocked on an @MVar@, but there are no other references
+-- to the @MVar@ so it can't ever continue.
 data BlockedOnDeadMVar = BlockedOnDeadMVar
     deriving Typeable
 
@@ -648,8 +648,13 @@ instance Exception BlockedOnDeadMVar
 instance Show BlockedOnDeadMVar where
     showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"
 
+blockedOnDeadMVar :: SomeException -- for the RTS
+blockedOnDeadMVar = toException BlockedOnDeadMVar
+
 -----
 
+-- |The thread is awiting to retry an STM transaction, but there are no
+-- other references to any @TVar@s involved, so it can't ever continue.
 data BlockedIndefinitely = BlockedIndefinitely
     deriving Typeable
 
@@ -658,8 +663,13 @@ instance Exception BlockedIndefinitely
 instance Show BlockedIndefinitely where
     showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"
 
+blockedIndefinitely :: SomeException -- for the RTS
+blockedIndefinitely = toException BlockedIndefinitely
+
 -----
 
+-- |There are no runnable threads, so the program is deadlocked.
+-- The @Deadlock@ exception is raised in the main thread only.
 data Deadlock = Deadlock
     deriving Typeable
 
@@ -670,18 +680,19 @@ instance Show Deadlock where
 
 -----
 
--- |The type of arithmetic exceptions
-data ArithException
-  = Overflow
-  | Underflow
-  | LossOfPrecision
-  | DivideByZero
-  | Denormal
-  deriving (Eq, Ord, Typeable)
+-- |Exceptions generated by 'assert'. The @String@ gives information
+-- about the source location of the assertion.
+data AssertionFailed = AssertionFailed String
+    deriving Typeable
 
-instance Exception ArithException
+instance Exception AssertionFailed
 
--- |Asynchronous exceptions
+instance Show AssertionFailed where
+    showsPrec _ (AssertionFailed err) = showString err
+
+-----
+
+-- |Asynchronous exceptions.
 data AsyncException
   = StackOverflow
         -- ^The current thread\'s stack exceeded its limit.
@@ -726,17 +737,11 @@ stackOverflow, heapOverflow :: SomeException -- for the RTS
 stackOverflow = toException StackOverflow
 heapOverflow  = toException HeapOverflow
 
-instance Show ArithException where
-  showsPrec _ Overflow        = showString "arithmetic overflow"
-  showsPrec _ Underflow       = showString "arithmetic underflow"
-  showsPrec _ LossOfPrecision = showString "loss of precision"
-  showsPrec _ DivideByZero    = showString "divide by zero"
-  showsPrec _ Denormal        = showString "denormal"
-
 instance Show AsyncException where
   showsPrec _ StackOverflow   = showString "stack overflow"
   showsPrec _ HeapOverflow    = showString "heap overflow"
   showsPrec _ ThreadKilled    = showString "thread killed"
+  showsPrec _ UserInterrupt   = showString "user interrupt"
 
 instance Show ArrayException where
   showsPrec _ (IndexOutOfBounds s)
@@ -794,6 +799,7 @@ data IOException
      ioe_type     :: IOErrorType,    -- what it was.
      ioe_location :: String,         -- location.
      ioe_description :: String,      -- error type specific information.
+     ioe_errno    :: Maybe CInt,     -- errno leading to this error, if any.
      ioe_filename :: Maybe FilePath  -- filename the error is related to.
    }
     deriving Typeable
@@ -801,8 +807,8 @@ data IOException
 instance Exception IOException
 
 instance Eq IOException where
-  (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = 
-    e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2
+  (IOError h1 e1 loc1 str1 en1 fn1) == (IOError h2 e2 loc2 str2 en2 fn2) = 
+    e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && en1==en2 && fn1==fn2
 
 -- | An abstract type that contains a value for each variant of 'IOError'.
 data IOErrorType
@@ -827,13 +833,9 @@ data IOErrorType
   | TimeExpired
   | ResourceVanished
   | Interrupted
-  | DynIOError Dynamic -- cheap&cheerful extensible IO error type.
 
 instance Eq IOErrorType where
-   x == y = 
-     case x of
-       DynIOError{} -> False -- from a strictness POV, compatible with a derived Eq inst?
-       _ -> getTag x ==# getTag y
+   x == y = getTag x ==# getTag y
  
 instance Show IOErrorType where
   showsPrec _ e =
@@ -858,7 +860,6 @@ instance Show IOErrorType where
       TimeExpired       -> "timeout"
       UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
       UnsupportedOperation -> "unsupported operation"
-      DynIOError{}      -> "unknown IO error"
 
 -- | Construct an 'IOError' value with a string describing the error.
 -- The 'fail' method of the 'IO' instance of the 'Monad' class raises a
@@ -869,13 +870,13 @@ instance Show IOErrorType where
 -- >   fail s = ioError (userError s)
 --
 userError       :: String  -> IOError
-userError str   =  IOError Nothing UserError "" str Nothing
+userError str   =  IOError Nothing UserError "" str Nothing Nothing
 
 -- ---------------------------------------------------------------------------
 -- Showing IOErrors
 
 instance Show IOException where
-    showsPrec p (IOError hdl iot loc s fn) =
+    showsPrec p (IOError hdl iot loc s _ fn) =
       (case fn of
          Nothing -> case hdl of
                         Nothing -> id
@@ -925,7 +926,7 @@ 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)
 
--- | A variant of 'throw' that can be used within the 'IO' monad.
+-- | A variant of 'throw' that can only be used within the 'IO' monad.
 --
 -- Although 'throwIO' has a type that is an instance of the type of 'throw', the
 -- two functions are subtly different:
@@ -986,9 +987,10 @@ blocked = IO $ \s -> case asyncExceptionsBlocked# s of
 \end{code}
 
 \begin{code}
--- | Forces its argument to be evaluated when the resultant 'IO' action
--- is executed.  It can be used to order evaluation with respect to
--- other 'IO' operations; its semantics are given by
+-- | Forces its argument to be evaluated to weak head normal form when
+-- the resultant 'IO' action is executed. It can be used to order
+-- evaluation with respect to other 'IO' operations; its semantics are
+-- given by
 --
 -- >   evaluate x `seq` y    ==>  y
 -- >   evaluate x `catch` f  ==>  (return $! x) `catch` f
@@ -1006,3 +1008,34 @@ evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #)
         -- because we can't have an unboxed tuple as a function argument
 \end{code}
 
+\begin{code}
+assertError :: Addr# -> Bool -> a -> a
+assertError str predicate v
+  | predicate = v
+  | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
+
+{-
+(untangle coded message) expects "coded" to be of the form
+        "location|details"
+It prints
+        location message details
+-}
+untangle :: Addr# -> String -> String
+untangle coded message
+  =  location
+  ++ ": "
+  ++ message
+  ++ details
+  ++ "\n"
+  where
+    coded_str = unpackCStringUtf8# coded
+
+    (location, details)
+      = case (span not_bar coded_str) of { (loc, rest) ->
+        case rest of
+          ('|':det) -> (loc, ' ' : det)
+          _         -> (loc, "")
+        }
+    not_bar c = c /= '|'
+\end{code}
+