ErrUtils.lhs 12.7 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1994-1998
3
4
5
6
%
\section[ErrsUtils]{Utilities for error reporting}

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
7

8
module ErrUtils (
9
10
        ErrMsg, WarnMsg, Severity(..),
        Messages, ErrorMessages, WarningMessages,
11
        errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
12
        MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc,
13
14
15
        pprLocErrMsg, makeIntoWarning,
        
        errorsFound, emptyMessages,
dterei's avatar
dterei committed
16
        mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
17
        printBagOfErrors, 
dterei's avatar
dterei committed
18
19
20
21
22
        warnIsErrorMsg, mkLongWarnMsg,

        ghcExit,
        doIfSet, doIfSet_dyn,
        dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_or,
23
        mkDumpDoc, dumpSDoc,
24

dterei's avatar
dterei committed
25
        --  * Messages during compilation
26
        putMsg, putMsgWith,
dterei's avatar
dterei committed
27
        errorMsg,
Ian Lynagh's avatar
Ian Lynagh committed
28
        fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
dterei's avatar
dterei committed
29
30
31
        compilationProgressMsg,
        showPass,
        debugTraceMsg,
Ian Lynagh's avatar
Ian Lynagh committed
32
33

        prettyPrintGhcErrors,
34
35
    ) where

36
#include "HsVersions.h"
37

dterei's avatar
dterei committed
38
import Bag              ( Bag, bagToList, isEmptyBag, emptyBag )
Ian Lynagh's avatar
Ian Lynagh committed
39
import Exception
40
import Util
41
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
42
import Panic
43
import FastString
44
import SrcLoc
45
import DynFlags
dterei's avatar
dterei committed
46
import StaticFlags      ( opt_ErrorSpans )
Simon Marlow's avatar
Simon Marlow committed
47

48
import System.Directory
dterei's avatar
dterei committed
49
import System.Exit      ( ExitCode(..), exitWith )
50
import System.FilePath
51
import Data.List
52
53
54
import qualified Data.Set as Set
import Data.IORef
import Control.Monad
55
import System.IO
sof's avatar
sof committed
56

57
58
59
-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.

60
61
62
type Messages        = (WarningMessages, ErrorMessages)
type WarningMessages = Bag WarnMsg
type ErrorMessages   = Bag ErrMsg
63

64
65
66
data ErrMsg = ErrMsg {
        errMsgSpans     :: [SrcSpan],
        errMsgContext   :: PrintUnqualified,
67
68
        errMsgShortDoc  :: MsgDoc,   -- errMsgShort* should always
        errMsgShortString :: String, -- contain the same text
69
70
71
72
73
74
75
        errMsgExtraInfo :: MsgDoc,
        errMsgSeverity  :: Severity
        }
        -- The SrcSpan is used for sorting errors into line-number order

type WarnMsg = ErrMsg
type MsgDoc = SDoc
76

77
data Severity
78
  = SevOutput
79
  | SevDump
80
  | SevInfo
81
82
83
84
  | SevWarning
  | SevError
  | SevFatal

85
instance Show ErrMsg where
86
    show em = errMsgShortString em
87
88
89
90
91
92

pprMessageBag :: Bag MsgDoc -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))

mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
  -- Always print the location, even if it is unhelpful.  Error messages
93
94
  -- are supposed to be in a standard format, and one without a location
  -- would look strange.  Better to say explicitly "<no location info>".
95
96
97
98
99
100
101
102
103
mkLocMessage severity locn msg
  | opt_ErrorSpans = hang (ppr locn <> colon <+> sev_info) 4 msg
  | otherwise      = hang (ppr (srcSpanStart locn) <> colon <+> sev_info) 4 msg
  where
    sev_info = case severity of
                 SevWarning -> ptext (sLit "Warning:")
                 _other     -> empty                 
      -- For warnings, print    Foo.hs:34: Warning:
      --                           <the warning message>
104

105
106
makeIntoWarning :: ErrMsg -> ErrMsg
makeIntoWarning err = err { errMsgSeverity = SevWarning }
107

108
109
110
-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.

Ian Lynagh's avatar
Ian Lynagh committed
111
112
mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
mk_err_msg _ sev locn print_unqual msg extra 
113
 = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
114
115
          , errMsgShortDoc = msg , errMsgShortString = showSDoc msg
          , errMsgExtraInfo = extra
116
117
          , errMsgSeverity = sev }

Ian Lynagh's avatar
Ian Lynagh committed
118
mkLongErrMsg, mkLongWarnMsg   :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
119
-- A long (multi-line) error message
Ian Lynagh's avatar
Ian Lynagh committed
120
mkErrMsg, mkWarnMsg           :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg
121
-- A short (one-line) error message
Ian Lynagh's avatar
Ian Lynagh committed
122
mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan ->                     MsgDoc            -> ErrMsg
123
124
-- Variant that doesn't care about qualified/unqualified names

Ian Lynagh's avatar
Ian Lynagh committed
125
126
127
128
129
130
mkLongErrMsg   dflags locn unqual msg extra = mk_err_msg dflags SevError   locn unqual        msg extra
mkErrMsg       dflags locn unqual msg       = mk_err_msg dflags SevError   locn unqual        msg empty
mkPlainErrMsg  dflags locn        msg       = mk_err_msg dflags SevError   locn alwaysQualify msg empty
mkLongWarnMsg  dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual        msg extra
mkWarnMsg      dflags locn unqual msg       = mk_err_msg dflags SevWarning locn unqual        msg empty
mkPlainWarnMsg dflags locn        msg       = mk_err_msg dflags SevWarning locn alwaysQualify msg empty
131

132
----------------
133
134
135
emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)

Ian Lynagh's avatar
Ian Lynagh committed
136
137
138
warnIsErrorMsg :: DynFlags -> ErrMsg
warnIsErrorMsg dflags
    = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
139

140
errorsFound :: DynFlags -> Messages -> Bool
141
errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
142

143
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
144
145
printBagOfErrors dflags bag_of_errors
  = printMsgBag dflags bag_of_errors
146

147
148
149
150
151
152
153
154
pprErrMsgBag :: Bag ErrMsg -> [SDoc]
pprErrMsgBag bag
  = [ let style = mkErrStyle unqual
      in withPprStyle style (d $$ e)
    | ErrMsg { errMsgShortDoc  = d,
               errMsgExtraInfo = e,
               errMsgContext   = unqual } <- sortMsgBag bag ]

155
156
157
pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag bag ]

158
159
160
161
162
163
164
165
166
167
168
169
pprLocErrMsg :: ErrMsg -> SDoc
pprLocErrMsg (ErrMsg { errMsgSpans     = spans
                     , errMsgShortDoc  = d
                     , errMsgExtraInfo = e
                     , errMsgSeverity  = sev
                     , errMsgContext   = unqual })
  = withPprStyle (mkErrStyle unqual) (mkLocMessage sev s (d $$ e))
  where
    (s : _) = spans   -- Should be non-empty

printMsgBag :: DynFlags -> Bag ErrMsg -> IO ()
printMsgBag dflags bag
170
  = sequence_ [ let style = mkErrStyle unqual
Ian Lynagh's avatar
Ian Lynagh committed
171
                in log_action dflags dflags sev s style (d $$ e)
172
173
              | ErrMsg { errMsgSpans     = s:_,
                         errMsgShortDoc  = d,
174
                         errMsgSeverity  = sev,
175
176
177
178
179
180
                         errMsgExtraInfo = e,
                         errMsgContext   = unqual } <- sortMsgBag bag ]

sortMsgBag :: Bag ErrMsg -> [ErrMsg]
sortMsgBag bag = sortLe srcOrder $ bagToList bag
  where
dterei's avatar
dterei committed
181
    srcOrder err1 err2 =
182
183
184
185
        case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
            LT -> True
            EQ -> True
            GT -> False
186

187
188
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
189
  | val == 0  = exitWith ExitSuccess
190
  | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
dterei's avatar
dterei committed
191
                   exitWith (ExitFailure val)
sof's avatar
sof committed
192
193
194

doIfSet :: Bool -> IO () -> IO ()
doIfSet flag action | flag      = action
dterei's avatar
dterei committed
195
                    | otherwise = return ()
196

197
198
doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
doIfSet_dyn dflags flag action | dopt flag dflags = action
dterei's avatar
dterei committed
199
                               | otherwise        = return ()
sof's avatar
sof committed
200

201
202
203
-- -----------------------------------------------------------------------------
-- Dumping

204
205
dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet dflags flag hdr doc
206
  | not flag   = return ()
Ian Lynagh's avatar
Ian Lynagh committed
207
  | otherwise  = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
208

209
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
210
dumpIfSet_dyn dflags flag hdr doc
dterei's avatar
dterei committed
211
  | dopt flag dflags || verbosity dflags >= 4
212
  = dumpSDoc dflags flag hdr doc
213
214
  | otherwise
  = return ()
215

216
dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
217
218
219
220
221
dumpIfSet_dyn_or _ [] _ _ = return ()
dumpIfSet_dyn_or dflags (flag : flags) hdr doc
    = if dopt flag dflags || verbosity dflags >= 4
      then dumpSDoc dflags flag hdr doc
      else dumpIfSet_dyn_or dflags flags hdr doc
222

twanvl's avatar
twanvl committed
223
mkDumpDoc :: String -> SDoc -> SDoc
dterei's avatar
dterei committed
224
mkDumpDoc hdr doc
225
   = vcat [blankLine,
dterei's avatar
dterei committed
226
227
228
229
           line <+> text hdr <+> line,
           doc,
           blankLine]
     where
sof's avatar
sof committed
230
        line = text (replicate 20 '=')
231

232
233

-- | Write out a dump.
dterei's avatar
dterei committed
234
235
--      If --dump-to-file is set then this goes to a file.
--      otherwise emit to stdout.
236
237
dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpSDoc dflags dflag hdr doc
238
239
240
241
242
243
244
245
246
247
248
249
250
 = do let mFile = chooseDumpFile dflags dflag
      case mFile of
            -- write the dump to a file
            -- don't add the header in this case, we can see what kind
            -- of dump it is from the filename.
            Just fileName
                 -> do
                        let gdref = generatedDumps dflags
                        gd <- readIORef gdref
                        let append = Set.member fileName gd
                            mode = if append then AppendMode else WriteMode
                        when (not append) $
                            writeIORef gdref (Set.insert fileName gd)
251
                        createDirectoryIfMissing True (takeDirectory fileName)
252
                        handle <- openFile fileName mode
Ian Lynagh's avatar
Ian Lynagh committed
253
                        hPrintDump dflags handle doc
254
255
256
257
                        hClose handle

            -- write the dump to stdout
            Nothing
Ian Lynagh's avatar
Ian Lynagh committed
258
                 -> log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
259
260
261
262
263
264
265


-- | Choose where to put a dump file based on DynFlags
--
chooseDumpFile :: DynFlags -> DynFlag -> Maybe String
chooseDumpFile dflags dflag

266
267
268
        | dopt Opt_DumpToFile dflags
        , Just prefix <- getPrefix
        = Just $ setDir (prefix ++ (beautifyDumpName dflag))
269

dterei's avatar
dterei committed
270
271
        | otherwise
        = Nothing
272

273
274
275
276
277
278
279
280
281
282
283
284
285
286
        where getPrefix
                 -- dump file location is being forced
                 --      by the --ddump-file-prefix flag.
               | Just prefix <- dumpPrefixForce dflags
                  = Just prefix
                 -- dump file location chosen by DriverPipeline.runPipeline
               | Just prefix <- dumpPrefix dflags
                  = Just prefix
                 -- we haven't got a place to put a dump file.
               | otherwise
                  = Nothing
              setDir f = case dumpDir dflags of
                         Just d  -> d </> f
                         Nothing ->       f
287
288
289
290

-- | Build a nice file name from name of a DynFlag constructor
beautifyDumpName :: DynFlag -> String
beautifyDumpName dflag
dterei's avatar
dterei committed
291
292
293
294
 = let str  = show dflag
       cut  = if isPrefixOf "Opt_D_" str then drop 6 str else str
       dash = map (\c -> if c == '_' then '-' else c) cut
   in dash
295
296


297
298
299
300
301
302
303
304
305
306
307
308
309
-- -----------------------------------------------------------------------------
-- Outputting messages from the compiler

-- We want all messages to go through one place, so that we can
-- redirect them if necessary.  For example, when GHC is used as a
-- library we might want to catch all messages that GHC tries to
-- output and do something else with them.

ifVerbose :: DynFlags -> Int -> IO () -> IO ()
ifVerbose dflags val act
  | verbosity dflags >= val = act
  | otherwise               = return ()

310
putMsg :: DynFlags -> MsgDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
311
putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
312

313
putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
314
putMsgWith dflags print_unqual msg
Ian Lynagh's avatar
Ian Lynagh committed
315
  = log_action dflags dflags SevInfo noSrcSpan sty msg
316
317
318
  where
    sty = mkUserStyle print_unqual AllTheWay

319
errorMsg :: DynFlags -> MsgDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
320
errorMsg dflags msg = log_action dflags dflags SevError noSrcSpan defaultErrStyle msg
321

322
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
323
fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
324

Ian Lynagh's avatar
Ian Lynagh committed
325
326
327
328
329
fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
fatalErrorMsg' la dflags msg = la dflags SevFatal noSrcSpan defaultErrStyle msg

fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
330
331
332

compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg
Ian Lynagh's avatar
Ian Lynagh committed
333
  = ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg))
334

335
showPass :: DynFlags -> String -> IO ()
dterei's avatar
dterei committed
336
showPass dflags what
Ian Lynagh's avatar
Ian Lynagh committed
337
  = ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
338

339
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
340
debugTraceMsg dflags val msg
Ian Lynagh's avatar
Ian Lynagh committed
341
  = ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg)
Ian Lynagh's avatar
Ian Lynagh committed
342

343
344
345
346
347
348
349
350
351
352
353
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors _
    = ghandle $ \e -> case e of
                      PprPanic str doc ->
                          pprDebugAndThen panic str doc
                      PprSorry str doc ->
                          pprDebugAndThen sorry str doc
                      PprProgramError str doc ->
                          pprDebugAndThen pgmError str doc
                      _ ->
                          throw e
sof's avatar
sof committed
354
\end{code}
dterei's avatar
dterei committed
355