In many places there was a common pattern
when (verbose >= n) $ putMsg "..."
It is now replaced with
debutTraceMsg dflags n "..."
In few places hPutStrLn stderr or putStrLn was used instead of putMsg in
the above pattern. They are replaced too. Now putMsg is used only in places
where the verbosity flag was not checked.
= do
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
= do
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
+ debugTraceMsg dflags 2 $
" Result size = " ++ show (coreBindsSize binds)
-- Report verbosely, if required
" Result size = " ++ show (coreBindsSize binds)
-- Report verbosely, if required
#if __GLASGOW_HASKELL__ <= 408
import Panic ( catchJust, ioErrors )
#endif
#if __GLASGOW_HASKELL__ <= 408
import Panic ( catchJust, ioErrors )
#endif
+import ErrUtils ( debugTraceMsg )
-----------------------------------------------------------------
--
-----------------------------------------------------------------
--
; let sorted = GHC.topSortModuleGraph False mod_summaries Nothing
-- Print out the dependencies if wanted
; let sorted = GHC.topSortModuleGraph False mod_summaries Nothing
-- Print out the dependencies if wanted
- ; if verbosity dflags >= 2 then
- hPutStrLn stderr (showSDoc (text "Module dependencies" $$ ppr sorted))
- else return ()
+ ; debugTraceMsg dflags 2 (showSDoc (text "Module dependencies" $$ ppr sorted))
-- Prcess them one by one, dumping results into makefile
-- and complaining about cycles
-- Prcess them one by one, dumping results into makefile
-- and complaining about cycles
showPass dflags0 ("Compiling " ++ showModMsg have_object mod_summary)
showPass dflags0 ("Compiling " ++ showModMsg have_object mod_summary)
- let verb = verbosity dflags0
let location = ms_location mod_summary
let input_fn = expectJust "compile:hs" (ml_hs_file location)
let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary)
let location = ms_location mod_summary
let input_fn = expectJust "compile:hs" (ml_hs_file location)
let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary)
- when (verb >= 2) (putMsg ("compile: input file " ++ input_fnpp))
+ debugTraceMsg dflags0 2 ("compile: input file " ++ input_fnpp)
-- Add in the OPTIONS from the source file
-- This is nasty: we've done this once already, in the compilation manager
-- Add in the OPTIONS from the source file
-- This is nasty: we've done this once already, in the compilation manager
-- the linkables to link
linkables = map (fromJust.hm_linkable) home_mod_infos
-- the linkables to link
linkables = map (fromJust.hm_linkable) home_mod_infos
- when (verb >= 3) $ do
- hPutStrLn stderr "link: linkables are ..."
- hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
+ debugTraceMsg dflags 3 "link: linkables are ..."
+ debugTraceMsg dflags 3 (showSDoc (vcat (map ppr linkables)))
-- check for the -no-link flag
if isNoLink (ghcLink dflags)
-- check for the -no-link flag
if isNoLink (ghcLink dflags)
- then do when (verb >= 3) $
- hPutStrLn stderr "link(batch): linking omitted (-c flag given)."
+ then do debugTraceMsg dflags 3 "link(batch): linking omitted (-c flag given)."
- when (verb >= 1) $
- hPutStrLn stderr "Linking ..."
+ debugTraceMsg dflags 1 "Linking ..."
let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
obj_files = concatMap getOfiles linkables
let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
obj_files = concatMap getOfiles linkables
-- Don't showPass in Batch mode; doLink will do that for us.
staticLink dflags obj_files pkg_deps
-- Don't showPass in Batch mode; doLink will do that for us.
staticLink dflags obj_files pkg_deps
- when (verb >= 3) (hPutStrLn stderr "link: done")
+ debugTraceMsg dflags 3 "link: done"
-- staticLink only returns if it succeeds
return Succeeded
| otherwise
-- staticLink only returns if it succeeds
return Succeeded
| otherwise
- = do when (verb >= 3) $ do
- hPutStrLn stderr "link(batch): upsweep (partially) failed OR"
- hPutStrLn stderr " Main.main not exported; not linking."
+ = do debugTraceMsg dflags 3 "link(batch): upsweep (partially) failed OR"
+ debugTraceMsg dflags 3 " Main.main not exported; not linking."
- where
- verb = verbosity dflags
-- -----------------------------------------------------------------------------
-- -----------------------------------------------------------------------------
compilationPassMsg dflags msg
= ifVerbose dflags 2 (putMsg msg)
compilationPassMsg dflags msg
= ifVerbose dflags 2 (putMsg msg)
-debugTraceMsg :: DynFlags -> String -> IO ()
-debugTraceMsg dflags msg
- = ifVerbose dflags 2 (putMsg msg)
+debugTraceMsg :: DynFlags -> Int -> String -> IO ()
+debugTraceMsg dflags val msg
+ = ifVerbose dflags val (putMsg msg)
GLOBAL_VAR(msgHandler, hPutStrLn stderr, (String -> IO ()))
GLOBAL_VAR(msgHandler, hPutStrLn stderr, (String -> IO ()))
-- used by DriverMkDepend:
sessionHscEnv,
cyclicModuleErr,
-- used by DriverMkDepend:
sessionHscEnv,
cyclicModuleErr,
+
+ -- Exceptions
+ GhcException(..)
import FiniteMap
import Panic
import Digraph
import FiniteMap
import Panic
import Digraph
-import ErrUtils ( showPass, Messages, putMsg )
+import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg )
import qualified ErrUtils
import Util
import StringBuffer ( StringBuffer, hGetStringBuffer )
import qualified ErrUtils
import Util
import StringBuffer ( StringBuffer, hGetStringBuffer )
hFlush stdout
case exception of
-- an IO exception probably isn't our fault, so don't panic
hFlush stdout
case exception of
-- an IO exception probably isn't our fault, so don't panic
- IOException _ -> hPutStrLn stderr (show exception)
+ IOException _ -> putMsg (show exception)
AsyncException StackOverflow ->
AsyncException StackOverflow ->
- hPutStrLn stderr "stack overflow: use +RTS -K<size> to increase it"
- _other -> hPutStr stderr (show (Panic (show exception)))
+ putMsg "stack overflow: use +RTS -K<size> to increase it"
+ _other -> putMsg (show (Panic (show exception)))
exitWith (ExitFailure 1)
) $
exitWith (ExitFailure 1)
) $
case dyn of
PhaseFailed _ code -> exitWith code
Interrupted -> exitWith (ExitFailure 1)
case dyn of
PhaseFailed _ code -> exitWith code
Interrupted -> exitWith (ExitFailure 1)
- _ -> do hPutStrLn stderr (show (dyn :: GhcException))
+ _ -> do putMsg (show (dyn :: GhcException))
exitWith (ExitFailure 1)
) $
inner
exitWith (ExitFailure 1)
) $
inner
old_graph = hsc_mod_graph hsc_env
showPass dflags "Chasing dependencies"
old_graph = hsc_mod_graph hsc_env
showPass dflags "Chasing dependencies"
- when (verbosity dflags >= 1 && gmode == BatchCompile) $
- hPutStrLn stderr (showSDoc (hcat [
+ when (gmode == BatchCompile) $
+ debugTraceMsg dflags 1 (showSDoc (hcat [
text "Chasing modules from: ",
hcat (punctuate comma (map pprTarget targets))]))
text "Chasing modules from: ",
hcat (punctuate comma (map pprTarget targets))]))
- when (verb >= 2) $
- putStrLn (showSDoc (text "Stable obj:" <+> ppr stable_obj $$
+ debugTraceMsg dflags 2 (showSDoc (text "Stable obj:" <+> ppr stable_obj $$
text "Stable BCO:" <+> ppr stable_bco))
-- Unload any modules which are going to be re-linked this time around.
text "Stable BCO:" <+> ppr stable_bco))
-- Unload any modules which are going to be re-linked this time around.
then
-- Easy; just relink it all.
then
-- Easy; just relink it all.
- do when (verb >= 2) $ putMsg "Upsweep completely successful."
+ do debugTraceMsg dflags 2 "Upsweep completely successful."
-- Clean up after ourselves
cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
-- Clean up after ourselves
cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
mod_graph
do_linking = a_root_is_Main || no_hs_main
mod_graph
do_linking = a_root_is_Main || no_hs_main
- when (ghci_mode == BatchCompile && isJust ofile && not do_linking
- && verb > 0) $
- putMsg ("Warning: output was redirected with -o, " ++
+ when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
+ debugTraceMsg dflags 1 ("Warning: output was redirected with -o, " ++
"but no output will be generated\n" ++
"because there is no " ++ main_mod ++ " module.")
"but no output will be generated\n" ++
"because there is no " ++ main_mod ++ " module.")
-- Tricky. We need to back out the effects of compiling any
-- half-done cycles, both so as to clean up the top level envs
-- and to avoid telling the interactive linker to link them.
-- Tricky. We need to back out the effects of compiling any
-- half-done cycles, both so as to clean up the top level envs
-- and to avoid telling the interactive linker to link them.
- do when (verb >= 2) $ putMsg "Upsweep partially successful."
+ do debugTraceMsg dflags 2 "Upsweep partially successful."
let modsDone_names
= map ms_mod modsDone
let modsDone_names
= map ms_mod modsDone
upsweep hsc_env old_hpt stable_mods cleanup
(CyclicSCC ms:_)
upsweep hsc_env old_hpt stable_mods cleanup
(CyclicSCC ms:_)
- = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms))
+ = do putMsg (showSDoc (cyclicModuleErr ms))
return (Failed, hsc_env, [])
upsweep hsc_env old_hpt stable_mods cleanup
return (Failed, hsc_env, [])
upsweep hsc_env old_hpt stable_mods cleanup
import Distribution.InstalledPackageInfo
import Distribution.Package
import Distribution.Version
import Distribution.InstalledPackageInfo
import Distribution.Package
import Distribution.Version
-import System.IO ( hPutStrLn, stderr )
import Data.Maybe ( isNothing )
import System.Directory ( doesFileExist )
import Control.Monad ( when, foldM )
import Data.Maybe ( isNothing )
import System.Directory ( doesFileExist )
import Control.Monad ( when, foldM )
import FastString
import DATA_IOREF
import EXCEPTION ( throwDyn )
import FastString
import DATA_IOREF
import EXCEPTION ( throwDyn )
+import ErrUtils ( debugTraceMsg, putMsg )
-- ---------------------------------------------------------------------------
-- The Package state
-- ---------------------------------------------------------------------------
-- The Package state
readPackageConfig
:: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap
readPackageConfig dflags pkg_map conf_file = do
readPackageConfig
:: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap
readPackageConfig dflags pkg_map conf_file = do
- when (verbosity dflags >= 2) $
- hPutStrLn stderr ("Using package config file: "
- ++ conf_file)
+ debugTraceMsg dflags 2 ("Using package config file: " ++ conf_file)
proto_pkg_configs <- loadPackageConfig conf_file
top_dir <- getTopDir
let pkg_configs = mungePackagePaths top_dir proto_pkg_configs
proto_pkg_configs <- loadPackageConfig conf_file
top_dir <- getTopDir
let pkg_configs = mungePackagePaths top_dir proto_pkg_configs
-- Show package info on console, if verbosity is >= 3
dumpPackages dflags
= do let pkg_map = pkgIdMap (pkgState dflags)
-- Show package info on console, if verbosity is >= 3
dumpPackages dflags
= do let pkg_map = pkgIdMap (pkgState dflags)
- hPutStrLn stderr $ showSDoc $
vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map))
\end{code}
vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map))
\end{code}
import UNSAFE_IO ( unsafePerformIO )
import Monad ( when )
import Char ( isDigit )
import UNSAFE_IO ( unsafePerformIO )
import Monad ( when )
import Char ( isDigit )
-import IO ( hPutStrLn, stderr ) -- ToDo: should use errorMsg
import List ( sort, intersperse )
-----------------------------------------------------------------------------
import List ( sort, intersperse )
-----------------------------------------------------------------------------
import DriverPhases ( isHaskellUserSrcFilename )
import Config
import Outputable
import DriverPhases ( isHaskellUserSrcFilename )
import Config
import Outputable
-import ErrUtils ( putMsg )
+import ErrUtils ( putMsg, debugTraceMsg )
import Panic ( GhcException(..) )
import Util ( Suffix, global, notNull, consIORef,
normalisePath, pgmPath, platformPath )
import Panic ( GhcException(..) )
import Util ( Suffix, global, notNull, consIORef,
normalisePath, pgmPath, platformPath )
import Monad ( when, unless )
import System ( ExitCode(..), getEnv, system )
import IO ( try, catch,
import Monad ( when, unless )
import System ( ExitCode(..), getEnv, system )
import IO ( try, catch,
- openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
+ openFile, hPutStr, hClose, hFlush, IOMode(..),
stderr )
import Directory ( doesFileExist, removeFile )
import List ( partition )
stderr )
import Directory ( doesFileExist, removeFile )
import List ( partition )
copy :: DynFlags -> String -> String -> String -> IO ()
copy dflags purpose from to = do
copy :: DynFlags -> String -> String -> String -> IO ()
copy dflags purpose from to = do
- when (verbosity dflags >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
+ debugTraceMsg dflags 2 ("*** " ++ purpose)
h <- openFile to WriteMode
ls <- readFile from -- inefficient, but it'll do for now.
h <- openFile to WriteMode
ls <- readFile from -- inefficient, but it'll do for now.
("Deleting: " ++ unwords deletees)
(mapM_ rm deletees)
where
("Deleting: " ++ unwords deletees)
(mapM_ rm deletees)
where
- verb = verbosity dflags
-
-- Flat out refuse to delete files that are likely to be source input
-- files (is there a worse bug than having a compiler delete your source
-- files?)
-- Flat out refuse to delete files that are likely to be source input
-- files (is there a worse bug than having a compiler delete your source
-- files?)
warnNon act
| null non_deletees = act
| otherwise = do
warnNon act
| null non_deletees = act
| otherwise = do
- hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
+ putMsg ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
act
(non_deletees, deletees) = partition isHaskellUserSrcFilename fs
rm f = removeFile f `IO.catch`
(\_ignored ->
act
(non_deletees, deletees) = partition isHaskellUserSrcFilename fs
rm f = removeFile f `IO.catch`
(\_ignored ->
- when (verb >= 2) $
- hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
+ debugTraceMsg dflags 2 ("Warning: deleting non-existent " ++ f)
-- b) don't do it at all if dry-run is set
traceCmd dflags phase_name cmd_line action
= do { let verb = verbosity dflags
-- b) don't do it at all if dry-run is set
traceCmd dflags phase_name cmd_line action
= do { let verb = verbosity dflags
- ; when (verb >= 2) $ putMsg ("*** " ++ phase_name)
- ; when (verb >= 3) $ putMsg cmd_line
+ ; debugTraceMsg dflags 2 ("*** " ++ phase_name)
+ ; debugTraceMsg dflags 3 cmd_line
; hFlush stderr
-- Test for -n flag
; hFlush stderr
-- Test for -n flag
; action `IO.catch` handle_exn verb
}}
where
; action `IO.catch` handle_exn verb
}}
where
- handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
- ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
+ handle_exn verb exn = do { debugTraceMsg dflags 2 "\n"
+ ; debugTraceMsg dflags 2 ("Failed: " ++ cmd_line ++ (show exn))
; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}
; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}