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         SYN_IE(Error), SYN_IE(Warning), SYN_IE(Message),
  11         addErrLoc,
  12         addShortErrLocLine, addShortWarnLocLine,
  13         dontAddErrLoc,
  14         pprBagOfErrors,
  15         ghcExit,
  16         doIfSet, dumpIfSet
  17     ) where
  18
  19 IMP_Ubiq(){-uitous-}
  20
  21 import CmdLineOpts      ( opt_PprUserLength )
  22 import Bag              --( bagToList )
  23 import Outputable       ( PprStyle(..), Outputable(..), printErrs )
  24 import Pretty
  25 import SrcLoc           ( noSrcLoc, SrcLoc{-instance-} )
  26 \end{code}
  27
  28 \begin{code}
  29 type Error   = PprStyle -> Doc
  30 type Warning = PprStyle -> Doc
  31 type Message = PprStyle -> Doc
  32
  33 addErrLoc :: SrcLoc -> String -> Error -> Error
  34 addErrLoc locn title rest_of_err_msg sty
  35   = hang (hcat [ppr (PprForUser opt_PprUserLength) locn,
  36                 if null title then empty else text (": " ++ title),
  37                 char ':'])
  38          4 (rest_of_err_msg sty)
  39
  40 addShortErrLocLine, addShortWarnLocLine :: SrcLoc -> Error -> Error
  41
  42 addShortErrLocLine locn rest_of_err_msg sty
  43   = hang ((<>) (ppr (PprForUser opt_PprUserLength) locn) (char ':'))
  44          4 (rest_of_err_msg sty)
  45
  46 addShortWarnLocLine locn rest_of_err_msg sty
  47   = hang ((<>) (ppr (PprForUser opt_PprUserLength) locn) (ptext SLIT(":warning:")))
  48          4 (rest_of_err_msg sty)
  49
  50 dontAddErrLoc :: String -> Error -> Error
  51 dontAddErrLoc title rest_of_err_msg sty
  52   = hang (hcat [text title, char ':'])
  53          4 (rest_of_err_msg sty)
  54
  55 pprBagOfErrors :: PprStyle -> Bag Error -> Doc
  56 pprBagOfErrors sty bag_of_errors
  57   = let  pretties = map ( \ e -> e sty ) (bagToList bag_of_errors)
  58     in
  59     vcat (map (\ p -> ($$) space p) pretties)
  60 \end{code}
  61
  62 \begin{code}
  63 ghcExit :: Int -> IO ()
  64
  65 ghcExit val
  66   = if val /= 0
  67     then error "Compilation had errors\n"
  68     else return ()
  69 \end{code}
  70
  71 \begin{code}
  72 doIfSet :: Bool -> IO () -> IO ()
  73 doIfSet flag action | flag      = action
  74                     | otherwise = return ()
  75 \end{code}
  76
  77 \begin{code}
  78 dumpIfSet :: Bool -> String -> Doc -> IO ()
  79 dumpIfSet flag hdr doc
  80   | not flag  = return ()
  81   | otherwise = printErrs dump
  82   where
  83     dump = (line <+> text hdr <+> line)
  84            $$
  85            doc
  86            $$
  87            text ""
  88     line = text (take 20 (repeat '='))
  89 \end{code}