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, addWarnLocHdrLine, dontAddErrLoc,
  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 addWarnLocHdrLine   :: SrcLoc -> Message -> Message -> Message
  54         -- Used by Lint and other system stuff
  55         -- Always print qualified, return a Message
  56
  57 addShortErrLocLine locn print_unqual msg
  58   = (locn, doc (mkErrStyle print_unqual))
  59   where
  60     doc = mkErrDoc locn msg
  61
  62 addShortWarnLocLine locn print_unqual msg
  63   = (locn, doc (mkErrStyle print_unqual))
  64   where
  65     doc = mkWarnDoc locn msg
  66
  67 addErrLocHdrLine locn hdr msg
  68   = mkErrDoc locn (hdr $$ msg)
  69
  70 addWarnLocHdrLine locn hdr msg
  71   = mkWarnDoc locn (hdr $$ msg)
  72
  73 dontAddErrLoc :: Message -> ErrMsg
  74 dontAddErrLoc msg = (noSrcLoc, msg defaultErrStyle)
  75
  76 mkErrDoc locn msg
  77   | isGoodSrcLoc locn = hang (ppr locn <> colon) 4 msg
  78   | otherwise         = msg
  79
  80 mkWarnDoc locn msg
  81   | isGoodSrcLoc locn = hang (ppr locn <> colon) 4 warn_msg
  82   | otherwise         = warn_msg
  83   where
  84     warn_msg = ptext SLIT("Warning:") <+> msg
  85 \end{code}
  86
  87 \begin{code}
  88 printError :: String -> IO ()
  89 printError str = hPutStrLn stderr str
  90 \end{code}
  91
  92 \begin{code}
  93 type Messages = (Bag WarnMsg, Bag ErrMsg)
  94
  95 emptyMessages :: Messages
  96 emptyMessages = (emptyBag, emptyBag)
  97
  98 errorsFound :: DynFlags -> Messages -> Bool
  99 -- The dyn-flags are used to see if the user has specified
 100 -- -Werorr, which says that warnings should be fatal
 101 errorsFound dflags (warns, errs)
 102   | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
 103   | otherwise                   = not (isEmptyBag errs)
 104
 105 printErrorsAndWarnings :: Messages -> IO ()
 106         -- Don't print any warnings if there are errors
 107 printErrorsAndWarnings (warns, errs)
 108   | no_errs && no_warns  = return ()
 109   | no_errs              = printErrs (pprBagOfWarnings warns)
 110   | otherwise            = printErrs (pprBagOfErrors   errs)
 111   where
 112     no_warns = isEmptyBag warns
 113     no_errs  = isEmptyBag errs
 114
 115 pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc
 116 pprBagOfErrors bag_of_errors
 117   = Pretty.vcat [Pretty.text "" Pretty.$$ p | (_,p) <- sorted_errs ]
 118     where
 119       bag_ls      = bagToList bag_of_errors
 120       sorted_errs = sortLt occ'ed_before bag_ls
 121
 122       occ'ed_before (a,_) (b,_) = LT == compare a b
 123
 124 pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc
 125 pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
 126 \end{code}
 127
 128 \begin{code}
 129 ghcExit :: Int -> IO ()
 130 ghcExit val
 131   | val == 0  = exitWith ExitSuccess
 132   | otherwise = do hPutStr stderr "\nCompilation had errors\n\n"
 133                    exitWith (ExitFailure val)
 134 \end{code}
 135
 136 \begin{code}
 137 doIfSet :: Bool -> IO () -> IO ()
 138 doIfSet flag action | flag      = action
 139                     | otherwise = return ()
 140
 141 doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
 142 doIfSet_dyn dflags flag action | dopt flag dflags = action
 143                                | otherwise        = return ()
 144 \end{code}
 145
 146 \begin{code}
 147 showPass :: DynFlags -> String -> IO ()
 148 showPass dflags what
 149   | verbosity dflags >= 2 = hPutStr stderr ("*** "++what++":\n")
 150   | otherwise             = return ()
 151
 152 dumpIfSet :: Bool -> String -> SDoc -> IO ()
 153 dumpIfSet flag hdr doc
 154   | not flag   = return ()
 155   | otherwise  = printDump (mkDumpDoc hdr doc)
 156
 157 dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 158 dumpIfSet_core dflags flag hdr doc
 159   | dopt flag dflags
 160         || verbosity dflags >= 4
 161         || dopt Opt_D_verbose_core2core dflags  = printDump (mkDumpDoc hdr doc)
 162   | otherwise                                   = return ()
 163
 164 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 165 dumpIfSet_dyn dflags flag hdr doc
 166   | dopt flag dflags || verbosity dflags >= 4
 167   = if   flag `elem` [Opt_D_dump_stix, Opt_D_dump_asm]
 168     then printForC stdout (mkDumpDoc hdr doc)
 169     else printDump (mkDumpDoc hdr doc)
 170   | otherwise
 171   = return ()
 172
 173 dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
 174 dumpIfSet_dyn_or dflags flags hdr doc
 175   | or [dopt flag dflags | flag <- flags]
 176   || verbosity dflags >= 4
 177   = printDump (mkDumpDoc hdr doc)
 178   | otherwise = return ()
 179
 180 mkDumpDoc hdr doc
 181    = vcat [text "",
 182            line <+> text hdr <+> line,
 183            doc,
 184            text ""]
 185      where
 186         line = text (replicate 20 '=')
 187 \end{code}