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