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, warningsFound, 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 :: Messages -> Bool
  99 errorsFound (warns, errs) = not (isEmptyBag errs)
 100
 101 warningsFound :: Messages -> Bool
 102 warningsFound (warns, errs) = not (isEmptyBag warns)
 103
 104 printErrorsAndWarnings :: Messages -> IO ()
 105         -- Don't print any warnings if there are errors
 106 printErrorsAndWarnings (warns, errs)
 107   | no_errs && no_warns  = return ()
 108   | no_errs              = printErrs (pprBagOfWarnings warns)
 109   | otherwise            = printErrs (pprBagOfErrors   errs)
 110   where
 111     no_warns = isEmptyBag warns
 112     no_errs  = isEmptyBag errs
 113
 114 pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc
 115 pprBagOfErrors bag_of_errors
 116   = Pretty.vcat [Pretty.text "" Pretty.$$ p | (_,p) <- sorted_errs ]
 117     where
 118       bag_ls      = bagToList bag_of_errors
 119       sorted_errs = sortLt occ'ed_before bag_ls
 120
 121       occ'ed_before (a,_) (b,_) = LT == compare a b
 122
 123 pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc
 124 pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
 125 \end{code}
 126
 127 \begin{code}
 128 ghcExit :: Int -> IO ()
 129 ghcExit val
 130   | val == 0  = exitWith ExitSuccess
 131   | otherwise = do hPutStr stderr "\nCompilation had errors\n\n"
 132                    exitWith (ExitFailure val)
 133 \end{code}
 134
 135 \begin{code}
 136 doIfSet :: Bool -> IO () -> IO ()
 137 doIfSet flag action | flag      = action
 138                     | otherwise = return ()
 139
 140 doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
 141 doIfSet_dyn dflags flag action | dopt flag dflags = action
 142                                | otherwise        = return ()
 143 \end{code}
 144
 145 \begin{code}
 146 showPass :: DynFlags -> String -> IO ()
 147 showPass dflags what
 148   | verbosity dflags >= 2 = hPutStr stderr ("*** "++what++":\n")
 149   | otherwise             = return ()
 150
 151 dumpIfSet :: Bool -> String -> SDoc -> IO ()
 152 dumpIfSet flag hdr doc
 153   | not flag   = return ()
 154   | otherwise  = printDump (mkDumpDoc hdr doc)
 155
 156 dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 157 dumpIfSet_core dflags flag hdr doc
 158   | dopt flag dflags
 159         || verbosity dflags >= 4
 160         || dopt Opt_D_verbose_core2core dflags  = printDump (mkDumpDoc hdr doc)
 161   | otherwise                                   = return ()
 162
 163 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 164 dumpIfSet_dyn dflags flag hdr doc
 165   | dopt flag dflags || verbosity dflags >= 4
 166   = if   flag `elem` [Opt_D_dump_stix, Opt_D_dump_asm]
 167     then printForC stdout (mkDumpDoc hdr doc)
 168     else printDump (mkDumpDoc hdr doc)
 169   | otherwise
 170   = return ()
 171
 172 dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
 173 dumpIfSet_dyn_or dflags flags hdr doc
 174   | or [dopt flag dflags | flag <- flags]
 175   || verbosity dflags >= 4
 176   = printDump (mkDumpDoc hdr doc)
 177   | otherwise = return ()
 178
 179 mkDumpDoc hdr doc
 180    = vcat [text "",
 181            line <+> text hdr <+> line,
 182            doc,
 183            text ""]
 184      where
 185         line = text (replicate 20 '=')
 186 \end{code}