\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
module PrelErr
-
(
irrefutPatError
, noMethodBindingError
, nonExhaustiveGuardsError
, patError
+ , recSelError
, recConError
, recUpdError -- :: String -> a
, seqError -- :: a
, error -- :: String -> a
- , ioError -- :: String -> a
- , assert__ -- :: String -> Bool -> a -> a
+ , assertError -- :: String -> Bool -> a -> a
) where
---import Prelude
import PrelBase
-import PrelIOBase
+import PrelIOBase ( IO(..) )
+--import PrelHandle ( catch )
import PrelAddr
import PrelList ( span )
+import PrelException
+import PrelPack ( packString )
+import PrelArr ( ByteArray(..) )
#ifndef __PARALLEL_HASKELL__
import PrelForeign ( StablePtr, deRefStablePtr )
%*********************************************************
\begin{code}
+{-
errorIO :: IO () -> a
errorIO (IO io)
_ -> bottom
where
bottom = bottom -- Never evaluated
-
-ioError :: String -> a
-ioError s = error__ ( \ x -> _ccall_ IOErrorHdrHook x ) s
+-}
+--ioError :: String -> a
+--ioError s = error__ ``&IOErrorHdrHook'' s
-- error stops execution and displays an error message
error :: String -> a
-error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s
+error s = throw (ErrorCall s)
+--error s = error__ ``&ErrorHdrHook'' s
+{-
+-- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook,
+-- but the former does exactly the same as the latter, so I nuked it.
+-- SLPJ Jan 97
+--
+-- Hmm..distinguishing between these two kinds of error is quite useful in the
+-- compiler sources, printing out a more verbose msg in the case of patter
+-- matching failure.
+-- So I've reinstated patError to invoke its own message function hook again.
+-- SOF 8/98
+patError__ x = error__ ``&PatErrorHdrHook'' x
-error__ :: (Addr{-FILE *-} -> IO ()) -> String -> a
+error__ :: Addr{-C function pointer to hook-} -> String -> a
error__ msg_hdr s
#ifdef __PARALLEL_HASKELL__
- = errorIO (msg_hdr sTDERR{-msg hdr-} >>
- _ccall_ fflush sTDERR >>
- fputs sTDERR s >>
- _ccall_ fflush sTDERR >>
- _ccall_ stg_exit (1::Int)
- )
+ = errorIO (do
+ (hFlush stdout) `catchException` (\ _ -> return ())
+ let bs@(ByteArray (_,len) _) = packString s
+ _ccall_ writeErrString__ msg_hdr bs len
+ _ccall_ stg_exit (1::Int)
+ )
#else
- = errorIO (msg_hdr sTDERR{-msg hdr-} >>
- _ccall_ fflush sTDERR >>
- fputs sTDERR s >>
- _ccall_ fflush sTDERR >>
- _ccall_ getErrorHandler >>= \ errorHandler ->
- if errorHandler == (-1::Int) then
- _ccall_ stg_exit (1::Int)
- else
- _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
- >>= \ osptr ->
- _ccall_ decrementErrorCount >>= \ () ->
- deRefStablePtr osptr >>= \ oact ->
- oact
- )
+ = errorIO ( do
+ (hFlush stdout) `catchException` (\ _ -> return ())
+ -- Note: there's potential for trouble here in a
+ -- a concurrent setting if an error is flagged after the
+ -- lock on the stdout handle. (I don't see a possibility
+ -- of this occurring with the current impl, but still.)
+ let bs@(ByteArray (_,len) _) = packString s
+ _ccall_ writeErrString__ msg_hdr bs len
+ errorHandler <- _ccall_ getErrorHandler
+ if errorHandler == (-1::Int) then
+ _ccall_ stg_exit (1::Int)
+ else do
+ osptr <- _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
+ _ccall_ decrementErrorCount
+ oact <- deRefStablePtr osptr
+ oact
+ )
+
#endif {- !parallel -}
- where
- sTDERR = (``stderr'' :: Addr)
+-}
\end{code}
%*********************************************************
\begin{code}
irrefutPatError
, noMethodBindingError
- --, noExplicitMethodError
, nonExhaustiveGuardsError
, patError
+ , recSelError
, recConError
, recUpdError :: String -> a
---noDefaultMethodError s = error ("noDefaultMethodError:"++s)
---noExplicitMethodError s = error ("No default method for class operation "++s)
-noMethodBindingError s = error (untangle s "No instance nor default method for class operation")
-irrefutPatError s = error (untangle s "Irrefutable pattern failed for pattern")
-nonExhaustiveGuardsError s = error (untangle s "Non-exhaustive guards in")
-patError s = error (untangle s "Non-exhaustive patterns in")
-recConError s = error (untangle s "Missing field in record construction:")
-recUpdError s = error (untangle s "Record to doesn't contain field(s) to be updated")
+noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
+irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
+nonExhaustiveGuardsError s = throw (NonExhaustiveGuards (untangle s "Non-exhaustive guards in"))
+patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
+recSelError s = throw (RecSelError (untangle s "Missing field in record selection:"))
+recConError s = throw (RecConError (untangle s "Missing field in record construction:"))
+recUpdError s = throw (RecUpdError (untangle s "Record to doesn't contain field(s) to be updated"))
-assert__ :: String -> Bool -> a -> a
-assert__ str pred v
+assertError :: String -> Bool -> a -> a
+assertError str pred v
| pred = v
| otherwise = error (untangle str "Assertion failed")
}
not_bar c = c /= '|'
\end{code}
-
--- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook,
--- but the former does exactly the same as the latter, so I nuked it.
--- SLPJ Jan 97
--- patError__ = error__ (\ x -> _ccall_ PatErrorHdrHook x)
-
projects / ghc-hetmet.git / blobdiff