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,
   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 printErrorsAndWarnings :: PrintUnqualified -> Messages -> IO ()
  71         -- Don't print any warnings if there are errors
  72 printErrorsAndWarnings unqual (warns, errs)
  73   | no_errs && no_warns  = return ()
  74   | no_errs              = printErrs unqual (pprBagOfWarnings warns)
  75   | otherwise            = printErrs unqual (pprBagOfErrors   errs)
  76   where
  77     no_warns = isEmptyBag warns
  78     no_errs  = isEmptyBag errs
  79
  80 pprBagOfErrors :: Bag ErrMsg -> SDoc
  81 pprBagOfErrors bag_of_errors
  82   = vcat [text "" $$ p | (_,p) <- sorted_errs ]
  83     where
  84       bag_ls      = bagToList bag_of_errors
  85       sorted_errs = sortLt occ'ed_before bag_ls
  86
  87       occ'ed_before (a,_) (b,_) = LT == compare a b
  88
  89 pprBagOfWarnings :: Bag WarnMsg -> SDoc
  90 pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
  91 \end{code}
  92
  93 \begin{code}
  94 ghcExit :: Int -> IO ()
  95 ghcExit val
  96   | val == 0  = exitWith ExitSuccess
  97   | otherwise = do hPutStr stderr "\nCompilation had errors\n\n"
  98                    exitWith (ExitFailure val)
  99 \end{code}
 100
 101 \begin{code}
 102 doIfSet :: Bool -> IO () -> IO ()
 103 doIfSet flag action | flag      = action
 104                     | otherwise = return ()
 105
 106 doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
 107 doIfSet_dyn dflags flag action | dopt flag dflags = action
 108                                | otherwise        = return ()
 109 \end{code}
 110
 111 \begin{code}
 112 showPass :: DynFlags -> String -> IO ()
 113 showPass dflags what
 114   | dopt Opt_D_show_passes dflags = hPutStr stderr ("*** "++what++":\n")
 115   | otherwise                     = return ()
 116
 117 dumpIfSet :: Bool -> String -> SDoc -> IO ()
 118 dumpIfSet flag hdr doc
 119   | not flag   = return ()
 120   | otherwise  = printDump (dump hdr doc)
 121
 122 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 123 dumpIfSet_dyn dflags flag hdr doc
 124   | not (dopt flag dflags)  = return ()
 125   | otherwise               = printDump (dump hdr doc)
 126
 127 dump hdr doc
 128    = vcat [text "",
 129            line <+> text hdr <+> line,
 130            doc,
 131            text ""]
 132      where
 133         line = text (take 20 (repeat '='))
 134 \end{code}