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         Messages, errorsFound, emptyMessages,
  10
  11         addShortErrLocLine, addShortWarnLocLine,
  12         addErrLocHdrLine,
  13
  14         printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
  15
  16         printError,
  17         ghcExit,
  18         doIfSet, doIfSet_dyn,
  19         dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,
  20         showPass
  21     ) where
  22
  23 #include "HsVersions.h"
  24
  25 import Bag              ( Bag, bagToList, isEmptyBag, emptyBag )
  26 import SrcLoc           ( SrcLoc, noSrcLoc, isGoodSrcLoc )
  27 import Util             ( sortLt )
  28 import Outputable
  29 import qualified Pretty
  30 import CmdLineOpts      ( DynFlags(..), DynFlag(..), dopt )
  31
  32 import List             ( replicate )
  33 import System           ( ExitCode(..), exitWith )
  34 import IO               ( hPutStr, hPutStrLn, stderr, stdout )
  35 \end{code}
  36
  37 \begin{code}
  38 type MsgWithLoc = (SrcLoc, Pretty.Doc)
  39         -- The SrcLoc is used for sorting errors into line-number order
  40         -- NB  Pretty.Doc not SDoc: we deal with the printing style (in ptic
  41         -- whether to qualify an External Name) at the error occurrence
  42
  43 type ErrMsg  = MsgWithLoc
  44 type WarnMsg = MsgWithLoc
  45 type Message = SDoc
  46
  47 addShortErrLocLine  :: SrcLoc -> PrintUnqualified -> Message -> ErrMsg
  48 addShortWarnLocLine :: SrcLoc -> PrintUnqualified -> Message -> WarnMsg
  49         -- Used heavily by renamer/typechecker
  50         -- Be refined about qualification, return an ErrMsg
  51
  52 addErrLocHdrLine    :: SrcLoc -> Message -> Message -> Message
  53         -- Used by Lint and other system stuff
  54         -- Always print qualified, return a Message
  55
  56 addShortErrLocLine locn print_unqual msg
  57   = (locn, doc (mkErrStyle print_unqual))
  58   where
  59     doc = mkErrDoc locn msg
  60
  61 addShortWarnLocLine locn print_unqual msg
  62   = (locn, doc (mkErrStyle print_unqual))
  63   where
  64     doc = mkWarnDoc locn msg
  65
  66 addErrLocHdrLine locn hdr msg
  67   = mkErrDoc locn (hdr $$ msg)
  68
  69 mkErrDoc locn msg
  70   | isGoodSrcLoc locn = hang (ppr locn <> colon) 4 msg
  71   | otherwise         = msg
  72
  73 mkWarnDoc locn msg = mkErrDoc locn msg
  74 \end{code}
  75
  76 \begin{code}
  77 printError :: String -> IO ()
  78 printError str = hPutStrLn stderr str
  79 \end{code}
  80
  81 \begin{code}
  82 type Messages = (Bag WarnMsg, Bag ErrMsg)
  83
  84 emptyMessages :: Messages
  85 emptyMessages = (emptyBag, emptyBag)
  86
  87 errorsFound :: DynFlags -> Messages -> Bool
  88 -- The dyn-flags are used to see if the user has specified
  89 -- -Werorr, which says that warnings should be fatal
  90 errorsFound dflags (warns, errs)
  91   | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
  92   | otherwise                   = not (isEmptyBag errs)
  93
  94 printErrorsAndWarnings :: Messages -> IO ()
  95         -- Don't print any warnings if there are errors
  96 printErrorsAndWarnings (warns, errs)
  97   | no_errs && no_warns  = return ()
  98   | no_errs              = printErrs (pprBagOfWarnings warns)
  99   | otherwise            = printErrs (pprBagOfErrors   errs)
 100   where
 101     no_warns = isEmptyBag warns
 102     no_errs  = isEmptyBag errs
 103
 104 pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc
 105 pprBagOfErrors bag_of_errors
 106   = Pretty.vcat [Pretty.text "" Pretty.$$ p | (_,p) <- sorted_errs ]
 107     where
 108       bag_ls      = bagToList bag_of_errors
 109       sorted_errs = sortLt occ'ed_before bag_ls
 110
 111       occ'ed_before (a,_) (b,_) = LT == compare a b
 112
 113 pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc
 114 pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
 115 \end{code}
 116
 117 \begin{code}
 118 ghcExit :: Int -> IO ()
 119 ghcExit val
 120   | val == 0  = exitWith ExitSuccess
 121   | otherwise = do hPutStr stderr "\nCompilation had errors\n\n"
 122                    exitWith (ExitFailure val)
 123 \end{code}
 124
 125 \begin{code}
 126 doIfSet :: Bool -> IO () -> IO ()
 127 doIfSet flag action | flag      = action
 128                     | otherwise = return ()
 129
 130 doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
 131 doIfSet_dyn dflags flag action | dopt flag dflags = action
 132                                | otherwise        = return ()
 133 \end{code}
 134
 135 \begin{code}
 136 showPass :: DynFlags -> String -> IO ()
 137 showPass dflags what
 138   | verbosity dflags >= 2 = hPutStr stderr ("*** "++what++":\n")
 139   | otherwise             = return ()
 140
 141 dumpIfSet :: Bool -> String -> SDoc -> IO ()
 142 dumpIfSet flag hdr doc
 143   | not flag   = return ()
 144   | otherwise  = printDump (mkDumpDoc hdr doc)
 145
 146 dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 147 dumpIfSet_core dflags flag hdr doc
 148   | dopt flag dflags
 149         || verbosity dflags >= 4
 150         || dopt Opt_D_verbose_core2core dflags  = printDump (mkDumpDoc hdr doc)
 151   | otherwise                                   = return ()
 152
 153 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 154 dumpIfSet_dyn dflags flag hdr doc
 155   | dopt flag dflags || verbosity dflags >= 4
 156   = if   flag `elem` [Opt_D_dump_stix, Opt_D_dump_asm]
 157     then printForC stdout (mkDumpDoc hdr doc)
 158     else printDump (mkDumpDoc hdr doc)
 159   | otherwise
 160   = return ()
 161
 162 dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
 163 dumpIfSet_dyn_or dflags flags hdr doc
 164   | or [dopt flag dflags | flag <- flags]
 165   || verbosity dflags >= 4
 166   = printDump (mkDumpDoc hdr doc)
 167   | otherwise = return ()
 168
 169 mkDumpDoc hdr doc
 170    = vcat [text "",
 171            line <+> text hdr <+> line,
 172            doc,
 173            text ""]
 174      where
 175         line = text (replicate 20 '=')
 176 \end{code}