The tuple datatype definitions have moved to ghc-prim

[ghc-base.git] / GHC / IOBase.lhs

diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs
index 58e5ec3..aa4af69 100644 (file)
--- a/GHC/IOBase.lhs
+++ b/GHC/IOBase.lhs
@@ -46,8 +46,8 @@ module GHC.IOBase(
     ExitCode(..),
     throwIO, block, unblock, blocked, catchAny, catchException,
     evaluate,
-    ErrorCall(..), ArithException(..), AsyncException(..),
-    BlockedOnDeadMVar(..), BlockedIndefinitely(..),
+    ErrorCall(..), AssertionFailed(..), assertError, untangle,
+    BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..)
   ) where
 
 import GHC.ST
@@ -64,8 +64,8 @@ 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 )
+import {-# SOURCE #-} Data.Dynamic      ( Dynamic )
 #endif
 
 -- ---------------------------------------------------------------------------
@@ -660,6 +660,26 @@ instance Show BlockedIndefinitely where
 
 -----
 
+data Deadlock = Deadlock
+    deriving Typeable
+
+instance Exception Deadlock
+
+instance Show Deadlock where
+    showsPrec _ Deadlock = showString "<<deadlock>>"
+
+-----
+
+data AssertionFailed = AssertionFailed String
+    deriving Typeable
+
+instance Exception AssertionFailed
+
+instance Show AssertionFailed where
+    showsPrec _ (AssertionFailed err) = showString err
+
+-----
+
 -- |The type of arithmetic exceptions
 data ArithException
   = Overflow
@@ -904,7 +924,7 @@ Now catch# has type
 (well almost; the compiler doesn't know about the IO newtype so we
 have to work around that in the definition of catchException below).
 
-\begin{code} 
+\begin{code}
 catchException :: Exception e => IO a -> (e -> IO a) -> IO a
 catchException (IO io) handler = IO $ catch# io handler'
     where handler' e = case fromException e of
@@ -996,3 +1016,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 pred v
+  | pred      = 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}
+