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 Bag ( Bag, bagToList, isEmptyBag, emptyBag )
import SrcLoc ( SrcSpan )
-import Util ( sortLe, global )
+import Util ( sortLe )
import Outputable
-import qualified Pretty
import SrcLoc ( srcSpanStart, noSrcSpan )
import DynFlags ( DynFlags(..), DynFlag(..), dopt )
import StaticFlags ( opt_ErrorSpans )
-import System ( ExitCode(..), exitWith )
-import DATA_IOREF
-import IO ( hPutStrLn, stderr )
-import DYNAMIC
+import Control.Monad
+import System.Exit ( ExitCode(..), exitWith )
+import Data.Dynamic
+import Data.List
+import System.IO
-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.
errMsgTc = mkTyCon "ErrMsg"
{-# NOINLINE errMsgTc #-}
instance Typeable ErrMsg where
-#if __GLASGOW_HASKELL__ < 603
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
typeOf _ = mkAppTy errMsgTc []
#else
typeOf _ = mkTyConApp errMsgTc []
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}
+
+
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}
projects / ghc-hetmet.git / blobdiff