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        (
  19          irrefutPatError
  20        , noMethodBindingError
  21        , nonExhaustiveGuardsError
  22        , patError
  23        , recSelError
  24        , recConError
  25        , recUpdError               -- :: String -> a
  26
  27        , absentErr, parError       -- :: a
  28        , seqError                  -- :: a
  29
  30        , error                     -- :: String -> a
  31        , ioError                   -- :: String -> a
  32        , assertError               -- :: String -> Bool -> a -> a
  33        ) where
  34
  35 import PrelBase
  36 import PrelIOBase   ( IO(..), catch )
  37 import PrelHandle
  38 import PrelAddr
  39 import PrelList     ( span )
  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 build   = error "GHCbase.build"
  53 augment = error "GHCbase.augment"
  54 --{-# GENERATE_SPECS build a #-}
  55 --build                 :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
  56 --build g       = g (:) []
  57 \end{code}
  58
  59 %*********************************************************
  60 %*                                                      *
  61 \subsection{Error-ish functions}
  62 %*                                                      *
  63 %*********************************************************
  64
  65 \begin{code}
  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 = error__ ``&ErrorHdrHook'' s
  80
  81 -- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook,
  82 -- but the former does exactly the same as the latter, so I nuked it.
  83 --              SLPJ Jan 97
  84 --
  85 -- Hmm..distinguishing between these two kinds of error is quite useful in the
  86 -- compiler sources, printing out a more verbose msg in the case of patter
  87 -- matching failure.
  88 -- So I've reinstated patError to invoke its own message function hook again.
  89 --    SOF 8/98
  90 patError__ x = error__ ``&PatErrorHdrHook'' x
  91
  92 error__ :: Addr{-C function pointer to hook-} -> String -> a
  93
  94 error__ msg_hdr s
  95 #ifdef __PARALLEL_HASKELL__
  96   = errorIO (do
  97      (hFlush stdout) `catch` (\ _ -> return ())
  98      let bs@(ByteArray (_,len) _) = packString s
  99      _ccall_ writeErrString__ msg_hdr bs len
 100      _ccall_ stg_exit (1::Int)
 101     )
 102 #else
 103   = errorIO ( do
 104       (hFlush stdout) `catch` (\ _ -> return ())
 105             -- Note: there's potential for trouble here in a
 106             -- a concurrent setting if an error is flagged after the
 107             -- lock on the stdout handle. (I don't see a possibility
 108             -- of this occurring with the current impl, but still.)
 109       let bs@(ByteArray (_,len) _) = packString s
 110       _ccall_ writeErrString__ msg_hdr bs len
 111       errorHandler <- _ccall_ getErrorHandler
 112       if errorHandler == (-1::Int) then
 113          _ccall_ stg_exit (1::Int)
 114        else do
 115         osptr <- _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
 116         _ccall_ decrementErrorCount
 117         oact  <- deRefStablePtr osptr
 118         oact
 119    )
 120
 121 #endif {- !parallel -}
 122 \end{code}
 123
 124 %*********************************************************
 125 %*                                                       *
 126 \subsection{Compiler generated errors + local utils}
 127 %*                                                       *
 128 %*********************************************************
 129
 130 Used for compiler-generated error message;
 131 encoding saves bytes of string junk.
 132
 133 \begin{code}
 134 absentErr, parError, seqError :: a
 135
 136 absentErr = error "Oops! The program has entered an `absent' argument!\n"
 137 parError  = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n"
 138 seqError = error "Oops! Entered seqError (a GHC bug -- please report it!)\n"
 139
 140 \end{code}
 141
 142 \begin{code}
 143 irrefutPatError
 144    , noMethodBindingError
 145  --, noExplicitMethodError
 146    , nonExhaustiveGuardsError
 147    , patError
 148    , recSelError
 149    , recConError
 150    , recUpdError :: String -> a
 151
 152 --noDefaultMethodError     s = error ("noDefaultMethodError:"++s)
 153 --noExplicitMethodError    s = error ("No default method for class operation "++s)
 154 noMethodBindingError     s = error (untangle s "No instance nor default method for class operation")
 155 irrefutPatError          s = error (untangle s "Irrefutable pattern failed for pattern")
 156 nonExhaustiveGuardsError s = error (untangle s "Non-exhaustive guards in")
 157 recSelError              s = error (untangle s "Missing field in record selection:")
 158 recConError              s = error (untangle s "Missing field in record construction:")
 159 recUpdError              s = error (untangle s "Record to doesn't contain field(s) to be updated")
 160 patError                 s = patError__ (untangle s "Non-exhaustive patterns in")
 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}