ghc/lib/std/PrelErr.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4
   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 with what the typechecker figures out.
  13
  14 \begin{code}
  15 {-# OPTIONS -fno-implicit-prelude #-}
  16 module PrelErr
  17        (
  18          irrefutPatError
  19        , noMethodBindingError
  20        , nonExhaustiveGuardsError
  21        , patError
  22        , recSelError
  23        , recConError
  24        , recUpdError               -- :: String -> a
  25
  26        , absentErr, parError       -- :: a
  27        , seqError                  -- :: a
  28
  29        , error                     -- :: String -> a
  30        , assertError               -- :: String -> Bool -> a -> a
  31
  32        ) where
  33
  34 import PrelBase
  35 import PrelIOBase   ( IO(..) )
  36 --import PrelHandle   ( catch )
  37 import PrelAddr
  38 import PrelList     ( span )
  39 import PrelException
  40 import PrelPack     ( packString )
  41 import PrelArr      ( ByteArray(..) )
  42
  43 #ifndef __PARALLEL_HASKELL__
  44 import PrelForeign  ( StablePtr, deRefStablePtr )
  45 #endif
  46
  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.
  51
  52 --{-# GENERATE_SPECS build a #-}
  53 --build                 :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
  54 --build g       = g (:) []
  55 --build   = error "GHCbase.build"
  56 --augment = error "GHCbase.augment"
  57 \end{code}
  58
  59 %*********************************************************
  60 %*                                                      *
  61 \subsection{Error-ish functions}
  62 %*                                                      *
  63 %*********************************************************
  64
  65 \begin{code}
  66 {-
  67 errorIO :: IO () -> a
  68
  69 errorIO (IO io)
  70   = case (errorIO# io) of
  71       _ -> bottom
  72   where
  73     bottom = bottom -- Never evaluated
  74 -}
  75 --ioError :: String -> a
  76 --ioError s = error__ ``&IOErrorHdrHook'' s
  77
  78 -- error stops execution and displays an error message
  79 error :: String -> a
  80 error s = throw (ErrorCall s)
  81 --error s = error__ ``&ErrorHdrHook'' s
  82 {-
  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.
  85 --              SLPJ Jan 97
  86 --
  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
  89 -- matching failure.
  90 -- So I've reinstated patError to invoke its own message function hook again.
  91 --    SOF 8/98
  92 patError__ x = error__ ``&PatErrorHdrHook'' x
  93
  94 error__ :: Addr{-C function pointer to hook-} -> String -> a
  95
  96 error__ msg_hdr s
  97 #ifdef __PARALLEL_HASKELL__
  98   = errorIO (do
  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)
 103     )
 104 #else
 105   = errorIO ( do
 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)
 116        else do
 117         osptr <- _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
 118         _ccall_ decrementErrorCount
 119         oact  <- deRefStablePtr osptr
 120         oact
 121    )
 122
 123 #endif {- !parallel -}
 124 -}
 125 \end{code}
 126
 127 %*********************************************************
 128 %*                                                       *
 129 \subsection{Compiler generated errors + local utils}
 130 %*                                                       *
 131 %*********************************************************
 132
 133 Used for compiler-generated error message;
 134 encoding saves bytes of string junk.
 135
 136 \begin{code}
 137 absentErr, parError, seqError :: a
 138
 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"
 142
 143 \end{code}
 144
 145 \begin{code}
 146 irrefutPatError
 147    , noMethodBindingError
 148    , nonExhaustiveGuardsError
 149    , patError
 150    , recSelError
 151    , recConError
 152    , recUpdError :: String -> a
 153
 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 to doesn't contain field(s) to be updated"))
 161
 162
 163 assertError :: String -> Bool -> a -> a
 164 assertError str pred v
 165   | pred      = v
 166   | otherwise = error (untangle str "Assertion failed")
 167
 168 \end{code}
 169
 170
 171 (untangle coded message) expects "coded" to be of the form
 172
 173         "location|details"
 174
 175 It prints
 176
 177         location message details
 178
 179 \begin{code}
 180 untangle :: String -> String -> String
 181 untangle coded message
 182   =  location
 183   ++ ": "
 184   ++ message
 185   ++ details
 186   ++ "\n"
 187   where
 188     (location, details)
 189       = case (span not_bar coded) of { (loc, rest) ->
 190         case rest of
 191           ('|':det) -> (loc, ' ' : det)
 192           _         -> (loc, "")
 193         }
 194     not_bar c = c /= '|'
 195 \end{code}