PrelErr.lhs 5.58 KB
Newer Older
1
2
3
4
%
% (c) The AQUA Project, Glasgow University, 1994-1996
%

5
\section[PrelErr]{Module @PrelErr@}
6

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").
9

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
13
14
with what the typechecker figures out.

\begin{code}
sof's avatar
sof committed
15
{-# OPTIONS -fno-implicit-prelude #-}
16
module PrelErr 
sof's avatar
sof committed
17
18
       (
         irrefutPatError
sof's avatar
sof committed
19
       , noMethodBindingError
sof's avatar
sof committed
20
21
       , nonExhaustiveGuardsError
       , patError
sof's avatar
sof committed
22
       , recSelError
sof's avatar
sof committed
23
24
25
26
27
28
29
       , recConError
       , recUpdError               -- :: String -> a

       , absentErr, parError       -- :: a
       , seqError                  -- :: a

       , error		           -- :: String -> a
30
       , assertError		   -- :: String -> Bool -> a -> a
sof's avatar
sof committed
31
       
sof's avatar
sof committed
32
       ) where
33

sof's avatar
sof committed
34
import PrelBase
35
36
import PrelIOBase   ( IO(..) )
--import PrelHandle   ( catch )
37
38
import PrelAddr
import PrelList     ( span )
39
import PrelException
sof's avatar
sof committed
40
41
import PrelPack     ( packString )
import PrelArr      ( ByteArray(..) )
sof's avatar
sof committed
42

43
#ifndef __PARALLEL_HASKELL__
44
import PrelStable  ( StablePtr, deRefStablePtr )
45
#endif
46
47
48
49
50
51
52
53
54

---------------------------------------------------------------
-- HACK: Magic unfoldings not implemented for unboxed lists
--	 Need to define a "build" to avoid undefined symbol
-- in this module to avoid .hi proliferation.

--{-# GENERATE_SPECS build a #-}
--build 		:: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
--build g 	= g (:) []
sof's avatar
sof committed
55
56
--build   = error "GHCbase.build"
--augment = error "GHCbase.augment"
sof's avatar
sof committed
57
\end{code}
58

sof's avatar
sof committed
59
60
61
62
63
64
65
%*********************************************************
%*							*
\subsection{Error-ish functions}
%*							*
%*********************************************************

\begin{code}
66
{-
sof's avatar
sof committed
67
68
69
70
71
72
73
errorIO :: IO () -> a

errorIO (IO io)
  = case (errorIO# io) of
      _ -> bottom
  where
    bottom = bottom -- Never evaluated
74
75
76
-}
--ioError :: String -> a
--ioError s = error__ ``&IOErrorHdrHook'' s 
sof's avatar
sof committed
77
78
79

-- error stops execution and displays an error message
error :: String -> a
80
81
82
error s = throw (ErrorCall s)
--error s = error__ ``&ErrorHdrHook'' s
{-
sof's avatar
sof committed
83
84
85
86
87
88
89
90
91
92
93
94
-- 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
sof's avatar
sof committed
95
96
97

error__ msg_hdr s
#ifdef __PARALLEL_HASKELL__
sof's avatar
sof committed
98
  = errorIO (do
99
     (hFlush stdout) `catchException` (\ _ -> return ())
sof's avatar
sof committed
100
     let bs@(ByteArray (_,len) _) = packString s
101
     _ccall_ writeErrString__ msg_hdr bs len
sof's avatar
sof committed
102
103
     _ccall_ stg_exit (1::Int)
    )
sof's avatar
sof committed
104
#else
sof's avatar
sof committed
105
  = errorIO ( do
106
      (hFlush stdout) `catchException` (\ _ -> return ())
sof's avatar
sof committed
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
	    -- 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
   )

sof's avatar
sof committed
123
#endif {- !parallel -}
124
-}
sof's avatar
sof committed
125
126
127
128
129
130
131
\end{code}

%*********************************************************
%*							 *
\subsection{Compiler generated errors + local utils}
%*							 *
%*********************************************************
132

sof's avatar
sof committed
133
134
Used for compiler-generated error message;
encoding saves bytes of string junk.
135

sof's avatar
sof committed
136
\begin{code}
sof's avatar
sof committed
137
absentErr, parError, seqError :: a
sof's avatar
sof committed
138
139
140

absentErr = error "Oops! The program has entered an `absent' argument!\n"
parError  = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n"
sof's avatar
sof committed
141
142
seqError = error "Oops! Entered seqError (a GHC bug -- please report it!)\n"

sof's avatar
sof committed
143
144
145
\end{code}

\begin{code}
146
irrefutPatError
147
148
149
   , noMethodBindingError
   , nonExhaustiveGuardsError
   , patError
sof's avatar
sof committed
150
   , recSelError
151
152
   , recConError
   , recUpdError :: String -> a
153

154
155
156
157
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"))
158
159
160
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"))
161

sof's avatar
sof committed
162

163
164
assertError :: String -> Bool -> a -> a
assertError str pred v 
sof's avatar
sof committed
165
  | pred      = v
sof's avatar
sof committed
166
  | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
sof's avatar
sof committed
167

sof's avatar
sof committed
168
169
\end{code}

170

sof's avatar
sof committed
171
(untangle coded message) expects "coded" to be of the form 
172

sof's avatar
sof committed
173
	"location|details"
174

sof's avatar
sof committed
175
It prints
176

sof's avatar
sof committed
177
178
179
	location message details

\begin{code}
sof's avatar
sof committed
180
untangle :: String -> String -> String
sof's avatar
sof committed
181
182
183
184
untangle coded message
  =  location
  ++ ": " 
  ++ message
185
  ++ details
186
187
  ++ "\n"
  where
sof's avatar
sof committed
188
    (location, details)
sof's avatar
sof committed
189
      = case (span not_bar coded) of { (loc, rest) ->
sof's avatar
sof committed
190
	case rest of
sof's avatar
sof committed
191
192
	  ('|':det) -> (loc, ' ' : det)
	  _	    -> (loc, "")
sof's avatar
sof committed
193
	}
194
195
    not_bar c = c /= '|'
\end{code}