+% -----------------------------------------------------------------------------
+% $Id: PrelErr.lhs,v 1.20 2001/07/24 16:04:21 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 Prelude
import PrelBase
-import PrelIOBase
-import PrelAddr
import PrelList ( span )
-
-#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__ ( \ x -> _ccall_ IOErrorHdrHook x ) 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__ ( \ x -> _ccall_ ErrorHdrHook x ) s
-
-error__ :: (Addr{-FILE *-} -> IO ()) -> 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)
- )
-#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
- )
-#endif {- !parallel -}
- where
- sTDERR = (``stderr'' :: Addr)
+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")
-patError s = error (untangle s "Non-exhaustive patterns 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")
+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}
-
--- 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