ghc/lib/ghc/GHCerr.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4
   5 \section[GHCerr]{Module @GHCerr@}
   6
   7 The GHCerr 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., GHCbase), 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 GHCerr
  17
  18        (
  19          irrefutPatError
  20        , noDefaultMethodError
  21        , noExplicitMethodError
  22        , nonExhaustiveGuardsError
  23        , patError
  24        , recConError
  25        , recUpdError               -- :: String -> a
  26
  27        , absentErr, parError       -- :: a
  28        , seqError                  -- :: a
  29
  30        , error                     -- :: String -> a
  31        , ioError                   -- :: String -> a
  32        , assert__                  -- :: String -> Bool -> a -> a
  33        ) where
  34
  35 --import Prelude
  36 import PrelBase
  37 import IOBase
  38 import Addr
  39 import Foreign  ( StablePtr, deRefStablePtr )
  40 import PrelList ( span )
  41
  42
  43 ---------------------------------------------------------------
  44 -- HACK: Magic unfoldings not implemented for unboxed lists
  45 --       Need to define a "build" to avoid undefined symbol
  46 -- in this module to avoid .hi proliferation.
  47
  48 build   = error "GHCbase.build"
  49 augment = error "GHCbase.augment"
  50 --{-# GENERATE_SPECS build a #-}
  51 --build                 :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
  52 --build g       = g (:) []
  53 \end{code}
  54
  55 %*********************************************************
  56 %*                                                      *
  57 \subsection{Error-ish functions}
  58 %*                                                      *
  59 %*********************************************************
  60
  61 \begin{code}
  62 errorIO :: IO () -> a
  63
  64 errorIO (IO io)
  65   = case (errorIO# io) of
  66       _ -> bottom
  67   where
  68     bottom = bottom -- Never evaluated
  69
  70 ioError :: String -> a
  71 ioError s = error__ ( \ x -> _ccall_ IOErrorHdrHook x ) s
  72
  73 -- error stops execution and displays an error message
  74 error :: String -> a
  75 error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s
  76
  77 error__ :: (Addr{-FILE *-} -> IO ()) -> String -> a
  78
  79 error__ msg_hdr s
  80 #ifdef __PARALLEL_HASKELL__
  81   = errorIO (msg_hdr sTDERR{-msg hdr-}  >>
  82              _ccall_ fflush sTDERR      >>
  83              fputs sTDERR s             >>
  84              _ccall_ fflush sTDERR      >>
  85              _ccall_ stg_exit (1::Int)
  86             )
  87 #else
  88   = errorIO (msg_hdr sTDERR{-msg hdr-}  >>
  89              _ccall_ fflush sTDERR      >>
  90              fputs sTDERR s             >>
  91              _ccall_ fflush sTDERR      >>
  92              _ccall_ getErrorHandler    >>= \ errorHandler ->
  93              if errorHandler == (-1::Int) then
  94                 _ccall_ stg_exit (1::Int)
  95              else
  96                 _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
  97                                                 >>= \ osptr ->
  98                 _ccall_ decrementErrorCount     >>= \ () ->
  99                 deRefStablePtr osptr            >>= \ oact ->
 100                 oact
 101             )
 102 #endif {- !parallel -}
 103   where
 104     sTDERR = (``stderr'' :: Addr)
 105 \end{code}
 106
 107 %*********************************************************
 108 %*                                                       *
 109 \subsection{Compiler generated errors + local utils}
 110 %*                                                       *
 111 %*********************************************************
 112
 113 Used for compiler-generated error message;
 114 encoding saves bytes of string junk.
 115
 116 \begin{code}
 117 absentErr, parError, seqError :: a
 118
 119 absentErr = error "Oops! The program has entered an `absent' argument!\n"
 120 parError  = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n"
 121 seqError = error "Oops! Entered seqError (a GHC bug -- please report it!)\n"
 122
 123 \end{code}
 124
 125 \begin{code}
 126 irrefutPatError
 127  , noDefaultMethodError
 128  , noExplicitMethodError
 129  , nonExhaustiveGuardsError
 130  , patError
 131  , recConError
 132  , recUpdError :: String -> a
 133
 134 noDefaultMethodError     s = error ("noDefaultMethodError:"++s)
 135 noExplicitMethodError    s = error ("No default method for class operation "++s)
 136 irrefutPatError          s = error (untangle s "Irrefutable pattern failed for pattern")
 137 nonExhaustiveGuardsError s = error (untangle s "Non-exhaustive guards in")
 138 patError                 s = error (untangle s "Non-exhaustive patterns in")
 139 recConError              s = error (untangle s "Missing field in record construction:")
 140 recUpdError              s = error (untangle s "Record to doesn't contain field(s) to be updated")
 141
 142
 143 assert__ :: String -> Bool -> a -> a
 144 assert__ str pred v
 145   | pred      = v
 146   | otherwise = error (untangle str "Assertion failed")
 147
 148 \end{code}
 149
 150
 151 (untangle coded message) expects "coded" to be of the form
 152
 153         "location|details"
 154
 155 It prints
 156
 157         location message details
 158
 159 \begin{code}
 160 untangle coded message
 161   =  location
 162   ++ ": "
 163   ++ message
 164   ++ details
 165   ++ "\n"
 166   where
 167     (location, details)
 168       = case (span not_bar coded) of { (location, rest) ->
 169         case rest of
 170           ('|':details) -> (location, ' ' : details)
 171           _             -> (location, "")
 172         }
 173     not_bar c = c /= '|'
 174 \end{code}
 175
 176 -- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook,
 177 -- but the former does exactly the same as the latter, so I nuked it.
 178 --              SLPJ Jan 97
 179 -- patError__ = error__ (\ x -> _ccall_ PatErrorHdrHook x)
 180