Message, mkLocMessage, printError,
Severity(..),
- ErrMsg, WarnMsg,
+ ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
Messages, errorsFound, emptyMessages,
- mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
+ mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
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,
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
mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
mkWarnMsg = mkErrMsg
+-- Variant that doesn't care about qualified/unqualified names
+mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg
+mkPlainWarnMsg locn msg = mkWarnMsg locn alwaysQualify msg
+
type Messages = (Bag WarnMsg, Bag ErrMsg)
emptyMessages :: Messages
errorsFound :: DynFlags -> Messages -> Bool
-- The dyn-flags are used to see if the user has specified
--- -Werorr, which says that warnings should be fatal
+-- -Werror, 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)
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 ]
LT -> True
EQ -> True
GT -> False
-\end{code}
-\begin{code}
+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
| val == 0 = exitWith ExitSuccess
| otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
exitWith (ExitFailure val)
-\end{code}
-\begin{code}
doIfSet :: Bool -> IO () -> IO ()
doIfSet flag action | flag = action
| otherwise = return ()
doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
doIfSet_dyn dflags flag action | dopt flag dflags = action
| otherwise = return ()
-\end{code}
-\begin{code}
+-- -----------------------------------------------------------------------------
+-- Dumping
+
dumpIfSet :: Bool -> String -> SDoc -> IO ()
dumpIfSet flag hdr doc
| 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 = printDump (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
- = printDump (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,
where
line = text (replicate 20 '=')
+
+-- | Write out a dump.
+-- If --dump-to-file is set then this goes to a file.
+-- otherwise emit to stdout.
+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
+ hClose handle
+
+ -- write the dump to stdout
+ Nothing
+ -> do printDump (mkDumpDoc hdr doc)
+
+
+-- | 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
+
+
-- -----------------------------------------------------------------------------
-- Outputting messages from the compiler
debugTraceMsg :: DynFlags -> Int -> Message -> IO ()
debugTraceMsg dflags val msg
= ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
+
\end{code}