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
= do
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
debugTraceMsg dflags $
debugTraceMsg dflags 2 $
" Result size = " ++ show (coreBindsSize binds)
-- Report verbosely, if required
......
......@@ -40,6 +40,7 @@ import Maybe ( isJust )
#if __GLASGOW_HASKELL__ <= 408
import Panic ( catchJust, ioErrors )
#endif
import ErrUtils ( debugTraceMsg )
-----------------------------------------------------------------
--
......@@ -65,9 +66,7 @@ doMkDependHS session srcs
; 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
......
......@@ -114,12 +114,11 @@ compile hsc_env mod_summary maybe_old_linkable old_iface = do
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)
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
......@@ -265,19 +264,16 @@ link BatchCompile dflags batch_attempt_linking hpt
-- 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)
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)."
return Succeeded
else do
when (verb >= 1) $
hPutStrLn stderr "Linking ..."
debugTraceMsg dflags 1 "Linking ..."
let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
obj_files = concatMap getOfiles linkables
......@@ -285,18 +281,15 @@ link BatchCompile dflags batch_attempt_linking hpt
-- 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
= 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."
return Succeeded
where
verb = verbosity dflags
-- -----------------------------------------------------------------------------
......
......@@ -219,9 +219,9 @@ compilationPassMsg :: DynFlags -> String -> IO ()
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 ()))
......
......@@ -68,6 +68,9 @@ module GHC (
-- used by DriverMkDepend:
sessionHscEnv,
cyclicModuleErr,
-- Exceptions
GhcException(..)
) where
{-
......@@ -123,7 +126,7 @@ import Module
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 )
......@@ -159,10 +162,10 @@ defaultErrorHandler inner =
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 ->
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)
) $
......@@ -172,7 +175,7 @@ defaultErrorHandler inner =
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
......@@ -321,8 +324,8 @@ depanal (Session ref) excluded_mods = do
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))]))
......@@ -401,8 +404,7 @@ load s@(Session ref) how_much
evaluate pruned_hpt
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.
......@@ -480,7 +482,7 @@ load s@(Session ref) how_much
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)
......@@ -501,9 +503,8 @@ load s@(Session ref) how_much
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.")
......@@ -516,7 +517,7 @@ load s@(Session ref) how_much
-- 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
......@@ -814,7 +815,7 @@ upsweep hsc_env old_hpt stable_mods cleanup
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
......
......@@ -60,7 +60,6 @@ import Compat.Directory ( getAppUserDataDirectory )
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 )
......@@ -73,6 +72,7 @@ import Data.List ( isPrefixOf )
import FastString
import DATA_IOREF
import EXCEPTION ( throwDyn )
import ErrUtils ( debugTraceMsg, putMsg )
-- ---------------------------------------------------------------------------
-- The Package state
......@@ -225,9 +225,7 @@ readPackageConfigs dflags = 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
......@@ -566,6 +564,6 @@ dumpPackages :: DynFlags -> IO ()
-- Show package info on console, if verbosity is >= 3
dumpPackages dflags
= do let pkg_map = pkgIdMap (pkgState dflags)
hPutStrLn stderr $ showSDoc $
putMsg $ showSDoc $
vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map))
\end{code}
......@@ -87,7 +87,6 @@ import DATA_IOREF
import UNSAFE_IO ( unsafePerformIO )
import Monad ( when )
import Char ( isDigit )
import IO ( hPutStrLn, stderr ) -- ToDo: should use errorMsg
import List ( sort, intersperse )
-----------------------------------------------------------------------------
......
......@@ -47,7 +47,7 @@ module SysTools (
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 )
......@@ -61,7 +61,7 @@ import DATA_INT
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 )
......@@ -490,7 +490,7 @@ touch dflags purpose arg = 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.
......@@ -562,8 +562,6 @@ removeTmpFiles dflags fs
("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?)
......@@ -573,15 +571,14 @@ removeTmpFiles dflags fs
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 ->
when (verb >= 2) $
hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
debugTraceMsg dflags 2 ("Warning: deleting non-existent " ++ f)
)
......@@ -622,8 +619,8 @@ traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
-- 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
......@@ -633,8 +630,8 @@ traceCmd dflags phase_name cmd_line action
; 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}
......
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