ErrUtils.lhs 9.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}
7
module ErrUtils (
8
	Message, mkLocMessage, printError, pprMessageBag,
9
	Severity(..),
10

11
	ErrMsg, WarnMsg,
12
        ErrorMessages, WarningMessages,
13
        errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
14
	Messages, errorsFound, emptyMessages,
15
	mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
16
	printBagOfErrors, printBagOfWarnings,
17
	warnIsErrorMsg, mkLongWarnMsg,
18

sof's avatar
sof committed
19
	ghcExit,
20
	doIfSet, doIfSet_dyn, 
21
	dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_or,
22
        mkDumpDoc, dumpSDoc,
23

24
	--  * Messages during compilation
25
        putMsg, putMsgWith,
26
	errorMsg,
27 28 29 30
	fatalErrorMsg,
	compilationProgressMsg,
	showPass,
	debugTraceMsg,	
31 32
    ) where

33
#include "HsVersions.h"
34

35
import Bag		( Bag, bagToList, isEmptyBag, emptyBag )
36
import Util		( sortLe )
37
import Outputable
38
import SrcLoc
39 40
import DynFlags		( DynFlags(..), DynFlag(..), dopt )
import StaticFlags	( opt_ErrorSpans )
Simon Marlow's avatar
Simon Marlow committed
41 42

import System.Exit	( ExitCode(..), exitWith )
43
import Data.List
44 45 46
import qualified Data.Set as Set
import Data.IORef
import Control.Monad
47
import System.IO
sof's avatar
sof committed
48

49 50 51
-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.

52
type Message = SDoc
53

54 55 56
pprMessageBag :: Bag Message -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))

57
data Severity
58 59
  = SevOutput
  | SevInfo
60 61 62 63
  | SevWarning
  | SevError
  | SevFatal

64 65 66 67 68 69 70
mkLocMessage :: SrcSpan -> Message -> Message
mkLocMessage locn msg
  | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg
  | otherwise      = hang (ppr (srcSpanStart locn) <> colon) 4 msg
  -- always print the location, even if it is unhelpful.  Error messages
  -- are supposed to be in a standard format, and one without a location
  -- would look strange.  Better to say explicitly "<no location info>".
71

72
printError :: SrcSpan -> Message -> IO ()
73 74
printError span msg =
  printErrs (mkLocMessage span msg) defaultErrStyle
75 76


77 78 79 80 81 82 83 84 85
-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.

data ErrMsg = ErrMsg { 
	errMsgSpans     :: [SrcSpan],
	errMsgContext   :: PrintUnqualified,
	errMsgShortDoc  :: Message,
	errMsgExtraInfo :: Message
	}
86
	-- The SrcSpan is used for sorting errors into line-number order
87

88 89 90
instance Show ErrMsg where
    show em = showSDoc (errMsgShortDoc em)

91
type WarnMsg = ErrMsg
92

93 94
-- A short (one-line) error message, with context to tell us whether
-- to qualify names in the message or not.
95 96
mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg
mkErrMsg locn print_unqual msg
97 98
  = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
           , errMsgShortDoc = msg, errMsgExtraInfo = empty }
99 100 101 102

-- Variant that doesn't care about qualified/unqualified names
mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg
mkPlainErrMsg locn msg
103 104
  = ErrMsg { errMsgSpans = [locn], errMsgContext = alwaysQualify
           , errMsgShortDoc = msg, errMsgExtraInfo = empty }
105 106 107 108 109

-- A long (multi-line) error message, with context to tell us whether
-- to qualify names in the message or not.
mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
mkLongErrMsg locn print_unqual msg extra 
110 111
 = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
          , errMsgShortDoc = msg, errMsgExtraInfo = extra }
112

113 114
mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
mkWarnMsg = mkErrMsg
115

116 117 118
mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
mkLongWarnMsg = mkLongErrMsg

119 120 121 122
-- Variant that doesn't care about qualified/unqualified names
mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg
mkPlainWarnMsg locn msg = mkWarnMsg locn alwaysQualify msg

123 124
type Messages = (Bag WarnMsg, Bag ErrMsg)

125 126 127
type WarningMessages = Bag WarnMsg
type ErrorMessages   = Bag ErrMsg

128 129 130
emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)

131
warnIsErrorMsg :: ErrMsg
132
warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.")
133

134
errorsFound :: DynFlags -> Messages -> Bool
135
errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
136

137
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
138 139
printBagOfErrors dflags bag_of_errors = 
  printMsgBag dflags bag_of_errors SevError
sof's avatar
sof committed
140

141 142 143
printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO ()
printBagOfWarnings dflags bag_of_warns = 
  printMsgBag dflags bag_of_warns SevWarning
144

145 146
printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
printMsgBag dflags bag sev
147
  = sequence_   [ let style = mkErrStyle unqual
148
		  in log_action dflags sev s style (d $$ e)
twanvl's avatar
twanvl committed
149
		| ErrMsg { errMsgSpans = s:_,
150 151 152 153
			   errMsgShortDoc = d,
			   errMsgExtraInfo = e,
			   errMsgContext = unqual } <- sorted_errs ]
    where
154
      bag_ls	  = bagToList bag
155 156 157 158 159 160 161
      sorted_errs = sortLe occ'ed_before bag_ls

      occ'ed_before err1 err2 = 
         case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
		LT -> True
		EQ -> True
		GT -> False
162

163 164
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
165
  | val == 0  = exitWith ExitSuccess
166
  | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
167
	           exitWith (ExitFailure val)
sof's avatar
sof committed
168 169 170 171

doIfSet :: Bool -> IO () -> IO ()
doIfSet flag action | flag      = action
		    | otherwise = return ()
172

173 174 175
doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
doIfSet_dyn dflags flag action | dopt flag dflags = action
		               | otherwise        = return ()
sof's avatar
sof committed
176

177 178 179
-- -----------------------------------------------------------------------------
-- Dumping

180 181 182
dumpIfSet :: Bool -> String -> SDoc -> IO ()
dumpIfSet flag hdr doc
  | not flag   = return ()
183
  | otherwise  = printDump (mkDumpDoc hdr doc)
184

185
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
186
dumpIfSet_dyn dflags flag hdr doc
187
  | dopt flag dflags || verbosity dflags >= 4 
188
  = dumpSDoc dflags flag hdr doc
189 190
  | otherwise
  = return ()
191

192 193 194 195
dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
dumpIfSet_dyn_or dflags flags hdr doc
  | or [dopt flag dflags | flag <- flags]
  || verbosity dflags >= 4 
196
  = printDump (mkDumpDoc hdr doc)
197 198
  | otherwise = return ()

twanvl's avatar
twanvl committed
199
mkDumpDoc :: String -> SDoc -> SDoc
200
mkDumpDoc hdr doc 
201
   = vcat [blankLine,
202 203
	   line <+> text hdr <+> line,
	   doc,
204
	   blankLine]
205
     where 
sof's avatar
sof committed
206
        line = text (replicate 20 '=')
207

208 209 210 211

-- | Write out a dump.
--	If --dump-to-file is set then this goes to a file.
--	otherwise emit to stdout.
212 213
dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpSDoc dflags dflag hdr doc
214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233
 = 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)
                        handle <- openFile fileName mode
                        hPrintDump handle doc
                        hClose handle

            -- write the dump to stdout
            Nothing
                 -> printDump (mkDumpDoc hdr doc)
234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272


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

	-- dump file location is being forced
	--	by the --ddump-file-prefix flag.
 	| dumpToFile
	, Just prefix	<- dumpPrefixForce dflags
	= Just $ prefix ++ (beautifyDumpName dflag)

	-- dump file location chosen by DriverPipeline.runPipeline
	| dumpToFile
	, Just prefix	<- dumpPrefix dflags
	= Just $ prefix ++ (beautifyDumpName dflag)

	-- we haven't got a place to put a dump file.
	| otherwise
	= Nothing

	where	dumpToFile = dopt Opt_DumpToFile dflags


-- | Build a nice file name from name of a DynFlag constructor
beautifyDumpName :: DynFlag -> String
beautifyDumpName dflag
 = let	str	= show dflag
 	cut	= if isPrefixOf "Opt_D_" str
			 then drop 6 str
			 else str
	dash	= map	(\c -> case c of
				'_'	-> '-'
				_	-> c)
			cut
   in	dash


273 274 275 276 277 278 279 280 281 282 283 284 285
-- -----------------------------------------------------------------------------
-- 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 ()

286 287 288
putMsg :: DynFlags -> Message -> IO ()
putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg

289 290 291 292 293 294
putMsgWith :: DynFlags -> PrintUnqualified -> Message -> IO ()
putMsgWith dflags print_unqual msg
  = log_action dflags SevInfo noSrcSpan sty msg
  where
    sty = mkUserStyle print_unqual AllTheWay

295 296 297 298 299
errorMsg :: DynFlags -> Message -> IO ()
errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg

fatalErrorMsg :: DynFlags -> Message -> IO ()
fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg
300 301 302

compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg
303
  = ifVerbose dflags 1 (log_action dflags SevOutput noSrcSpan defaultUserStyle (text msg))
304

305 306 307
showPass :: DynFlags -> String -> IO ()
showPass dflags what 
  = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
308

309
debugTraceMsg :: DynFlags -> Int -> Message -> IO ()
310
debugTraceMsg dflags val msg
311
  = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
312

sof's avatar
sof committed
313
\end{code}