2 % (c) The AQUA Project, Glasgow University, 1994-1998
4 \section[ErrsUtils]{Utilities for error reporting}
8 ErrMsg, WarnMsg, Message,
9 addShortErrLocLine, addShortWarnLocLine,
12 printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
14 doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_dyn
17 #include "HsVersions.h"
19 import Bag ( Bag, bagToList, isEmptyBag )
20 import SrcLoc ( SrcLoc, noSrcLoc )
21 import Util ( sortLt )
23 import CmdLineOpts ( DynFlags, DynFlag, dopt )
25 import System ( ExitCode(..), exitWith )
26 import IO ( hPutStr, stderr )
30 type MsgWithLoc = (SrcLoc, SDoc)
32 type ErrMsg = MsgWithLoc
33 type WarnMsg = MsgWithLoc
36 addShortErrLocLine :: SrcLoc -> Message -> ErrMsg
37 addErrLocHdrLine :: SrcLoc -> Message -> Message -> ErrMsg
38 addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg
40 addShortErrLocLine locn rest_of_err_msg
42 , hang (ppr locn <> colon)
46 addErrLocHdrLine locn hdr rest_of_err_msg
48 , hang (ppr locn <> colon<+> hdr)
52 addShortWarnLocLine locn rest_of_err_msg
54 , hang (ppr locn <> colon)
55 4 (ptext SLIT("Warning:") <+> rest_of_err_msg)
58 dontAddErrLoc :: String -> Message -> ErrMsg
59 dontAddErrLoc title rest_of_err_msg
60 | null title = (noSrcLoc, rest_of_err_msg)
62 ( noSrcLoc, hang (text title <> colon) 4 rest_of_err_msg )
64 printErrorsAndWarnings :: (Bag WarnMsg, Bag ErrMsg) -> IO ()
65 -- Don't print any warnings if there are errors
66 printErrorsAndWarnings (warns, errs)
67 | no_errs && no_warns = return ()
68 | no_errs = printErrs (pprBagOfWarnings warns)
69 | otherwise = printErrs (pprBagOfErrors errs)
71 no_warns = isEmptyBag warns
72 no_errs = isEmptyBag errs
74 pprBagOfErrors :: Bag ErrMsg -> SDoc
75 pprBagOfErrors bag_of_errors
76 = vcat [text "" $$ p | (_,p) <- sorted_errs ]
78 bag_ls = bagToList bag_of_errors
79 sorted_errs = sortLt occ'ed_before bag_ls
81 occ'ed_before (a,_) (b,_) = LT == compare a b
83 pprBagOfWarnings :: Bag WarnMsg -> SDoc
84 pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
88 ghcExit :: Int -> IO ()
90 | val == 0 = exitWith ExitSuccess
91 | otherwise = do hPutStr stderr "\nCompilation had errors\n\n"
92 exitWith (ExitFailure val)
96 doIfSet :: Bool -> IO () -> IO ()
97 doIfSet flag action | flag = action
98 | otherwise = return ()
100 doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
101 doIfSet_dyn dflags flag action | dopt flag dflags = action
102 | otherwise = return ()
106 dumpIfSet :: Bool -> String -> SDoc -> IO ()
107 dumpIfSet flag hdr doc
108 | not flag = return ()
109 | otherwise = printDump (dump hdr doc)
111 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
112 dumpIfSet_dyn dflags flag hdr doc
113 | not (dopt flag dflags) = return ()
114 | otherwise = printDump (dump hdr doc)
118 line <+> text hdr <+> line,
122 line = text (take 20 (repeat '='))