+% -----------------------------------------------------------------------------
+% $Id: PrelErr.lhs,v 1.21 2001/07/24 16:09:48 simonpj Exp $
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The University of Glasgow, 1994-2000
%
\section[PrelErr]{Module @PrelErr@}
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
module PrelErr
-
(
irrefutPatError
, noMethodBindingError
, absentErr, parError -- :: a
, seqError -- :: a
+ , errorCString -- :: Addr# -> a -- Arg is a ptr to C string
, error -- :: String -> a
- , ioError -- :: String -> a
, assertError -- :: String -> Bool -> a -> a
+
+ , undefined -- :: a
) where
import PrelBase
-import PrelIOBase ( IO(..), catch )
-import PrelHandle
-import PrelAddr
import PrelList ( span )
-import PrelPack ( packString )
-import PrelArr ( ByteArray(..) )
-
-#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( StablePtr, deRefStablePtr )
-#endif
-
----------------------------------------------------------------
--- HACK: Magic unfoldings not implemented for unboxed lists
--- Need to define a "build" to avoid undefined symbol
--- in this module to avoid .hi proliferation.
-
-build = error "GHCbase.build"
-augment = error "GHCbase.augment"
---{-# GENERATE_SPECS build a #-}
---build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
---build g = g (:) []
+import PrelException
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
-errorIO :: IO () -> a
+-- error stops execution and displays an error message
+error :: String -> a
+error s = throw (ErrorCall s)
-errorIO (IO io)
- = case (errorIO# io) of
- _ -> bottom
- where
- bottom = bottom -- Never evaluated
+errorCString :: Addr# -> a
+errorCString s = error (unpackCString# s)
-ioError :: String -> a
-ioError s = error__ ``&IOErrorHdrHook'' s
+-- It is expected that compilers will recognize this and insert error
+-- messages which are more appropriate to the context in which undefined
+-- appears.
--- error stops execution and displays an error message
-error :: String -> a
-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{-C function pointer to hook-} -> String -> a
-
-error__ msg_hdr s
-#ifdef __PARALLEL_HASKELL__
- = errorIO (do
- (hFlush stdout) `catch` (\ _ -> return ())
- let bs@(ByteArray (_,len) _) = packString s
- _ccall_ writeErrString__ msg_hdr bs len
- _ccall_ stg_exit (1::Int)
- )
-#else
- = errorIO ( do
- (hFlush stdout) `catch` (\ _ -> 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 -}
+undefined :: a
+undefined = error "Prelude.undefined"
\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")
-recSelError s = error (untangle s "Missing field in record selection:")
-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")
-patError s = patError__ (untangle s "Non-exhaustive patterns in")
+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 (PatternMatchFail (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 doesn't contain field(s) to be updated"))
+
assertError :: String -> Bool -> a -> a
assertError str pred v
| pred = v
- | otherwise = error (untangle str "Assertion failed")
+ | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
\end{code}
location message details
\begin{code}
+untangle :: String -> String -> String
untangle coded message
= location
++ ": "
++ "\n"
where
(location, details)
- = case (span not_bar coded) of { (location, rest) ->
+ = case (span not_bar coded) of { (loc, rest) ->
case rest of
- ('|':details) -> (location, ' ' : details)
- _ -> (location, "")
+ ('|':det) -> (loc, ' ' : det)
+ _ -> (loc, "")
}
not_bar c = c /= '|'
\end{code}