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