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,
   9         addShortErrLocLine, addShortWarnLocLine,
  10         addErrLocHdrLine,
  11         dontAddErrLoc,
  12         printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
  13         ghcExit,
  14         doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_dyn
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 import Bag              ( Bag, bagToList, isEmptyBag )
  20 import SrcLoc           ( SrcLoc, noSrcLoc )
  21 import Util             ( sortLt )
  22 import Outputable
  23 import CmdLineOpts      ( DynFlags, DynFlag, dopt )
  24
  25 import System           ( ExitCode(..), exitWith )
  26 import IO               ( hPutStr, stderr )
  27 \end{code}
  28
  29 \begin{code}
  30 type MsgWithLoc = (SrcLoc, SDoc)
  31
  32 type ErrMsg  = MsgWithLoc
  33 type WarnMsg = MsgWithLoc
  34 type Message = SDoc
  35
  36 addShortErrLocLine  :: SrcLoc -> Message -> ErrMsg
  37 addErrLocHdrLine    :: SrcLoc -> Message -> Message -> ErrMsg
  38 addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg
  39
  40 addShortErrLocLine locn rest_of_err_msg
  41   = ( locn
  42     , hang (ppr locn <> colon)
  43          4 rest_of_err_msg
  44     )
  45
  46 addErrLocHdrLine locn hdr rest_of_err_msg
  47   = ( locn
  48     , hang (ppr locn <> colon<+> hdr)
  49          4 rest_of_err_msg
  50     )
  51
  52 addShortWarnLocLine locn rest_of_err_msg
  53   = ( locn
  54     , hang (ppr locn <> colon)
  55          4 (ptext SLIT("Warning:") <+> rest_of_err_msg)
  56     )
  57
  58 dontAddErrLoc :: String -> Message -> ErrMsg
  59 dontAddErrLoc title rest_of_err_msg
  60  | null title = (noSrcLoc, rest_of_err_msg)
  61  | otherwise  =
  62     ( noSrcLoc, hang (text title <> colon) 4 rest_of_err_msg )
  63
  64 printErrorsAndWarnings :: (Bag WarnMsg, Bag ErrMsg) -> IO ()
  65         -- Don't print any warnings if there are errors
  66 printErrorsAndWarnings (warns, errs)
  67   | no_errs && no_warns  = return ()
  68   | no_errs              = printErrs (pprBagOfWarnings warns)
  69   | otherwise            = printErrs (pprBagOfErrors   errs)
  70   where
  71     no_warns = isEmptyBag warns
  72     no_errs  = isEmptyBag errs
  73
  74 pprBagOfErrors :: Bag ErrMsg -> SDoc
  75 pprBagOfErrors bag_of_errors
  76   = vcat [text "" $$ p | (_,p) <- sorted_errs ]
  77     where
  78       bag_ls      = bagToList bag_of_errors
  79       sorted_errs = sortLt occ'ed_before bag_ls
  80
  81       occ'ed_before (a,_) (b,_) = LT == compare a b
  82
  83 pprBagOfWarnings :: Bag WarnMsg -> SDoc
  84 pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
  85 \end{code}
  86
  87 \begin{code}
  88 ghcExit :: Int -> IO ()
  89 ghcExit val
  90   | val == 0  = exitWith ExitSuccess
  91   | otherwise = do hPutStr stderr "\nCompilation had errors\n\n"
  92                    exitWith (ExitFailure val)
  93 \end{code}
  94
  95 \begin{code}
  96 doIfSet :: Bool -> IO () -> IO ()
  97 doIfSet flag action | flag      = action
  98                     | otherwise = return ()
  99
 100 doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
 101 doIfSet_dyn dflags flag action | dopt flag dflags = action
 102                                | otherwise        = return ()
 103 \end{code}
 104
 105 \begin{code}
 106 dumpIfSet :: Bool -> String -> SDoc -> IO ()
 107 dumpIfSet flag hdr doc
 108   | not flag   = return ()
 109   | otherwise  = printDump (dump hdr doc)
 110
 111 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 112 dumpIfSet_dyn dflags flag hdr doc
 113   | not (dopt flag dflags)  = return ()
 114   | otherwise               = printDump (dump hdr doc)
 115
 116 dump hdr doc
 117    = vcat [text "",
 118            line <+> text hdr <+> line,
 119            doc,
 120            text ""]
 121      where
 122         line = text (take 20 (repeat '='))
 123 \end{code}