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        ) where
  32
  33 import PrelBase
  34 import PrelIOBase   ( IO(..) )
  35 --import PrelHandle   ( catch )
  36 import PrelAddr
  37 import PrelList     ( span )
  38 import PrelException
  39 import PrelPack     ( packString )
  40 import PrelArr      ( ByteArray(..) )
  41
  42 #ifndef __PARALLEL_HASKELL__
  43 import PrelForeign  ( StablePtr, deRefStablePtr )
  44 #endif
  45
  46 ---------------------------------------------------------------
  47 -- HACK: Magic unfoldings not implemented for unboxed lists
  48 --       Need to define a "build" to avoid undefined symbol
  49 -- in this module to avoid .hi proliferation.
  50
  51 build   = error "GHCbase.build"
  52 augment = error "GHCbase.augment"
  53 --{-# GENERATE_SPECS build a #-}
  54 --build                 :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
  55 --build g       = g (:) []
  56 \end{code}
  57
  58 %*********************************************************
  59 %*                                                      *
  60 \subsection{Error-ish functions}
  61 %*                                                      *
  62 %*********************************************************
  63
  64 \begin{code}
  65 {-
  66 errorIO :: IO () -> a
  67
  68 errorIO (IO io)
  69   = case (errorIO# io) of
  70       _ -> bottom
  71   where
  72     bottom = bottom -- Never evaluated
  73 -}
  74 --ioError :: String -> a
  75 --ioError s = error__ ``&IOErrorHdrHook'' s
  76
  77 -- error stops execution and displays an error message
  78 error :: String -> a
  79 error s = throw (ErrorCall s)
  80 --error s = error__ ``&ErrorHdrHook'' s
  81 {-
  82 -- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook,
  83 -- but the former does exactly the same as the latter, so I nuked it.
  84 --              SLPJ Jan 97
  85 --
  86 -- Hmm..distinguishing between these two kinds of error is quite useful in the
  87 -- compiler sources, printing out a more verbose msg in the case of patter
  88 -- matching failure.
  89 -- So I've reinstated patError to invoke its own message function hook again.
  90 --    SOF 8/98
  91 patError__ x = error__ ``&PatErrorHdrHook'' x
  92
  93 error__ :: Addr{-C function pointer to hook-} -> String -> a
  94
  95 error__ msg_hdr s
  96 #ifdef __PARALLEL_HASKELL__
  97   = errorIO (do
  98      (hFlush stdout) `catchException` (\ _ -> return ())
  99      let bs@(ByteArray (_,len) _) = packString s
 100      _ccall_ writeErrString__ msg_hdr bs len
 101      _ccall_ stg_exit (1::Int)
 102     )
 103 #else
 104   = errorIO ( do
 105       (hFlush stdout) `catchException` (\ _ -> return ())
 106             -- Note: there's potential for trouble here in a
 107             -- a concurrent setting if an error is flagged after the
 108             -- lock on the stdout handle. (I don't see a possibility
 109             -- of this occurring with the current impl, but still.)
 110       let bs@(ByteArray (_,len) _) = packString s
 111       _ccall_ writeErrString__ msg_hdr bs len
 112       errorHandler <- _ccall_ getErrorHandler
 113       if errorHandler == (-1::Int) then
 114          _ccall_ stg_exit (1::Int)
 115        else do
 116         osptr <- _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
 117         _ccall_ decrementErrorCount
 118         oact  <- deRefStablePtr osptr
 119         oact
 120    )
 121
 122 #endif {- !parallel -}
 123 -}
 124 \end{code}
 125
 126 %*********************************************************
 127 %*                                                       *
 128 \subsection{Compiler generated errors + local utils}
 129 %*                                                       *
 130 %*********************************************************
 131
 132 Used for compiler-generated error message;
 133 encoding saves bytes of string junk.
 134
 135 \begin{code}
 136 absentErr, parError, seqError :: a
 137
 138 absentErr = error "Oops! The program has entered an `absent' argument!\n"
 139 parError  = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n"
 140 seqError = error "Oops! Entered seqError (a GHC bug -- please report it!)\n"
 141
 142 \end{code}
 143
 144 \begin{code}
 145 irrefutPatError
 146    , noMethodBindingError
 147    , nonExhaustiveGuardsError
 148    , patError
 149    , recSelError
 150    , recConError
 151    , recUpdError :: String -> a
 152
 153 noMethodBindingError     s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
 154 irrefutPatError          s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
 155 nonExhaustiveGuardsError s = throw (NonExhaustiveGuards (untangle s "Non-exhaustive guards in"))
 156 patError                 s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
 157 recSelError              s = throw (RecSelError (untangle s "Missing field in record selection:"))
 158 recConError              s = throw (RecConError (untangle s "Missing field in record construction:"))
 159 recUpdError              s = throw (RecUpdError (untangle s "Record to doesn't contain field(s) to be updated"))
 160
 161
 162 assertError :: String -> Bool -> a -> a
 163 assertError str pred v
 164   | pred      = v
 165   | otherwise = error (untangle str "Assertion failed")
 166
 167 \end{code}
 168
 169
 170 (untangle coded message) expects "coded" to be of the form
 171
 172         "location|details"
 173
 174 It prints
 175
 176         location message details
 177
 178 \begin{code}
 179 untangle coded message
 180   =  location
 181   ++ ": "
 182   ++ message
 183   ++ details
 184   ++ "\n"
 185   where
 186     (location, details)
 187       = case (span not_bar coded) of { (location, rest) ->
 188         case rest of
 189           ('|':details) -> (location, ' ' : details)
 190           _             -> (location, "")
 191         }
 192     not_bar c = c /= '|'
 193 \end{code}