ErrUtils.lhs 13.2 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 Outputable
Ian Lynagh's avatar
Ian Lynagh committed
41
import Panic
42
import FastString
43
import SrcLoc
44
import DynFlags
dterei's avatar
dterei committed
45
import StaticFlags      ( opt_ErrorSpans )
Simon Marlow's avatar
Simon Marlow committed
46

47
import System.Directory
dterei's avatar
dterei committed
48
import System.Exit      ( ExitCode(..), exitWith )
49
import System.FilePath
50
import Data.List
51 52
import qualified Data.Set as Set
import Data.IORef
Ian Lynagh's avatar
Ian Lynagh committed
53
import Data.Ord
54
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
mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
Ian Lynagh's avatar
Ian Lynagh committed
112
mk_err_msg  dflags sev locn print_unqual msg extra
113
 = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
Ian Lynagh's avatar
Ian Lynagh committed
114
          , errMsgShortDoc = msg , errMsgShortString = showSDoc dflags msg
115
          , 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
pprErrMsgBag :: Bag ErrMsg -> [SDoc]
pprErrMsgBag bag
149 150
  = [ sdocWithDynFlags $ \dflags ->
      let style = mkErrStyle dflags unqual
151 152 153 154 155
      in withPprStyle style (d $$ e)
    | ErrMsg { errMsgShortDoc  = d,
               errMsgExtraInfo = e,
               errMsgContext   = unqual } <- sortMsgBag bag ]

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

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

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

sortMsgBag :: Bag ErrMsg -> [ErrMsg]
Ian Lynagh's avatar
Ian Lynagh committed
181 182
sortMsgBag bag = sortBy (comparing (head . errMsgSpans)) $ bagToList bag
                 -- TODO: Why "head ."? Why not compare the whole list?
183

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

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

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

198 199 200
-- -----------------------------------------------------------------------------
-- Dumping

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

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

213
dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
214 215 216 217 218
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
219

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

229 230

-- | Write out a dump.
dterei's avatar
dterei committed
231 232
--      If --dump-to-file is set then this goes to a file.
--      otherwise emit to stdout.
233 234 235
-- 
-- When hdr is empty, we print in a more compact format (no separators and
-- blank lines)
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
253 254 255 256
                        let doc'
                              | null hdr  = doc
                              | otherwise = doc $$ blankLine
                        defaultLogActionHPrintDoc dflags handle doc' defaultDumpStyle
257 258 259
                        hClose handle

            -- write the dump to stdout
260 261 262 263 264
            Nothing -> do
              let (doc', severity)
                    | null hdr  = (doc, SevOutput)
                    | otherwise = (mkDumpDoc hdr doc, SevDump)
              log_action dflags dflags severity noSrcSpan defaultDumpStyle doc'
265 266 267 268 269 270 271


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

272 273 274
        | dopt Opt_DumpToFile dflags
        , Just prefix <- getPrefix
        = Just $ setDir (prefix ++ (beautifyDumpName dflag))
275

dterei's avatar
dterei committed
276 277
        | otherwise
        = Nothing
278

279 280 281 282 283 284 285 286 287 288 289 290 291 292
        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
293 294 295 296

-- | Build a nice file name from name of a DynFlag constructor
beautifyDumpName :: DynFlag -> String
beautifyDumpName dflag
dterei's avatar
dterei committed
297 298 299 300
 = 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
301 302


303 304 305 306 307 308 309 310 311 312 313 314 315
-- -----------------------------------------------------------------------------
-- 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 ()

316
putMsg :: DynFlags -> MsgDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
317
putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
318

319
putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
320
putMsgWith dflags print_unqual msg
Ian Lynagh's avatar
Ian Lynagh committed
321
  = log_action dflags dflags SevInfo noSrcSpan sty msg
322 323 324
  where
    sty = mkUserStyle print_unqual AllTheWay

325
errorMsg :: DynFlags -> MsgDoc -> IO ()
326 327
errorMsg dflags msg =
    log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
328

329
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
330
fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
331

Ian Lynagh's avatar
Ian Lynagh committed
332
fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
333 334
fatalErrorMsg' la dflags msg =
    la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
Ian Lynagh's avatar
Ian Lynagh committed
335 336 337

fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
338 339 340

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

343
showPass :: DynFlags -> String -> IO ()
dterei's avatar
dterei committed
344
showPass dflags what
Ian Lynagh's avatar
Ian Lynagh committed
345
  = ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
346

347
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
348
debugTraceMsg dflags val msg
Ian Lynagh's avatar
Ian Lynagh committed
349
  = ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg)
Ian Lynagh's avatar
Ian Lynagh committed
350

351
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
352
prettyPrintGhcErrors dflags
353 354
    = ghandle $ \e -> case e of
                      PprPanic str doc ->
355
                          pprDebugAndThen dflags panic str doc
356
                      PprSorry str doc ->
357
                          pprDebugAndThen dflags sorry str doc
358
                      PprProgramError str doc ->
359
                          pprDebugAndThen dflags pgmError str doc
360 361
                      _ ->
                          throw e
sof's avatar
sof committed
362
\end{code}
dterei's avatar
dterei committed
363