1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
%
% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[ErrsUtils]{Utilities for error reporting}
\begin{code}
module ErrUtils (
ErrMsg, WarnMsg, Message,
addShortErrLocLine, addShortWarnLocLine,
addErrLocHdrLine,
dontAddErrLoc,
printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
ghcExit,
doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_dyn
) where
#include "HsVersions.h"
import Bag ( Bag, bagToList, isEmptyBag )
import SrcLoc ( SrcLoc, noSrcLoc )
import Util ( sortLt )
import Outputable
import CmdLineOpts ( DynFlags, DynFlag, dopt )
import System ( ExitCode(..), exitWith )
import IO ( hPutStr, stderr )
\end{code}
\begin{code}
type MsgWithLoc = (SrcLoc, SDoc)
type ErrMsg = MsgWithLoc
type WarnMsg = MsgWithLoc
type Message = SDoc
addShortErrLocLine :: SrcLoc -> Message -> ErrMsg
addErrLocHdrLine :: SrcLoc -> Message -> Message -> ErrMsg
addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg
addShortErrLocLine locn rest_of_err_msg
= ( locn
, hang (ppr locn <> colon)
4 rest_of_err_msg
)
addErrLocHdrLine locn hdr rest_of_err_msg
= ( locn
, hang (ppr locn <> colon<+> hdr)
4 rest_of_err_msg
)
addShortWarnLocLine locn rest_of_err_msg
= ( locn
, hang (ppr locn <> colon)
4 (ptext SLIT("Warning:") <+> rest_of_err_msg)
)
dontAddErrLoc :: String -> Message -> ErrMsg
dontAddErrLoc title rest_of_err_msg
| null title = (noSrcLoc, rest_of_err_msg)
| otherwise =
( noSrcLoc, hang (text title <> colon) 4 rest_of_err_msg )
printErrorsAndWarnings :: (Bag WarnMsg, Bag ErrMsg) -> IO ()
-- Don't print any warnings if there are errors
printErrorsAndWarnings (warns, errs)
| no_errs && no_warns = return ()
| no_errs = printErrs (pprBagOfWarnings warns)
| otherwise = printErrs (pprBagOfErrors errs)
where
no_warns = isEmptyBag warns
no_errs = isEmptyBag errs
pprBagOfErrors :: Bag ErrMsg -> SDoc
pprBagOfErrors bag_of_errors
= vcat [text "" $$ p | (_,p) <- sorted_errs ]
where
bag_ls = bagToList bag_of_errors
sorted_errs = sortLt occ'ed_before bag_ls
occ'ed_before (a,_) (b,_) = LT == compare a b
pprBagOfWarnings :: Bag WarnMsg -> SDoc
pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
\end{code}
\begin{code}
ghcExit :: Int -> IO ()
ghcExit val
| val == 0 = exitWith ExitSuccess
| otherwise = do hPutStr stderr "\nCompilation had errors\n\n"
exitWith (ExitFailure val)
\end{code}
\begin{code}
doIfSet :: Bool -> IO () -> IO ()
doIfSet flag action | flag = action
| otherwise = return ()
doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
doIfSet_dyn dflags flag action | dopt flag dflags = action
| otherwise = return ()
\end{code}
\begin{code}
dumpIfSet :: Bool -> String -> SDoc -> IO ()
dumpIfSet flag hdr doc
| not flag = return ()
| otherwise = printDump (dump hdr doc)
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
| not (dopt flag dflags) = return ()
| otherwise = printDump (dump hdr doc)
dump hdr doc
= vcat [text "",
line <+> text hdr <+> line,
doc,
text ""]
where
line = text (take 20 (repeat '='))
\end{code}
|
