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