ErrUtils.lhs 14.3 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}
7
{-# LANGUAGE CPP #-}
Ian Lynagh's avatar
Ian Lynagh committed
8

9
module ErrUtils (
10 11 12
        MsgDoc, 
        Validity(..), andValid, allValid, isValid, getInvalids,

13 14
        ErrMsg, WarnMsg, Severity(..),
        Messages, ErrorMessages, WarningMessages,
15
        errMsgSpan, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
16
        mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc,
17
        pprLocErrMsg, makeIntoWarning,
18

19
        errorsFound, emptyMessages, isEmptyMessages,
dterei's avatar
dterei committed
20
        mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
21
        printBagOfErrors,
dterei's avatar
dterei committed
22 23 24 25
        warnIsErrorMsg, mkLongWarnMsg,

        ghcExit,
        doIfSet, doIfSet_dyn,
26
        dumpIfSet, dumpIfSet_dyn,
27
        mkDumpDoc, dumpSDoc,
28

dterei's avatar
dterei committed
29
        --  * Messages during compilation
30 31
        putMsg, printInfoForUser, printOutputForUser,
        logInfo, logOutput,
dterei's avatar
dterei committed
32
        errorMsg,
Ian Lynagh's avatar
Ian Lynagh committed
33
        fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
dterei's avatar
dterei committed
34 35 36
        compilationProgressMsg,
        showPass,
        debugTraceMsg,
Ian Lynagh's avatar
Ian Lynagh committed
37 38

        prettyPrintGhcErrors,
39 40
    ) where

41
#include "HsVersions.h"
42

dterei's avatar
dterei committed
43
import Bag              ( Bag, bagToList, isEmptyBag, emptyBag )
Ian Lynagh's avatar
Ian Lynagh committed
44
import Exception
45
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
46
import Panic
47
import FastString
48
import SrcLoc
49
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
50

51
import System.Directory
dterei's avatar
dterei committed
52
import System.Exit      ( ExitCode(..), exitWith )
53
import System.FilePath  ( takeDirectory, (</>) )
54
import Data.List
55 56
import qualified Data.Set as Set
import Data.IORef
Ian Lynagh's avatar
Ian Lynagh committed
57
import Data.Ord
58
import Data.Time
59
import Control.Monad
60
import Control.Monad.IO.Class
61
import System.IO
sof's avatar
sof committed
62

63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
-------------------------
type MsgDoc  = SDoc

-------------------------
data Validity
  = IsValid            -- Everything is fine
  | NotValid MsgDoc    -- A problem, and some indication of why

isValid :: Validity -> Bool
isValid IsValid       = True
isValid (NotValid {}) = False

andValid :: Validity -> Validity -> Validity
andValid IsValid v = v
andValid v _       = v

allValid :: [Validity] -> Validity   -- If they aren't all valid, return the first
allValid []       = IsValid
allValid (v : vs) = v `andValid` allValid vs

getInvalids :: [Validity] -> [MsgDoc]
getInvalids vs = [d | NotValid d <- vs]

86 87 88
-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.

89 90 91
type Messages        = (WarningMessages, ErrorMessages)
type WarningMessages = Bag WarnMsg
type ErrorMessages   = Bag ErrMsg
92

93
data ErrMsg = ErrMsg {
94
        errMsgSpan      :: SrcSpan,
95
        errMsgContext   :: PrintUnqualified,
96 97
        errMsgShortDoc  :: MsgDoc,   -- errMsgShort* should always
        errMsgShortString :: String, -- contain the same text
98 99 100 101 102 103
        errMsgExtraInfo :: MsgDoc,
        errMsgSeverity  :: Severity
        }
        -- The SrcSpan is used for sorting errors into line-number order

type WarnMsg = ErrMsg
104

105
data Severity
106
  = SevOutput
107
  | SevDump
108
  | SevInteractive
109
  | SevInfo
110 111 112 113
  | SevWarning
  | SevError
  | SevFatal

114
instance Show ErrMsg where
115
    show em = errMsgShortString em
116 117 118 119 120 121

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
122 123
  -- are supposed to be in a standard format, and one without a location
  -- would look strange.  Better to say explicitly "<no location info>".
124
mkLocMessage severity locn msg
125
    = sdocWithDynFlags $ \dflags ->
ian@well-typed.com's avatar
ian@well-typed.com committed
126
      let locn' = if gopt Opt_ErrorSpans dflags
127 128 129
                  then ppr locn
                  else ppr (srcSpanStart locn)
      in hang (locn' <> colon <+> sev_info) 4 msg
130 131 132 133 134 135
  where
    sev_info = case severity of
                 SevWarning -> ptext (sLit "Warning:")
                 _other     -> empty                 
      -- For warnings, print    Foo.hs:34: Warning:
      --                           <the warning message>
136

137 138
makeIntoWarning :: ErrMsg -> ErrMsg
makeIntoWarning err = err { errMsgSeverity = SevWarning }
139

140 141 142
-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.

Ian Lynagh's avatar
Ian Lynagh committed
143
mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
Ian Lynagh's avatar
Ian Lynagh committed
144
mk_err_msg  dflags sev locn print_unqual msg extra
145
 = ErrMsg { errMsgSpan = locn, errMsgContext = print_unqual
Ian Lynagh's avatar
Ian Lynagh committed
146
          , errMsgShortDoc = msg , errMsgShortString = showSDoc dflags msg
147
          , errMsgExtraInfo = extra
148 149
          , errMsgSeverity = sev }

Ian Lynagh's avatar
Ian Lynagh committed
150
mkLongErrMsg, mkLongWarnMsg   :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
151
-- A long (multi-line) error message
Ian Lynagh's avatar
Ian Lynagh committed
152
mkErrMsg, mkWarnMsg           :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg
153
-- A short (one-line) error message
Ian Lynagh's avatar
Ian Lynagh committed
154
mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan ->                     MsgDoc            -> ErrMsg
155 156
-- Variant that doesn't care about qualified/unqualified names

Ian Lynagh's avatar
Ian Lynagh committed
157 158 159 160 161 162
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
163

164
----------------
165 166 167
emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)

168 169 170
isEmptyMessages :: Messages -> Bool
isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs

Ian Lynagh's avatar
Ian Lynagh committed
171 172 173
warnIsErrorMsg :: DynFlags -> ErrMsg
warnIsErrorMsg dflags
    = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
174

175
errorsFound :: DynFlags -> Messages -> Bool
176
errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
177

178
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
179 180
printBagOfErrors dflags bag_of_errors
  = printMsgBag dflags bag_of_errors
181

182 183
pprErrMsgBag :: Bag ErrMsg -> [SDoc]
pprErrMsgBag bag
184 185
  = [ sdocWithDynFlags $ \dflags ->
      let style = mkErrStyle dflags unqual
186 187 188 189 190
      in withPprStyle style (d $$ e)
    | ErrMsg { errMsgShortDoc  = d,
               errMsgExtraInfo = e,
               errMsgContext   = unqual } <- sortMsgBag bag ]

191 192 193
pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag bag ]

194
pprLocErrMsg :: ErrMsg -> SDoc
195
pprLocErrMsg (ErrMsg { errMsgSpan      = s
196 197 198 199
                     , errMsgShortDoc  = d
                     , errMsgExtraInfo = e
                     , errMsgSeverity  = sev
                     , errMsgContext   = unqual })
200 201
  = sdocWithDynFlags $ \dflags ->
    withPprStyle (mkErrStyle dflags unqual) (mkLocMessage sev s (d $$ e))
202 203 204

printMsgBag :: DynFlags -> Bag ErrMsg -> IO ()
printMsgBag dflags bag
205
  = sequence_ [ let style = mkErrStyle dflags unqual
Ian Lynagh's avatar
Ian Lynagh committed
206
                in log_action dflags dflags sev s style (d $$ e)
207
              | ErrMsg { errMsgSpan      = s,
208
                         errMsgShortDoc  = d,
209
                         errMsgSeverity  = sev,
210 211 212 213
                         errMsgExtraInfo = e,
                         errMsgContext   = unqual } <- sortMsgBag bag ]

sortMsgBag :: Bag ErrMsg -> [ErrMsg]
214
sortMsgBag bag = sortBy (comparing errMsgSpan) $ bagToList bag
215

216 217
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
218
  | val == 0  = exitWith ExitSuccess
219
  | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
dterei's avatar
dterei committed
220
                   exitWith (ExitFailure val)
sof's avatar
sof committed
221 222 223

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

226
doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
ian@well-typed.com's avatar
ian@well-typed.com committed
227
doIfSet_dyn dflags flag action | gopt flag dflags = action
dterei's avatar
dterei committed
228
                               | otherwise        = return ()
sof's avatar
sof committed
229

230 231 232
-- -----------------------------------------------------------------------------
-- Dumping

233 234
dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet dflags flag hdr doc
235
  | not flag   = return ()
Ian Lynagh's avatar
Ian Lynagh committed
236
  | otherwise  = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
237

238
dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
239
dumpIfSet_dyn dflags flag hdr doc
240
  | dopt flag dflags
241
  = dumpSDoc dflags alwaysQualify flag hdr doc
242 243
  | otherwise
  = return ()
244

twanvl's avatar
twanvl committed
245
mkDumpDoc :: String -> SDoc -> SDoc
dterei's avatar
dterei committed
246
mkDumpDoc hdr doc
247
   = vcat [blankLine,
dterei's avatar
dterei committed
248 249 250 251
           line <+> text hdr <+> line,
           doc,
           blankLine]
     where
sof's avatar
sof committed
252
        line = text (replicate 20 '=')
253

254 255

-- | Write out a dump.
dterei's avatar
dterei committed
256 257
--      If --dump-to-file is set then this goes to a file.
--      otherwise emit to stdout.
258
--
259 260
-- When hdr is empty, we print in a more compact format (no separators and
-- blank lines)
261 262
dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
dumpSDoc dflags print_unqual flag hdr doc
263
 = do let mFile = chooseDumpFile dflags flag
264
          dump_style = mkDumpStyle print_unqual
265 266 267 268 269 270 271 272 273
      case mFile of
            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)
274
                        createDirectoryIfMissing True (takeDirectory fileName)
275
                        handle <- openFile fileName mode
276 277 278 279 280 281 282
                        doc' <- if null hdr
                                then return doc
                                else do t <- getCurrentTime
                                        let d = text (show t)
                                             $$ blankLine
                                             $$ doc
                                        return $ mkDumpDoc hdr d
283
                        defaultLogActionHPrintDoc dflags handle doc' dump_style
284 285 286
                        hClose handle

            -- write the dump to stdout
287 288 289 290
            Nothing -> do
              let (doc', severity)
                    | null hdr  = (doc, SevOutput)
                    | otherwise = (mkDumpDoc hdr doc, SevDump)
291
              log_action dflags dflags severity noSrcSpan dump_style doc'
292 293 294 295


-- | Choose where to put a dump file based on DynFlags
--
296
chooseDumpFile :: DynFlags -> DumpFlag -> Maybe String
297
chooseDumpFile dflags flag
298

ian@well-typed.com's avatar
ian@well-typed.com committed
299
        | gopt Opt_DumpToFile dflags
300
        , Just prefix <- getPrefix
301
        = Just $ setDir (prefix ++ (beautifyDumpName flag))
302

dterei's avatar
dterei committed
303 304
        | otherwise
        = Nothing
305

306 307 308 309 310 311 312 313 314 315 316 317 318 319
        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
320

321
-- | Build a nice file name from name of a GeneralFlag constructor
322
beautifyDumpName :: DumpFlag -> String
323
beautifyDumpName flag
324 325 326 327 328
 = let str = show flag
       suff = case stripPrefix "Opt_D_" str of
              Just x -> x
              Nothing -> panic ("Bad flag name: " ++ str)
       dash = map (\c -> if c == '_' then '-' else c) suff
dterei's avatar
dterei committed
329
   in dash
330 331


332 333 334 335 336 337 338 339 340 341 342 343 344
-- -----------------------------------------------------------------------------
-- 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 ()

345
errorMsg :: DynFlags -> MsgDoc -> IO ()
346 347
errorMsg dflags msg
   = log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
348

349
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
350
fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
351

Ian Lynagh's avatar
Ian Lynagh committed
352
fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
353 354
fatalErrorMsg' la dflags msg =
    la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
Ian Lynagh's avatar
Ian Lynagh committed
355 356 357

fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
358 359 360

compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg
361 362
  = ifVerbose dflags 1 $
    logOutput dflags defaultUserStyle (text msg)
363

364
showPass :: DynFlags -> String -> IO ()
dterei's avatar
dterei committed
365
showPass dflags what
366 367
  = ifVerbose dflags 2 $
    logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
368

369
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389
debugTraceMsg dflags val msg = ifVerbose dflags val $
                               logInfo dflags defaultDumpStyle msg

putMsg :: DynFlags -> MsgDoc -> IO ()
putMsg dflags msg = logInfo dflags defaultUserStyle msg

printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printInfoForUser dflags print_unqual msg
  = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg

printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printOutputForUser dflags print_unqual msg
  = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg

logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
logInfo dflags sty msg = log_action dflags dflags SevInfo noSrcSpan sty msg

logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
-- Like logInfo but with SevOutput rather then SevInfo
logOutput dflags sty msg = log_action dflags dflags SevOutput noSrcSpan sty msg
Ian Lynagh's avatar
Ian Lynagh committed
390

391
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
392
prettyPrintGhcErrors dflags
393 394
    = ghandle $ \e -> case e of
                      PprPanic str doc ->
395
                          pprDebugAndThen dflags panic (text str) doc
396
                      PprSorry str doc ->
397
                          pprDebugAndThen dflags sorry (text str) doc
398
                      PprProgramError str doc ->
399
                          pprDebugAndThen dflags pgmError (text str) doc
400
                      _ ->
401
                          liftIO $ throwIO e
sof's avatar
sof committed
402
\end{code}
dterei's avatar
dterei committed
403