Commit bdfa0107 authored by krasimir's avatar krasimir
Browse files

[project @ 2005-04-05 09:06:36 by krasimir]

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.
parent 43c2b681
...@@ -66,7 +66,7 @@ endPass dflags pass_name dump_flag binds ...@@ -66,7 +66,7 @@ endPass dflags pass_name dump_flag binds
= do = do
-- Report result size if required -- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated -- This has the side effect of forcing the intermediate to be evaluated
debugTraceMsg dflags $ debugTraceMsg dflags 2 $
" Result size = " ++ show (coreBindsSize binds) " Result size = " ++ show (coreBindsSize binds)
-- Report verbosely, if required -- Report verbosely, if required
......
...@@ -40,6 +40,7 @@ import Maybe ( isJust ) ...@@ -40,6 +40,7 @@ import Maybe ( isJust )
#if __GLASGOW_HASKELL__ <= 408 #if __GLASGOW_HASKELL__ <= 408
import Panic ( catchJust, ioErrors ) import Panic ( catchJust, ioErrors )
#endif #endif
import ErrUtils ( debugTraceMsg )
----------------------------------------------------------------- -----------------------------------------------------------------
-- --
...@@ -65,9 +66,7 @@ doMkDependHS session srcs ...@@ -65,9 +66,7 @@ doMkDependHS session srcs
; let sorted = GHC.topSortModuleGraph False mod_summaries Nothing ; let sorted = GHC.topSortModuleGraph False mod_summaries Nothing
-- Print out the dependencies if wanted -- Print out the dependencies if wanted
; if verbosity dflags >= 2 then ; debugTraceMsg dflags 2 (showSDoc (text "Module dependencies" $$ ppr sorted))
hPutStrLn stderr (showSDoc (text "Module dependencies" $$ ppr sorted))
else return ()
-- Prcess them one by one, dumping results into makefile -- Prcess them one by one, dumping results into makefile
-- and complaining about cycles -- and complaining about cycles
......
...@@ -114,12 +114,11 @@ compile hsc_env mod_summary maybe_old_linkable old_iface = do ...@@ -114,12 +114,11 @@ compile hsc_env mod_summary maybe_old_linkable old_iface = do
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 location = ms_location mod_summary
let input_fn = expectJust "compile:hs" (ml_hs_file location) let input_fn = expectJust "compile:hs" (ml_hs_file location)
let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary) 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 -- Add in the OPTIONS from the source file
-- This is nasty: we've done this once already, in the compilation manager -- This is nasty: we've done this once already, in the compilation manager
...@@ -265,19 +264,16 @@ link BatchCompile dflags batch_attempt_linking hpt ...@@ -265,19 +264,16 @@ link BatchCompile dflags batch_attempt_linking hpt
-- the linkables to link -- the linkables to link
linkables = map (fromJust.hm_linkable) home_mod_infos linkables = map (fromJust.hm_linkable) home_mod_infos
when (verb >= 3) $ do debugTraceMsg dflags 3 "link: linkables are ..."
hPutStrLn stderr "link: linkables are ..." debugTraceMsg dflags 3 (showSDoc (vcat (map ppr linkables)))
hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
-- check for the -no-link flag -- check for the -no-link flag
if isNoLink (ghcLink dflags) if isNoLink (ghcLink dflags)
then do when (verb >= 3) $ then do debugTraceMsg dflags 3 "link(batch): linking omitted (-c flag given)."
hPutStrLn stderr "link(batch): linking omitted (-c flag given)."
return Succeeded return Succeeded
else do else do
when (verb >= 1) $ debugTraceMsg dflags 1 "Linking ..."
hPutStrLn stderr "Linking ..."
let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
obj_files = concatMap getOfiles linkables obj_files = concatMap getOfiles linkables
...@@ -285,18 +281,15 @@ link BatchCompile dflags batch_attempt_linking hpt ...@@ -285,18 +281,15 @@ link BatchCompile dflags batch_attempt_linking hpt
-- Don't showPass in Batch mode; doLink will do that for us. -- Don't showPass in Batch mode; doLink will do that for us.
staticLink dflags obj_files pkg_deps staticLink dflags obj_files pkg_deps
when (verb >= 3) (hPutStrLn stderr "link: done") debugTraceMsg dflags 3 "link: done"
-- staticLink only returns if it succeeds -- staticLink only returns if it succeeds
return Succeeded return Succeeded
| otherwise | otherwise
= do when (verb >= 3) $ do = do debugTraceMsg dflags 3 "link(batch): upsweep (partially) failed OR"
hPutStrLn stderr "link(batch): upsweep (partially) failed OR" debugTraceMsg dflags 3 " Main.main not exported; not linking."
hPutStrLn stderr " Main.main not exported; not linking."
return Succeeded return Succeeded
where
verb = verbosity dflags
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
......
...@@ -219,9 +219,9 @@ compilationPassMsg :: DynFlags -> String -> IO () ...@@ -219,9 +219,9 @@ compilationPassMsg :: DynFlags -> String -> IO ()
compilationPassMsg dflags msg compilationPassMsg dflags msg
= ifVerbose dflags 2 (putMsg msg) = ifVerbose dflags 2 (putMsg msg)
debugTraceMsg :: DynFlags -> String -> IO () debugTraceMsg :: DynFlags -> Int -> String -> IO ()
debugTraceMsg dflags msg debugTraceMsg dflags val msg
= ifVerbose dflags 2 (putMsg msg) = ifVerbose dflags val (putMsg msg)
GLOBAL_VAR(msgHandler, hPutStrLn stderr, (String -> IO ())) GLOBAL_VAR(msgHandler, hPutStrLn stderr, (String -> IO ()))
......
...@@ -68,6 +68,9 @@ module GHC ( ...@@ -68,6 +68,9 @@ module GHC (
-- used by DriverMkDepend: -- used by DriverMkDepend:
sessionHscEnv, sessionHscEnv,
cyclicModuleErr, cyclicModuleErr,
-- Exceptions
GhcException(..)
) where ) where
{- {-
...@@ -123,7 +126,7 @@ import Module ...@@ -123,7 +126,7 @@ import Module
import FiniteMap import FiniteMap
import Panic import Panic
import Digraph import Digraph
import ErrUtils ( showPass, Messages, putMsg ) import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg )
import qualified ErrUtils import qualified ErrUtils
import Util import Util
import StringBuffer ( StringBuffer, hGetStringBuffer ) import StringBuffer ( StringBuffer, hGetStringBuffer )
...@@ -159,10 +162,10 @@ defaultErrorHandler inner = ...@@ -159,10 +162,10 @@ defaultErrorHandler inner =
hFlush stdout hFlush stdout
case exception of case exception of
-- an IO exception probably isn't our fault, so don't panic -- 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" putMsg "stack overflow: use +RTS -K<size> to increase it"
_other -> hPutStr stderr (show (Panic (show exception))) _other -> putMsg (show (Panic (show exception)))
exitWith (ExitFailure 1) exitWith (ExitFailure 1)
) $ ) $
...@@ -172,7 +175,7 @@ defaultErrorHandler inner = ...@@ -172,7 +175,7 @@ defaultErrorHandler inner =
case dyn of case dyn of
PhaseFailed _ code -> exitWith code PhaseFailed _ code -> exitWith code
Interrupted -> exitWith (ExitFailure 1) Interrupted -> exitWith (ExitFailure 1)
_ -> do hPutStrLn stderr (show (dyn :: GhcException)) _ -> do putMsg (show (dyn :: GhcException))
exitWith (ExitFailure 1) exitWith (ExitFailure 1)
) $ ) $
inner inner
...@@ -321,8 +324,8 @@ depanal (Session ref) excluded_mods = do ...@@ -321,8 +324,8 @@ depanal (Session ref) excluded_mods = do
old_graph = hsc_mod_graph hsc_env old_graph = hsc_mod_graph hsc_env
showPass dflags "Chasing dependencies" showPass dflags "Chasing dependencies"
when (verbosity dflags >= 1 && gmode == BatchCompile) $ when (gmode == BatchCompile) $
hPutStrLn stderr (showSDoc (hcat [ debugTraceMsg dflags 1 (showSDoc (hcat [
text "Chasing modules from: ", text "Chasing modules from: ",
hcat (punctuate comma (map pprTarget targets))])) hcat (punctuate comma (map pprTarget targets))]))
...@@ -401,8 +404,7 @@ load s@(Session ref) how_much ...@@ -401,8 +404,7 @@ load s@(Session ref) how_much
evaluate pruned_hpt evaluate pruned_hpt
when (verb >= 2) $ debugTraceMsg dflags 2 (showSDoc (text "Stable obj:" <+> ppr stable_obj $$
putStrLn (showSDoc (text "Stable obj:" <+> ppr stable_obj $$
text "Stable BCO:" <+> ppr stable_bco)) text "Stable BCO:" <+> ppr stable_bco))
-- Unload any modules which are going to be re-linked this time around. -- Unload any modules which are going to be re-linked this time around.
...@@ -480,7 +482,7 @@ load s@(Session ref) how_much ...@@ -480,7 +482,7 @@ load s@(Session ref) how_much
then then
-- Easy; just relink it all. -- Easy; just relink it all.
do when (verb >= 2) $ putMsg "Upsweep completely successful." do debugTraceMsg dflags 2 "Upsweep completely successful."
-- Clean up after ourselves -- Clean up after ourselves
cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
...@@ -501,9 +503,8 @@ load s@(Session ref) how_much ...@@ -501,9 +503,8 @@ load s@(Session ref) how_much
mod_graph mod_graph
do_linking = a_root_is_Main || no_hs_main do_linking = a_root_is_Main || no_hs_main
when (ghci_mode == BatchCompile && isJust ofile && not do_linking when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
&& verb > 0) $ debugTraceMsg dflags 1 ("Warning: output was redirected with -o, " ++
putMsg ("Warning: output was redirected with -o, " ++
"but no output will be generated\n" ++ "but no output will be generated\n" ++
"because there is no " ++ main_mod ++ " module.") "because there is no " ++ main_mod ++ " module.")
...@@ -516,7 +517,7 @@ load s@(Session ref) how_much ...@@ -516,7 +517,7 @@ load s@(Session ref) how_much
-- Tricky. We need to back out the effects of compiling any -- Tricky. We need to back out the effects of compiling any
-- half-done cycles, both so as to clean up the top level envs -- half-done cycles, both so as to clean up the top level envs
-- and to avoid telling the interactive linker to link them. -- 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 let modsDone_names
= map ms_mod modsDone = map ms_mod modsDone
...@@ -814,7 +815,7 @@ upsweep hsc_env old_hpt stable_mods cleanup ...@@ -814,7 +815,7 @@ upsweep hsc_env old_hpt stable_mods cleanup
upsweep hsc_env old_hpt stable_mods cleanup upsweep hsc_env old_hpt stable_mods cleanup
(CyclicSCC ms:_) (CyclicSCC ms:_)
= do hPutStrLn stderr (showSDoc (cyclicModuleErr ms)) = do putMsg (showSDoc (cyclicModuleErr ms))
return (Failed, hsc_env, []) return (Failed, hsc_env, [])
upsweep hsc_env old_hpt stable_mods cleanup upsweep hsc_env old_hpt stable_mods cleanup
......
...@@ -60,7 +60,6 @@ import Compat.Directory ( getAppUserDataDirectory ) ...@@ -60,7 +60,6 @@ import Compat.Directory ( getAppUserDataDirectory )
import Distribution.InstalledPackageInfo import Distribution.InstalledPackageInfo
import Distribution.Package import Distribution.Package
import Distribution.Version import Distribution.Version
import System.IO ( hPutStrLn, stderr )
import Data.Maybe ( isNothing ) import Data.Maybe ( isNothing )
import System.Directory ( doesFileExist ) import System.Directory ( doesFileExist )
import Control.Monad ( when, foldM ) import Control.Monad ( when, foldM )
...@@ -73,6 +72,7 @@ import Data.List ( isPrefixOf ) ...@@ -73,6 +72,7 @@ import Data.List ( isPrefixOf )
import FastString import FastString
import DATA_IOREF import DATA_IOREF
import EXCEPTION ( throwDyn ) import EXCEPTION ( throwDyn )
import ErrUtils ( debugTraceMsg, putMsg )
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
-- The Package state -- The Package state
...@@ -225,9 +225,7 @@ readPackageConfigs dflags = do ...@@ -225,9 +225,7 @@ readPackageConfigs dflags = do
readPackageConfig readPackageConfig
:: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap :: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap
readPackageConfig dflags pkg_map conf_file = do readPackageConfig dflags pkg_map conf_file = do
when (verbosity dflags >= 2) $ debugTraceMsg dflags 2 ("Using package config file: " ++ conf_file)
hPutStrLn stderr ("Using package config file: "
++ conf_file)
proto_pkg_configs <- loadPackageConfig conf_file proto_pkg_configs <- loadPackageConfig conf_file
top_dir <- getTopDir top_dir <- getTopDir
let pkg_configs = mungePackagePaths top_dir proto_pkg_configs let pkg_configs = mungePackagePaths top_dir proto_pkg_configs
...@@ -566,6 +564,6 @@ dumpPackages :: DynFlags -> IO () ...@@ -566,6 +564,6 @@ dumpPackages :: DynFlags -> IO ()
-- Show package info on console, if verbosity is >= 3 -- Show package info on console, if verbosity is >= 3
dumpPackages dflags dumpPackages dflags
= do let pkg_map = pkgIdMap (pkgState dflags) = do let pkg_map = pkgIdMap (pkgState dflags)
hPutStrLn stderr $ showSDoc $ putMsg $ showSDoc $
vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map)) vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map))
\end{code} \end{code}
...@@ -87,7 +87,6 @@ import DATA_IOREF ...@@ -87,7 +87,6 @@ import DATA_IOREF
import UNSAFE_IO ( unsafePerformIO ) import UNSAFE_IO ( unsafePerformIO )
import Monad ( when ) import Monad ( when )
import Char ( isDigit ) import Char ( isDigit )
import IO ( hPutStrLn, stderr ) -- ToDo: should use errorMsg
import List ( sort, intersperse ) import List ( sort, intersperse )
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
......
...@@ -47,7 +47,7 @@ module SysTools ( ...@@ -47,7 +47,7 @@ module SysTools (
import DriverPhases ( isHaskellUserSrcFilename ) import DriverPhases ( isHaskellUserSrcFilename )
import Config import Config
import Outputable import Outputable
import ErrUtils ( putMsg ) import ErrUtils ( putMsg, debugTraceMsg )
import Panic ( GhcException(..) ) import Panic ( GhcException(..) )
import Util ( Suffix, global, notNull, consIORef, import Util ( Suffix, global, notNull, consIORef,
normalisePath, pgmPath, platformPath ) normalisePath, pgmPath, platformPath )
...@@ -61,7 +61,7 @@ import DATA_INT ...@@ -61,7 +61,7 @@ import DATA_INT
import Monad ( when, unless ) import Monad ( when, unless )
import System ( ExitCode(..), getEnv, system ) import System ( ExitCode(..), getEnv, system )
import IO ( try, catch, import IO ( try, catch,
openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..), openFile, hPutStr, hClose, hFlush, IOMode(..),
stderr ) stderr )
import Directory ( doesFileExist, removeFile ) import Directory ( doesFileExist, removeFile )
import List ( partition ) import List ( partition )
...@@ -490,7 +490,7 @@ touch dflags purpose arg = do ...@@ -490,7 +490,7 @@ touch dflags purpose arg = do
copy :: DynFlags -> String -> String -> String -> IO () copy :: DynFlags -> String -> String -> String -> IO ()
copy dflags purpose from to = do copy dflags purpose from to = do
when (verbosity dflags >= 2) $ hPutStrLn stderr ("*** " ++ purpose) debugTraceMsg dflags 2 ("*** " ++ purpose)
h <- openFile to WriteMode h <- openFile to WriteMode
ls <- readFile from -- inefficient, but it'll do for now. ls <- readFile from -- inefficient, but it'll do for now.
...@@ -562,8 +562,6 @@ removeTmpFiles dflags fs ...@@ -562,8 +562,6 @@ removeTmpFiles dflags fs
("Deleting: " ++ unwords deletees) ("Deleting: " ++ unwords deletees)
(mapM_ rm deletees) (mapM_ rm deletees)
where where
verb = verbosity dflags
-- Flat out refuse to delete files that are likely to be source input -- 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 (is there a worse bug than having a compiler delete your source
-- files?) -- files?)
...@@ -573,15 +571,14 @@ removeTmpFiles dflags fs ...@@ -573,15 +571,14 @@ removeTmpFiles dflags fs
warnNon act warnNon act
| null non_deletees = act | null non_deletees = act
| otherwise = do | otherwise = do
hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees) putMsg ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
act act
(non_deletees, deletees) = partition isHaskellUserSrcFilename fs (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
rm f = removeFile f `IO.catch` rm f = removeFile f `IO.catch`
(\_ignored -> (\_ignored ->
when (verb >= 2) $ debugTraceMsg dflags 2 ("Warning: deleting non-existent " ++ f)
hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
) )
...@@ -622,8 +619,8 @@ traceCmd :: DynFlags -> String -> String -> IO () -> IO () ...@@ -622,8 +619,8 @@ traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
-- b) don't do it at all if dry-run is set -- b) don't do it at all if dry-run is set
traceCmd dflags phase_name cmd_line action traceCmd dflags phase_name cmd_line action
= do { let verb = verbosity dflags = do { let verb = verbosity dflags
; when (verb >= 2) $ putMsg ("*** " ++ phase_name) ; debugTraceMsg dflags 2 ("*** " ++ phase_name)
; when (verb >= 3) $ putMsg cmd_line ; debugTraceMsg dflags 3 cmd_line
; hFlush stderr ; hFlush stderr
-- Test for -n flag -- Test for -n flag
...@@ -633,8 +630,8 @@ traceCmd dflags phase_name cmd_line action ...@@ -633,8 +630,8 @@ traceCmd dflags phase_name cmd_line action
; action `IO.catch` handle_exn verb ; action `IO.catch` handle_exn verb
}} }}
where where
handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n") handle_exn verb exn = do { debugTraceMsg dflags 2 "\n"
; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn))) ; debugTraceMsg dflags 2 ("Failed: " ++ cmd_line ++ (show exn))
; throwDyn (PhaseFailed phase_name (ExitFailure 1)) } ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
\end{code} \end{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment