2 % (c) The AQUA Project, Glasgow University, 1994-1996
5 \section[PrelErr]{Module @PrelErr@}
7 The PrelErr module defines the code for the wired-in error functions,
8 which have a special type in the compiler (with "open tyvars").
10 We cannot define these functions in a module where they might be used
11 (e.g., PrelBase), because the magical wired-in type will get confused
12 with what the typechecker figures out.
15 {-# OPTIONS -fno-implicit-prelude #-}
19 , noMethodBindingError
20 , nonExhaustiveGuardsError
24 , recUpdError -- :: String -> a
26 , absentErr, parError -- :: a
29 , error -- :: String -> a
30 , assertError -- :: String -> Bool -> a -> a
35 import PrelIOBase ( IO(..) )
36 --import PrelHandle ( catch )
38 import PrelList ( span )
40 import PrelPack ( packString )
41 import PrelArr ( ByteArray(..) )
43 #ifndef __PARALLEL_HASKELL__
44 import PrelStable ( StablePtr, deRefStablePtr )
47 ---------------------------------------------------------------
48 -- HACK: Magic unfoldings not implemented for unboxed lists
49 -- Need to define a "build" to avoid undefined symbol
50 -- in this module to avoid .hi proliferation.
52 --{-# GENERATE_SPECS build a #-}
53 --build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
55 --build = error "GHCbase.build"
56 --augment = error "GHCbase.augment"
59 %*********************************************************
61 \subsection{Error-ish functions}
63 %*********************************************************
70 = case (errorIO# io) of
73 bottom = bottom -- Never evaluated
75 --ioError :: String -> a
76 --ioError s = error__ ``&IOErrorHdrHook'' s
78 -- error stops execution and displays an error message
80 error s = throw (ErrorCall s)
81 --error s = error__ ``&ErrorHdrHook'' s
83 -- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook,
84 -- but the former does exactly the same as the latter, so I nuked it.
87 -- Hmm..distinguishing between these two kinds of error is quite useful in the
88 -- compiler sources, printing out a more verbose msg in the case of patter
90 -- So I've reinstated patError to invoke its own message function hook again.
92 patError__ x = error__ ``&PatErrorHdrHook'' x
94 error__ :: Addr{-C function pointer to hook-} -> String -> a
97 #ifdef __PARALLEL_HASKELL__
99 (hFlush stdout) `catchException` (\ _ -> return ())
100 let bs@(ByteArray (_,len) _) = packString s
101 _ccall_ writeErrString__ msg_hdr bs len
102 _ccall_ stg_exit (1::Int)
106 (hFlush stdout) `catchException` (\ _ -> return ())
107 -- Note: there's potential for trouble here in a
108 -- a concurrent setting if an error is flagged after the
109 -- lock on the stdout handle. (I don't see a possibility
110 -- of this occurring with the current impl, but still.)
111 let bs@(ByteArray (_,len) _) = packString s
112 _ccall_ writeErrString__ msg_hdr bs len
113 errorHandler <- _ccall_ getErrorHandler
114 if errorHandler == (-1::Int) then
115 _ccall_ stg_exit (1::Int)
117 osptr <- _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
118 _ccall_ decrementErrorCount
119 oact <- deRefStablePtr osptr
123 #endif {- !parallel -}
127 %*********************************************************
129 \subsection{Compiler generated errors + local utils}
131 %*********************************************************
133 Used for compiler-generated error message;
134 encoding saves bytes of string junk.
137 absentErr, parError, seqError :: a
139 absentErr = error "Oops! The program has entered an `absent' argument!\n"
140 parError = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n"
141 seqError = error "Oops! Entered seqError (a GHC bug -- please report it!)\n"
147 , noMethodBindingError
148 , nonExhaustiveGuardsError
152 , recUpdError :: String -> a
154 noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
155 irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
156 nonExhaustiveGuardsError s = throw (NonExhaustiveGuards (untangle s "Non-exhaustive guards in"))
157 patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
158 recSelError s = throw (RecSelError (untangle s "Missing field in record selection"))
159 recConError s = throw (RecConError (untangle s "Missing field in record construction"))
160 recUpdError s = throw (RecUpdError (untangle s "Record doesn't contain field(s) to be updated"))
163 assertError :: String -> Bool -> a -> a
164 assertError str pred v
166 | otherwise = error (untangle str "Assertion failed")
171 (untangle coded message) expects "coded" to be of the form
177 location message details
180 untangle :: String -> String -> String
181 untangle coded message
189 = case (span not_bar coded) of { (loc, rest) ->
191 ('|':det) -> (loc, ' ' : det)