Message, mkLocMessage, printError,
Severity(..),
- ErrMsg, WarnMsg,
+ ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
Messages, errorsFound, emptyMessages,
mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
+ handleFlagWarnings,
ghcExit,
doIfSet, doIfSet_dyn,
- dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,
+ dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
+ mkDumpDoc, dumpSDoc,
-- * Messages during compilation
putMsg,
#include "HsVersions.h"
-import Module ( ModLocation(..))
import Bag ( Bag, bagToList, isEmptyBag, emptyBag )
import SrcLoc ( SrcSpan )
import Util ( sortLe )
import DynFlags ( DynFlags(..), DynFlag(..), dopt )
import StaticFlags ( opt_ErrorSpans )
+import Control.Monad
import System.Exit ( ExitCode(..), exitWith )
import Data.Dynamic
import Data.List
import System.IO
+import Exception
-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.
-- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic
-- whether to qualify an External Name) at the error occurrence
+#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
+
-- So we can throw these things as exceptions
errMsgTc :: TyCon
errMsgTc = mkTyCon "ErrMsg"
{-# NOINLINE errMsgTc #-}
instance Typeable ErrMsg where
-#if __GLASGOW_HASKELL__ < 603
- typeOf _ = mkAppTy errMsgTc []
-#else
typeOf _ = mkTyConApp errMsgTc []
-#endif
type WarnMsg = ErrMsg
printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
printErrorsAndWarnings dflags (warns, errs)
- | no_errs && no_warns = return ()
- | no_errs = printBagOfWarnings dflags warns
- -- Don't print any warnings if there are errors
- | otherwise = printBagOfErrors dflags errs
+ | 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
where
no_warns = isEmptyBag warns
no_errs = isEmptyBag errs
printBagOfErrors dflags bag_of_errors
= sequence_ [ let style = mkErrStyle unqual
in log_action dflags SevError s style (d $$ e)
- | ErrMsg { errMsgSpans = s:ss,
+ | ErrMsg { errMsgSpans = s:_,
errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sorted_errs ]
printBagOfWarnings dflags bag_of_warns
= sequence_ [ let style = mkErrStyle unqual
in log_action dflags SevWarning s style (d $$ e)
- | ErrMsg { errMsgSpans = s:ss,
+ | ErrMsg { errMsgSpans = s:_,
errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sorted_errs ]
EQ -> True
GT -> False
-
+handleFlagWarnings :: DynFlags -> [String] -> IO ()
+handleFlagWarnings dflags warns
+ = when (dopt Opt_WarnDeprecatedFlags dflags)
+ (handleFlagWarnings' dflags warns)
+
+handleFlagWarnings' :: DynFlags -> [String] -> IO ()
+handleFlagWarnings' _ [] = return ()
+handleFlagWarnings' dflags warns
+ = 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)
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
| not flag = return ()
| otherwise = printDump (mkDumpDoc hdr doc)
+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 ()
+
dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_core dflags flag hdr doc
- | dopt flag dflags
- || verbosity dflags >= 4
- || dopt Opt_D_verbose_core2core dflags
- = writeDump dflags flag (mkDumpDoc hdr doc)
- | otherwise = return ()
+ = dumpIf_core (dopt flag dflags) dflags flag hdr doc
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
| dopt flag dflags || verbosity dflags >= 4
- = writeDump dflags flag (mkDumpDoc hdr doc)
+ = dumpSDoc dflags flag hdr doc
| otherwise
= return ()
= printDump (mkDumpDoc hdr doc)
| otherwise = return ()
+mkDumpDoc :: String -> SDoc -> SDoc
mkDumpDoc hdr doc
= vcat [text "",
line <+> text hdr <+> line,
-- | Write out a dump.
-- If --dump-to-file is set then this goes to a file.
-- otherwise emit to stdout.
-writeDump :: DynFlags -> DynFlag -> SDoc -> IO ()
-writeDump dflags dflag doc
+dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
+dumpSDoc dflags dflag hdr doc
= 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 handle <- openFile fileName AppendMode
hPrintDump handle doc
-- write the dump to stdout
Nothing
- -> do printDump doc
+ -> do printDump (mkDumpDoc hdr doc)
-- | Choose where to put a dump file based on DynFlags
projects / ghc-hetmet.git / blobdiff