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, dontAddErrLoc,
  12
  13         printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
  14
  15         ghcExit,
  16         doIfSet, doIfSet_dyn, dumpIfSet, 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 addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg
  41
  42 addShortErrLocLine locn rest_of_err_msg
  43   | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4
  44                                     rest_of_err_msg)
  45   | otherwise         = (locn, rest_of_err_msg)
  46
  47 addErrLocHdrLine locn hdr rest_of_err_msg
  48   = ( locn
  49     , hang (ppr locn <> colon<+> hdr)
  50          4 rest_of_err_msg
  51     )
  52
  53 addShortWarnLocLine locn rest_of_err_msg
  54   | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4
  55                                     (ptext SLIT("Warning:") <+> rest_of_err_msg))
  56   | otherwise         = (locn, rest_of_err_msg)
  57
  58 dontAddErrLoc :: Message -> ErrMsg
  59 dontAddErrLoc msg = (noSrcLoc, msg)
  60
  61 \end{code}
  62
  63
  64 \begin{code}
  65 type Messages = (Bag WarnMsg, Bag ErrMsg)
  66
  67 errorsFound :: Messages -> Bool
  68 errorsFound (warns, errs) = not (isEmptyBag errs)
  69
  70 warningsFound :: Messages -> Bool
  71 warningsFound (warns, errs) = not (isEmptyBag warns)
  72
  73 printErrorsAndWarnings :: PrintUnqualified -> Messages -> IO ()
  74         -- Don't print any warnings if there are errors
  75 printErrorsAndWarnings unqual (warns, errs)
  76   | no_errs && no_warns  = return ()
  77   | no_errs              = printErrs unqual (pprBagOfWarnings warns)
  78   | otherwise            = printErrs unqual (pprBagOfErrors   errs)
  79   where
  80     no_warns = isEmptyBag warns
  81     no_errs  = isEmptyBag errs
  82
  83 pprBagOfErrors :: Bag ErrMsg -> SDoc
  84 pprBagOfErrors bag_of_errors
  85   = vcat [text "" $$ p | (_,p) <- sorted_errs ]
  86     where
  87       bag_ls      = bagToList bag_of_errors
  88       sorted_errs = sortLt occ'ed_before bag_ls
  89
  90       occ'ed_before (a,_) (b,_) = LT == compare a b
  91
  92 pprBagOfWarnings :: Bag WarnMsg -> SDoc
  93 pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
  94 \end{code}
  95
  96 \begin{code}
  97 ghcExit :: Int -> IO ()
  98 ghcExit val
  99   | val == 0  = exitWith ExitSuccess
 100   | otherwise = do hPutStr stderr "\nCompilation had errors\n\n"
 101                    exitWith (ExitFailure val)
 102 \end{code}
 103
 104 \begin{code}
 105 doIfSet :: Bool -> IO () -> IO ()
 106 doIfSet flag action | flag      = action
 107                     | otherwise = return ()
 108
 109 doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
 110 doIfSet_dyn dflags flag action | dopt flag dflags = action
 111                                | otherwise        = return ()
 112 \end{code}
 113
 114 \begin{code}
 115 showPass :: DynFlags -> String -> IO ()
 116 showPass dflags what
 117   | dopt Opt_D_show_passes dflags = hPutStr stderr ("*** "++what++":\n")
 118   | otherwise                     = return ()
 119
 120 dumpIfSet :: Bool -> String -> SDoc -> IO ()
 121 dumpIfSet flag hdr doc
 122   | not flag   = return ()
 123   | otherwise  = printDump (dump hdr doc)
 124
 125 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 126 dumpIfSet_dyn dflags flag hdr doc
 127   | not (dopt flag dflags)  = return ()
 128   | otherwise               = printDump (dump hdr doc)
 129
 130 dump hdr doc
 131    = vcat [text "",
 132            line <+> text hdr <+> line,
 133            doc,
 134            text ""]
 135      where
 136         line = text (take 20 (repeat '='))
 137 \end{code}