ghc/compiler/main/ErrUtils.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1998
   3 %
   4 \section[ErrsUtils]{Utilities for error reporting}
   5
   6 \begin{code}
   7 module ErrUtils (
   8         ErrMsg, WarnMsg, Message, Messages, errorsFound, warningsFound,
   9
  10         addShortErrLocLine, addShortWarnLocLine,
  11         addErrLocHdrLine, addWarnLocHdrLine, dontAddErrLoc,
  12
  13         printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
  14
  15         ghcExit,
  16         doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, showPass
  17     ) where
  18
  19 #include "HsVersions.h"
  20
  21 import Bag              ( Bag, bagToList, isEmptyBag )
  22 import SrcLoc           ( SrcLoc, noSrcLoc, isGoodSrcLoc )
  23 import Util             ( sortLt )
  24 import Outputable
  25 import CmdLineOpts      ( DynFlags(..), DynFlag(..), dopt )
  26
  27 import System           ( ExitCode(..), exitWith )
  28 import IO               ( hPutStr, stderr )
  29 \end{code}
  30
  31 \begin{code}
  32 type MsgWithLoc = (SrcLoc, SDoc)
  33
  34 type ErrMsg  = MsgWithLoc
  35 type WarnMsg = MsgWithLoc
  36 type Message = SDoc
  37
  38 addShortErrLocLine  :: SrcLoc -> Message -> ErrMsg
  39 addErrLocHdrLine    :: SrcLoc -> Message -> Message -> ErrMsg
  40 addWarnLocHdrLine    :: SrcLoc -> Message -> Message -> ErrMsg
  41 addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg
  42
  43 addShortErrLocLine locn rest_of_err_msg
  44   | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4
  45                                     rest_of_err_msg)
  46   | otherwise         = (locn, rest_of_err_msg)
  47
  48 addErrLocHdrLine locn hdr rest_of_err_msg
  49   = ( locn
  50     , hang (ppr locn <> colon<+> hdr)
  51          4 rest_of_err_msg
  52     )
  53
  54 addWarnLocHdrLine locn hdr rest_of_err_msg
  55   = ( locn
  56     , hang (ppr locn <> colon <+> ptext SLIT("Warning:") <+> hdr)
  57          4 (rest_of_err_msg)
  58     )
  59
  60 addShortWarnLocLine locn rest_of_err_msg
  61   | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4
  62                                     (ptext SLIT("Warning:") <+> rest_of_err_msg))
  63   | otherwise         = (locn, rest_of_err_msg)
  64
  65 dontAddErrLoc :: Message -> ErrMsg
  66 dontAddErrLoc msg = (noSrcLoc, msg)
  67
  68 \end{code}
  69
  70
  71 \begin{code}
  72 type Messages = (Bag WarnMsg, Bag ErrMsg)
  73
  74 errorsFound :: Messages -> Bool
  75 errorsFound (warns, errs) = not (isEmptyBag errs)
  76
  77 warningsFound :: Messages -> Bool
  78 warningsFound (warns, errs) = not (isEmptyBag warns)
  79
  80 printErrorsAndWarnings :: PrintUnqualified -> Messages -> IO ()
  81         -- Don't print any warnings if there are errors
  82 printErrorsAndWarnings unqual (warns, errs)
  83   | no_errs && no_warns  = return ()
  84   | no_errs              = printErrs unqual (pprBagOfWarnings warns)
  85   | otherwise            = printErrs unqual (pprBagOfErrors   errs)
  86   where
  87     no_warns = isEmptyBag warns
  88     no_errs  = isEmptyBag errs
  89
  90 pprBagOfErrors :: Bag ErrMsg -> SDoc
  91 pprBagOfErrors bag_of_errors
  92   = vcat [text "" $$ p | (_,p) <- sorted_errs ]
  93     where
  94       bag_ls      = bagToList bag_of_errors
  95       sorted_errs = sortLt occ'ed_before bag_ls
  96
  97       occ'ed_before (a,_) (b,_) = LT == compare a b
  98
  99 pprBagOfWarnings :: Bag WarnMsg -> SDoc
 100 pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
 101 \end{code}
 102
 103 \begin{code}
 104 ghcExit :: Int -> IO ()
 105 ghcExit val
 106   | val == 0  = exitWith ExitSuccess
 107   | otherwise = do hPutStr stderr "\nCompilation had errors\n\n"
 108                    exitWith (ExitFailure val)
 109 \end{code}
 110
 111 \begin{code}
 112 doIfSet :: Bool -> IO () -> IO ()
 113 doIfSet flag action | flag      = action
 114                     | otherwise = return ()
 115
 116 doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
 117 doIfSet_dyn dflags flag action | dopt flag dflags = action
 118                                | otherwise        = return ()
 119 \end{code}
 120
 121 \begin{code}
 122 showPass :: DynFlags -> String -> IO ()
 123 showPass dflags what
 124   | verbosity dflags >= 2 = hPutStr stderr ("*** "++what++":\n")
 125   | otherwise             = return ()
 126
 127 dumpIfSet :: Bool -> String -> SDoc -> IO ()
 128 dumpIfSet flag hdr doc
 129   | not flag   = return ()
 130   | otherwise  = printDump (dump hdr doc)
 131
 132 dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 133 dumpIfSet_core dflags flag hdr doc
 134   | dopt flag dflags
 135         || verbosity dflags >= 4
 136         || dopt Opt_D_verbose_core2core dflags  = printDump (dump hdr doc)
 137   | otherwise                                   = return ()
 138
 139 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 140 dumpIfSet_dyn dflags flag hdr doc
 141   | dopt flag dflags || verbosity dflags >= 4 = printDump (dump hdr doc)
 142   | otherwise                                 = return ()
 143
 144 dump hdr doc
 145    = vcat [text "",
 146            line <+> text hdr <+> line,
 147            doc,
 148            text ""]
 149      where
 150         line = text (take 20 (repeat '='))
 151 \end{code}