ghc/compiler/main/ErrUtils.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1995
   3 %
   4 \section[ErrsUtils]{Utilities for error reporting}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module ErrUtils (
  10
  11         Error(..),
  12         addErrLoc, addShortErrLocLine,
  13         dontAddErrLoc, pprBagOfErrors,
  14
  15         TcError(..), TcWarning(..), Message(..),
  16         mkTcErr, arityErr
  17
  18     ) where
  19
  20 import Ubiq{-uitous-}
  21
  22 import Bag              ( bagToList )
  23 import PprStyle         ( PprStyle(..) )
  24 import Pretty
  25 import SrcLoc           ( mkUnknownSrcLoc, SrcLoc{-instance-} )
  26 \end{code}
  27
  28 \begin{code}
  29 type Error   = PprStyle -> Pretty
  30
  31 addErrLoc :: SrcLoc -> String -> Error -> Error
  32 addErrLoc locn title rest_of_err_msg sty
  33   = ppHang (ppBesides [ppr PprForUser locn,
  34                        if null title then ppNil else ppStr (": " ++ title),
  35                        ppChar ':'])
  36          4 (rest_of_err_msg sty)
  37
  38 addShortErrLocLine :: SrcLoc -> Error -> Error
  39 addShortErrLocLine locn rest_of_err_msg sty
  40   = ppHang (ppBeside (ppr PprForUser locn) (ppChar ':'))
  41          4 (rest_of_err_msg sty)
  42
  43 dontAddErrLoc :: String -> Error -> Error
  44 dontAddErrLoc title rest_of_err_msg sty
  45   = ppHang (ppBesides [ppStr title, ppChar ':'])
  46          4 (rest_of_err_msg sty)
  47
  48 pprBagOfErrors :: PprStyle -> Bag Error -> Pretty
  49 pprBagOfErrors sty bag_of_errors
  50   = let  pretties = map ( \ e -> e sty ) (bagToList bag_of_errors)  in
  51     ppAboves (map (\ p -> ppAbove ppSP p) pretties)
  52 \end{code}
  53
  54 TypeChecking Errors
  55 ~~~~~~~~~~~~~~~~~~~
  56
  57 \begin{code}
  58 type Message   = PprStyle -> Pretty
  59 type TcError   = Message
  60 type TcWarning = Message
  61
  62
  63 mkTcErr :: SrcLoc               -- Where
  64         -> [Message]            -- Context
  65         -> Message              -- What went wrong
  66         -> TcError              -- The complete error report
  67
  68 mkTcErr locn ctxt msg sty
  69   = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
  70          4 (ppAboves [msg sty | msg <- ctxt])
  71
  72
  73 arityErr kind name n m sty =
  74     ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
  75                 n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
  76     where
  77         errmsg = kind ++ " has too " ++ quantity ++ " arguments"
  78         quantity | m < n     = "few"
  79                  | otherwise = "many"
  80         n_arguments | n == 0 = ppStr "no arguments"
  81                     | n == 1 = ppStr "1 argument"
  82                     | True   = ppCat [ppInt n, ppStr "arguments"]
  83 \end{code}