ErrUtils.lhs 11 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,
9
	Severity(..),
10

11
	ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
12
	errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
13
	Messages, errorsFound, emptyMessages,
14
	mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
15
	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
16
    handleFlagWarnings,
17

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

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

32
#include "HsVersions.h"
33

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

42
import Control.Monad
Simon Marlow's avatar
Simon Marlow committed
43 44
import System.Exit	( ExitCode(..), exitWith )
import Data.Dynamic
45 46
import Data.List
import System.IO
47
import Exception
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 57 58 59
data Severity
  = SevInfo
  | SevWarning
  | SevError
  | SevFatal

60 61 62 63 64 65 66
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>".
67

68 69
printError :: SrcSpan -> Message -> IO ()
printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)
70 71


72 73 74 75 76 77 78 79 80
-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.

data ErrMsg = ErrMsg { 
	errMsgSpans     :: [SrcSpan],
	errMsgContext   :: PrintUnqualified,
	errMsgShortDoc  :: Message,
	errMsgExtraInfo :: Message
	}
81 82 83
	-- The SrcSpan is used for sorting errors into line-number order
	-- NB  Pretty.Doc not SDoc: we deal with the printing style (in ptic 
	-- whether to qualify an External Name) at the error occurrence
84

85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
#if __GLASGOW_HASKELL__ >= 609
instance Exception ErrMsg
#endif

instance Show ErrMsg where
    show em = showSDoc (errMsgShortDoc em)

throwErrMsg :: ErrMsg -> a
#if __GLASGOW_HASKELL__ < 609
throwErrMsg = throwDyn
#else
throwErrMsg = throw
#endif

handleErrMsg :: (ErrMsg -> IO a) -> IO a -> IO a
#if __GLASGOW_HASKELL__ < 609
handleErrMsg = flip catchDyn
#else
handleErrMsg = handle
#endif

106 107 108
-- So we can throw these things as exceptions
errMsgTc :: TyCon
errMsgTc = mkTyCon "ErrMsg"
109
{-# NOINLINE errMsgTc #-}
110 111 112
instance Typeable ErrMsg where
  typeOf _ = mkTyConApp errMsgTc []

113
type WarnMsg = ErrMsg
114

115 116
-- A short (one-line) error message, with context to tell us whether
-- to qualify names in the message or not.
117 118
mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg
mkErrMsg locn print_unqual msg
119 120 121 122 123 124 125 126 127 128 129 130 131
  = ErrMsg [locn] print_unqual msg empty

-- Variant that doesn't care about qualified/unqualified names
mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg
mkPlainErrMsg locn msg
  = ErrMsg [locn] alwaysQualify msg empty

-- 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 
 = ErrMsg [locn] print_unqual msg extra

132 133
mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
mkWarnMsg = mkErrMsg
134 135 136

type Messages = (Bag WarnMsg, Bag ErrMsg)

137 138 139
emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)

140 141 142 143 144 145
errorsFound :: DynFlags -> Messages -> Bool
-- The dyn-flags are used to see if the user has specified
-- -Werorr, which says that warnings should be fatal
errorsFound dflags (warns, errs) 
  | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
  | otherwise  		        = not (isEmptyBag errs)
146

147 148
printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
printErrorsAndWarnings dflags (warns, errs)
149 150 151 152 153 154 155
  | no_errs && no_warns = return ()
  | no_errs             = do printBagOfWarnings dflags warns
                             when (dopt Opt_WarnIsError dflags) $
                                 errorMsg dflags $
                                     text "\nFailing due to -Werror.\n"
                          -- Don't print any warnings if there are errors
  | otherwise           = printBagOfErrors dflags errs
156 157 158 159
  where
    no_warns = isEmptyBag warns
    no_errs  = isEmptyBag errs

160 161 162 163
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
  = sequence_   [ let style = mkErrStyle unqual
		  in log_action dflags SevError s style (d $$ e)
twanvl's avatar
twanvl committed
164
		| ErrMsg { errMsgSpans = s:_,
165
			   errMsgShortDoc = d,
166 167
			   errMsgExtraInfo = e,
			   errMsgContext = unqual } <- sorted_errs ]
sof's avatar
sof committed
168 169
    where
      bag_ls	  = bagToList bag_of_errors
170
      sorted_errs = sortLe occ'ed_before bag_ls
sof's avatar
sof committed
171

172
      occ'ed_before err1 err2 = 
173 174 175 176
         case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
		LT -> True
		EQ -> True
		GT -> False
177

178 179 180 181
printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfWarnings dflags bag_of_warns
  = sequence_   [ let style = mkErrStyle unqual
		  in log_action dflags SevWarning s style (d $$ e)
twanvl's avatar
twanvl committed
182
		| ErrMsg { errMsgSpans = s:_,
183 184 185 186 187 188 189 190 191 192 193 194
			   errMsgShortDoc = d,
			   errMsgExtraInfo = e,
			   errMsgContext = unqual } <- sorted_errs ]
    where
      bag_ls	  = bagToList bag_of_warns
      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
195

196 197
handleFlagWarnings :: DynFlags -> [String] -> IO ()
handleFlagWarnings dflags warns
198 199 200 201 202 203
 = when (dopt Opt_WarnDeprecatedFlags dflags)
        (handleFlagWarnings' dflags warns)

handleFlagWarnings' :: DynFlags -> [String] -> IO ()
handleFlagWarnings' _ [] = return ()
handleFlagWarnings' dflags warns
204 205 206 207 208 209 210
 = do -- It would be nicer if warns :: [Message], but that has circular
      -- import problems.
      let warns' = map text warns
      mapM_ (log_action dflags SevWarning noSrcSpan defaultUserStyle) warns'
      when (dopt Opt_WarnIsError dflags) $
          do errorMsg dflags $ text "\nFailing due to -Werror.\n"
             exitWith (ExitFailure 1)
211

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

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

222 223 224
doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
doIfSet_dyn dflags flag action | dopt flag dflags = action
		               | otherwise        = return ()
sof's avatar
sof committed
225

226 227 228
-- -----------------------------------------------------------------------------
-- Dumping

229 230 231
dumpIfSet :: Bool -> String -> SDoc -> IO ()
dumpIfSet flag hdr doc
  | not flag   = return ()
232
  | otherwise  = printDump (mkDumpDoc hdr doc)
233

234 235 236 237 238 239 240 241 242
dumpIf_core :: Bool -> DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIf_core cond dflags dflag hdr doc
  | cond
    || verbosity dflags >= 4
    || dopt Opt_D_verbose_core2core dflags
  = dumpSDoc dflags dflag hdr doc

  | otherwise = return ()

243 244
dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_core dflags flag hdr doc
245
  = dumpIf_core (dopt flag dflags) dflags flag hdr doc
246

247
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
248
dumpIfSet_dyn dflags flag hdr doc
249
  | dopt flag dflags || verbosity dflags >= 4 
250
  = dumpSDoc dflags flag hdr doc
251 252
  | otherwise
  = return ()
253

254 255 256 257
dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
dumpIfSet_dyn_or dflags flags hdr doc
  | or [dopt flag dflags | flag <- flags]
  || verbosity dflags >= 4 
258
  = printDump (mkDumpDoc hdr doc)
259 260
  | otherwise = return ()

twanvl's avatar
twanvl committed
261
mkDumpDoc :: String -> SDoc -> SDoc
262
mkDumpDoc hdr doc 
263 264 265 266 267
   = vcat [text "", 
	   line <+> text hdr <+> line,
	   doc,
	   text ""]
     where 
sof's avatar
sof committed
268
        line = text (replicate 20 '=')
269

270 271 272 273

-- | Write out a dump.
--	If --dump-to-file is set then this goes to a file.
--	otherwise emit to stdout.
274 275
dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpSDoc dflags dflag hdr doc
276 277 278
 = do	let mFile	= chooseDumpFile dflags dflag
 	case mFile of
		-- write the dump to a file
279 280
		--	don't add the header in this case, we can see what kind
		--	of dump it is from the filename.
281 282 283 284 285 286 287
		Just fileName
		 -> do	handle	<- openFile fileName AppendMode
		 	hPrintDump handle doc
		 	hClose handle

		-- write the dump to stdout
		Nothing
288
		 -> do	printDump (mkDumpDoc hdr doc)
289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327


-- | 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


328 329 330 331 332 333 334 335 336 337 338 339 340
-- -----------------------------------------------------------------------------
-- 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 ()

341 342 343 344 345 346 347 348
putMsg :: DynFlags -> Message -> IO ()
putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg

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
349 350 351

compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg
352
  = ifVerbose dflags 1 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text msg))
353

354 355 356
showPass :: DynFlags -> String -> IO ()
showPass dflags what 
  = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
357

358
debugTraceMsg :: DynFlags -> Int -> Message -> IO ()
359
debugTraceMsg dflags val msg
360
  = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
361

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