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         Message, mkLocMessage, printError,
   9         Severity(..),
  10
  11         ErrMsg, WarnMsg,
  12         errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
  13         Messages, errorsFound, emptyMessages,
  14         mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
  15         printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
  16
  17         ghcExit,
  18         doIfSet, doIfSet_dyn,
  19         dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,
  20
  21         --  * Messages during compilation
  22         putMsg,
  23         errorMsg,
  24         fatalErrorMsg,
  25         compilationProgressMsg,
  26         showPass,
  27         debugTraceMsg,
  28     ) where
  29
  30 #include "HsVersions.h"
  31
  32 import Bag              ( Bag, bagToList, isEmptyBag, emptyBag )
  33 import SrcLoc           ( SrcSpan )
  34 import Util             ( sortLe, global )
  35 import Outputable
  36 import qualified Pretty
  37 import SrcLoc           ( srcSpanStart, noSrcSpan )
  38 import DynFlags         ( DynFlags(..), DynFlag(..), dopt )
  39 import StaticFlags      ( opt_ErrorSpans )
  40
  41 import System.Exit      ( ExitCode(..), exitWith )
  42 import System.IO        ( hPutStrLn, stderr )
  43 import Data.Dynamic
  44
  45
  46 -- -----------------------------------------------------------------------------
  47 -- Basic error messages: just render a message with a source location.
  48
  49 type Message = SDoc
  50
  51 data Severity
  52   = SevInfo
  53   | SevWarning
  54   | SevError
  55   | SevFatal
  56
  57 mkLocMessage :: SrcSpan -> Message -> Message
  58 mkLocMessage locn msg
  59   | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg
  60   | otherwise      = hang (ppr (srcSpanStart locn) <> colon) 4 msg
  61   -- always print the location, even if it is unhelpful.  Error messages
  62   -- are supposed to be in a standard format, and one without a location
  63   -- would look strange.  Better to say explicitly "<no location info>".
  64
  65 printError :: SrcSpan -> Message -> IO ()
  66 printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)
  67
  68
  69 -- -----------------------------------------------------------------------------
  70 -- Collecting up messages for later ordering and printing.
  71
  72 data ErrMsg = ErrMsg {
  73         errMsgSpans     :: [SrcSpan],
  74         errMsgContext   :: PrintUnqualified,
  75         errMsgShortDoc  :: Message,
  76         errMsgExtraInfo :: Message
  77         }
  78         -- The SrcSpan is used for sorting errors into line-number order
  79         -- NB  Pretty.Doc not SDoc: we deal with the printing style (in ptic
  80         -- whether to qualify an External Name) at the error occurrence
  81
  82 -- So we can throw these things as exceptions
  83 errMsgTc :: TyCon
  84 errMsgTc = mkTyCon "ErrMsg"
  85 {-# NOINLINE errMsgTc #-}
  86 instance Typeable ErrMsg where
  87 #if __GLASGOW_HASKELL__ < 603
  88   typeOf _ = mkAppTy errMsgTc []
  89 #else
  90   typeOf _ = mkTyConApp errMsgTc []
  91 #endif
  92
  93 type WarnMsg = ErrMsg
  94
  95 -- A short (one-line) error message, with context to tell us whether
  96 -- to qualify names in the message or not.
  97 mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg
  98 mkErrMsg locn print_unqual msg
  99   = ErrMsg [locn] print_unqual msg empty
 100
 101 -- Variant that doesn't care about qualified/unqualified names
 102 mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg
 103 mkPlainErrMsg locn msg
 104   = ErrMsg [locn] alwaysQualify msg empty
 105
 106 -- A long (multi-line) error message, with context to tell us whether
 107 -- to qualify names in the message or not.
 108 mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
 109 mkLongErrMsg locn print_unqual msg extra
 110  = ErrMsg [locn] print_unqual msg extra
 111
 112 mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
 113 mkWarnMsg = mkErrMsg
 114
 115 type Messages = (Bag WarnMsg, Bag ErrMsg)
 116
 117 emptyMessages :: Messages
 118 emptyMessages = (emptyBag, emptyBag)
 119
 120 errorsFound :: DynFlags -> Messages -> Bool
 121 -- The dyn-flags are used to see if the user has specified
 122 -- -Werorr, which says that warnings should be fatal
 123 errorsFound dflags (warns, errs)
 124   | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
 125   | otherwise                   = not (isEmptyBag errs)
 126
 127 printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
 128 printErrorsAndWarnings dflags (warns, errs)
 129   | no_errs && no_warns  = return ()
 130   | no_errs              = printBagOfWarnings dflags warns
 131                             -- Don't print any warnings if there are errors
 132   | otherwise            = printBagOfErrors   dflags errs
 133   where
 134     no_warns = isEmptyBag warns
 135     no_errs  = isEmptyBag errs
 136
 137 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
 138 printBagOfErrors dflags bag_of_errors
 139   = sequence_   [ let style = mkErrStyle unqual
 140                   in log_action dflags SevError s style (d $$ e)
 141                 | ErrMsg { errMsgSpans = s:ss,
 142                            errMsgShortDoc = d,
 143                            errMsgExtraInfo = e,
 144                            errMsgContext = unqual } <- sorted_errs ]
 145     where
 146       bag_ls      = bagToList bag_of_errors
 147       sorted_errs = sortLe occ'ed_before bag_ls
 148
 149       occ'ed_before err1 err2 =
 150          case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
 151                 LT -> True
 152                 EQ -> True
 153                 GT -> False
 154
 155 printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO ()
 156 printBagOfWarnings dflags bag_of_warns
 157   = sequence_   [ let style = mkErrStyle unqual
 158                   in log_action dflags SevWarning s style (d $$ e)
 159                 | ErrMsg { errMsgSpans = s:ss,
 160                            errMsgShortDoc = d,
 161                            errMsgExtraInfo = e,
 162                            errMsgContext = unqual } <- sorted_errs ]
 163     where
 164       bag_ls      = bagToList bag_of_warns
 165       sorted_errs = sortLe occ'ed_before bag_ls
 166
 167       occ'ed_before err1 err2 =
 168          case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
 169                 LT -> True
 170                 EQ -> True
 171                 GT -> False
 172 \end{code}
 173
 174 \begin{code}
 175 ghcExit :: DynFlags -> Int -> IO ()
 176 ghcExit dflags val
 177   | val == 0  = exitWith ExitSuccess
 178   | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
 179                    exitWith (ExitFailure val)
 180 \end{code}
 181
 182 \begin{code}
 183 doIfSet :: Bool -> IO () -> IO ()
 184 doIfSet flag action | flag      = action
 185                     | otherwise = return ()
 186
 187 doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
 188 doIfSet_dyn dflags flag action | dopt flag dflags = action
 189                                | otherwise        = return ()
 190 \end{code}
 191
 192 \begin{code}
 193 dumpIfSet :: Bool -> String -> SDoc -> IO ()
 194 dumpIfSet flag hdr doc
 195   | not flag   = return ()
 196   | otherwise  = printDump (mkDumpDoc hdr doc)
 197
 198 dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 199 dumpIfSet_core dflags flag hdr doc
 200   | dopt flag dflags
 201         || verbosity dflags >= 4
 202         || dopt Opt_D_verbose_core2core dflags  = printDump (mkDumpDoc hdr doc)
 203   | otherwise                                   = return ()
 204
 205 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 206 dumpIfSet_dyn dflags flag hdr doc
 207   | dopt flag dflags || verbosity dflags >= 4
 208   = printDump (mkDumpDoc hdr doc)
 209   | otherwise
 210   = return ()
 211
 212 dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
 213 dumpIfSet_dyn_or dflags flags hdr doc
 214   | or [dopt flag dflags | flag <- flags]
 215   || verbosity dflags >= 4
 216   = printDump (mkDumpDoc hdr doc)
 217   | otherwise = return ()
 218
 219 mkDumpDoc hdr doc
 220    = vcat [text "",
 221            line <+> text hdr <+> line,
 222            doc,
 223            text ""]
 224      where
 225         line = text (replicate 20 '=')
 226
 227 -- -----------------------------------------------------------------------------
 228 -- Outputting messages from the compiler
 229
 230 -- We want all messages to go through one place, so that we can
 231 -- redirect them if necessary.  For example, when GHC is used as a
 232 -- library we might want to catch all messages that GHC tries to
 233 -- output and do something else with them.
 234
 235 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
 236 ifVerbose dflags val act
 237   | verbosity dflags >= val = act
 238   | otherwise               = return ()
 239
 240 putMsg :: DynFlags -> Message -> IO ()
 241 putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
 242
 243 errorMsg :: DynFlags -> Message -> IO ()
 244 errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
 245
 246 fatalErrorMsg :: DynFlags -> Message -> IO ()
 247 fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg
 248
 249 compilationProgressMsg :: DynFlags -> String -> IO ()
 250 compilationProgressMsg dflags msg
 251   = ifVerbose dflags 1 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text msg))
 252
 253 showPass :: DynFlags -> String -> IO ()
 254 showPass dflags what
 255   = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
 256
 257 debugTraceMsg :: DynFlags -> Int -> Message -> IO ()
 258 debugTraceMsg dflags val msg
 259   = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
 260 \end{code}