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         pprBagOfErrors, pprBagOfWarnings,
  13         ghcExit,
  14         doIfSet, dumpIfSet
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 import Bag              ( Bag, bagToList )
  20 import SrcLoc           ( SrcLoc, noSrcLoc )
  21 import Util             ( sortLt )
  22 import Outputable
  23 \end{code}
  24
  25 \begin{code}
  26 type MsgWithLoc = (SrcLoc, SDoc)
  27
  28 type ErrMsg  = MsgWithLoc
  29 type WarnMsg = MsgWithLoc
  30 type Message = SDoc
  31
  32 addShortErrLocLine  :: SrcLoc -> Message -> ErrMsg
  33 addErrLocHdrLine    :: SrcLoc -> Message -> Message -> ErrMsg
  34 addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg
  35
  36 addShortErrLocLine locn rest_of_err_msg
  37   = ( locn
  38     , hang (ppr locn <> colon)
  39          4 rest_of_err_msg
  40     )
  41
  42 addErrLocHdrLine locn hdr rest_of_err_msg
  43   = ( locn
  44     , hang (ppr locn <> colon<+> hdr)
  45          4 rest_of_err_msg
  46     )
  47
  48 addShortWarnLocLine locn rest_of_err_msg
  49   = ( locn
  50     , hang (ppr locn <> ptext SLIT(": Warning:"))
  51         4 rest_of_err_msg
  52     )
  53
  54 dontAddErrLoc :: String -> Message -> ErrMsg
  55 dontAddErrLoc title rest_of_err_msg
  56  | null title = (noSrcLoc, rest_of_err_msg)
  57  | otherwise  =
  58     ( noSrcLoc, hang (hcat [text title, char ':'])
  59                   4  rest_of_err_msg )
  60
  61 pprBagOfErrors :: Bag ErrMsg -> SDoc
  62 pprBagOfErrors bag_of_errors
  63   = vcat [p $$ text "" | (_,p) <- sorted_errs ]
  64     where
  65       bag_ls      = bagToList bag_of_errors
  66       sorted_errs = sortLt occ'ed_before bag_ls
  67
  68       occ'ed_before (a,_) (b,_) = LT == compare a b
  69
  70 pprBagOfWarnings :: Bag WarnMsg -> SDoc
  71 pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
  72 \end{code}
  73
  74 \begin{code}
  75 ghcExit :: Int -> IO ()
  76
  77 ghcExit val
  78   = if val /= 0
  79     then error "Compilation had errors\n"
  80     else return ()
  81 \end{code}
  82
  83 \begin{code}
  84 doIfSet :: Bool -> IO () -> IO ()
  85 doIfSet flag action | flag      = action
  86                     | otherwise = return ()
  87 \end{code}
  88
  89 \begin{code}
  90 dumpIfSet :: Bool -> String -> SDoc -> IO ()
  91 dumpIfSet flag hdr doc
  92   | not flag  = return ()
  93   | otherwise = printDump dump
  94   where
  95     dump = vcat [text "",
  96                  line <+> text hdr <+> line,
  97                  doc,
  98                  text ""]
  99     line = text (take 20 (repeat '='))
 100 \end{code}