ghc-pkg: make sure info messages go to stdout and errors to stderr (#3818)

1 files changed, 40 insertions, 30 deletions

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 14664a8ada..e29301d933 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -611,7 +611,7 @@ readParseDatabase verbosity mb_user_conf use_cache path
                 Right tcache
                   | tcache >= tdir -> do
                      when (verbosity > Normal) $
-                        putStrLn ("using cache: " ++ cache)
+                        infoLn ("using cache: " ++ cache)
                      pkgs <- myReadBinPackageDB cache
                      let pkgs' = map convertPackageInfoIn pkgs
                      mkPackageDB pkgs'
@@ -649,7 +649,7 @@ myReadBinPackageDB filepath = do
 
 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
 parseMultiPackageConf verbosity file = do
-  when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
+  when (verbosity > Normal) $ infoLn ("reading package database: " ++ file)
   str <- readUTF8File file
   let pkgs = map convertPackageInfoIn $ read str
   Exception.evaluate pkgs
@@ -658,7 +658,7 @@ parseMultiPackageConf verbosity file = do
   
 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
 parseSingletonPackageConf verbosity file = do
-  when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
+  when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
   readUTF8File file >>= fmap fst . parsePackageInfo
 
 cachefilename :: FilePath
@@ -767,13 +767,13 @@ registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update f
     case input of
       "-" -> do
         when (verbosity >= Normal) $
-            putStr "Reading package info from stdin ... "
+            info "Reading package info from stdin ... "
         -- fix the encoding to UTF-8, since this is an interchange format
         hSetEncoding stdin utf8
         getContents
       f   -> do
         when (verbosity >= Normal) $
-            putStr ("Reading package info from " ++ show f ++ " ... ")
+            info ("Reading package info from " ++ show f ++ " ... ")
         readUTF8File f
 
   expanded <- if expand_env_vars then expandEnvVars s force
@@ -781,7 +781,7 @@ registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update f
 
   (pkg, ws) <- parsePackageInfo expanded
   when (verbosity >= Normal) $
-      putStrLn "done."
+      infoLn "done."
 
   -- report any warnings from the parse phase
   _ <- reportValidateErrors [] ws
@@ -795,7 +795,7 @@ registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update f
   let truncated_stack = dropWhile ((/= to_modify).location) db_stack
   -- truncate the stack for validation, because we don't allow
   -- packages lower in the stack to refer to those higher up.
-  validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force
+  validatePackageConfig pkg_expanded verbosity truncated_stack auto_ghci_libs update force
   let 
      removes = [ RemovePackage p
                | p <- packages db_to_operate_on,
@@ -850,11 +850,11 @@ changeDBDir verbosity cmds db = do
  where
   do_cmd (RemovePackage p) = do
     let file = location db </> display (installedPackageId p) <.> "conf"
-    when (verbosity > Normal) $ putStrLn ("removing " ++ file)
+    when (verbosity > Normal) $ infoLn ("removing " ++ file)
     removeFileSafe file
   do_cmd (AddPackage p) = do
     let file = location db </> display (installedPackageId p) <.> "conf"
-    when (verbosity > Normal) $ putStrLn ("writing " ++ file)
+    when (verbosity > Normal) $ infoLn ("writing " ++ file)
     writeFileUtf8Atomic file (showInstalledPackageInfo p)
   do_cmd (ModifyPackage p) = 
     do_cmd (AddPackage p)
@@ -863,7 +863,7 @@ updateDBCache :: Verbosity -> PackageDB -> IO ()
 updateDBCache verbosity db = do
   let filename = location db </> cachefilename
   when (verbosity > Normal) $
-      putStrLn ("writing cache " ++ filename)
+      infoLn ("writing cache " ++ filename)
   writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
     `catchIO` \e ->
       if isPermissionError e
@@ -1144,7 +1144,7 @@ describeField verbosity my_flags pkgarg fields expand_pkgroot = do
             Nothing -> die ("unknown field: " ++ f)
             Just fn -> do fns <- toFields fs
                           return (fn:fns)
-        selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
+        selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns
 
 toField :: String -> Maybe (InstalledPackageInfo -> String)
 -- backwards compatibility:
@@ -1181,7 +1181,7 @@ checkConsistency verbosity my_flags = do
   let pkgs = allPackagesInStack db_stack
 
       checkPackage p = do
-         (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
+         (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack False True
          if null es
             then do when (not simple_output) $ do
                       _ <- reportValidateErrors [] ws "" Nothing
@@ -1259,7 +1259,7 @@ convertPackageInfoIn
 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
 writeNewConfig verbosity filename ipis = do
   when (verbosity >= Normal) $
-      hPutStr stdout "Writing new package config file... "
+      info "Writing new package config file... "
   createDirectoryIfMissing True $ takeDirectory filename
   let shown = concat $ intersperse ",\n "
                      $ map (show . convertPackageInfoOut) ipis
@@ -1270,7 +1270,7 @@ writeNewConfig verbosity filename ipis = do
       then die (filename ++ ": you don't have permission to modify this file")
       else ioError e
   when (verbosity >= Normal) $
-      hPutStrLn stdout "done."
+      infoLn "done."
 
 -----------------------------------------------------------------------------
 -- Sanity-check a new package config, and automatically build GHCi libs
@@ -1321,22 +1321,24 @@ reportValidateErrors es ws prefix mb_force = do
              err = prefix ++ s
 
 validatePackageConfig :: InstalledPackageInfo
+                      -> Verbosity
                       -> PackageDBStack
                       -> Bool   -- auto-ghc-libs
                       -> Bool   -- update, or check
                       -> Force
                       -> IO ()
-validatePackageConfig pkg db_stack auto_ghci_libs update force = do
-  (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
+validatePackageConfig pkg verbosity db_stack auto_ghci_libs update force = do
+  (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack auto_ghci_libs update
   ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
   when (not ok) $ exitWith (ExitFailure 1)
 
 checkPackageConfig :: InstalledPackageInfo
+                      -> Verbosity
                       -> PackageDBStack
                       -> Bool   -- auto-ghc-libs
                       -> Bool   -- update, or check
                       -> Validate ()
-checkPackageConfig pkg db_stack auto_ghci_libs update = do
+checkPackageConfig pkg verbosity db_stack auto_ghci_libs update = do
   checkInstalledPackageId pkg db_stack update
   checkPackageId pkg
   checkDuplicates db_stack pkg update
@@ -1349,7 +1351,7 @@ checkPackageConfig pkg db_stack auto_ghci_libs update = do
   mapM_ (checkFile   True "haddock-interfaces") (haddockInterfaces pkg)
   mapM_ (checkDirURL True "haddock-html")       (haddockHTMLs pkg)
   checkModules pkg
-  mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
+  mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
   -- ToDo: check these somehow?
   --    extra_libraries :: [String],
   --    c_includes      :: [String],
@@ -1449,14 +1451,14 @@ checkDuplicateDepends deps
   where
        dups = [ p | (p:_:_) <- group (sort deps) ]
 
-checkHSLib :: [String] -> Bool -> String -> Validate ()
-checkHSLib dirs auto_ghci_libs lib = do
+checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate ()
+checkHSLib verbosity dirs auto_ghci_libs lib = do
   let batch_lib_file = "lib" ++ lib ++ ".a"
   m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
   case m of
     Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
                                    " on library path")
-    Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs
+    Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs
 
 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
 doesFileExistOnPath file path = go path
@@ -1479,9 +1481,9 @@ checkModules pkg = do
       when (isNothing m) $
          verror ForceFiles ("file " ++ file ++ " is missing")
 
-checkGHCiLib :: String -> String -> String -> Bool -> IO ()
-checkGHCiLib batch_lib_dir batch_lib_file lib auto_build
-  | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
+checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO ()
+checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build
+  | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file
   | otherwise  = return ()
  where
     ghci_lib_file = lib <.> "o"
@@ -1489,11 +1491,12 @@ checkGHCiLib batch_lib_dir batch_lib_file lib auto_build
 -- automatically build the GHCi version of a batch lib,
 -- using ld --whole-archive.
 
-autoBuildGHCiLib :: String -> String -> String -> IO ()
-autoBuildGHCiLib dir batch_file ghci_file = do
+autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO ()
+autoBuildGHCiLib verbosity dir batch_file ghci_file = do
   let ghci_lib_file  = dir ++ '/':ghci_file
       batch_lib_file = dir ++ '/':batch_file
-  hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
+  when (verbosity >= Normal) $
+    info ("building GHCi library " ++ ghci_lib_file ++ "...")
 #if defined(darwin_HOST_OS)
   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
 #elif defined(mingw32_HOST_OS)
@@ -1503,7 +1506,8 @@ autoBuildGHCiLib dir batch_file ghci_file = do
   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
 #endif
   when (r /= ExitSuccess) $ exitWith r
-  hPutStrLn stderr (" done.")
+  when (verbosity >= Normal) $
+    infoLn (" done.")
 
 -- -----------------------------------------------------------------------------
 -- Searching for modules
@@ -1582,9 +1586,8 @@ die = dieWith 1
 
 dieWith :: Int -> String -> IO a
 dieWith ec s = do
-  hFlush stdout
   prog <- getProgramName
-  hPutStrLn stderr (prog ++ ": " ++ s)
+  reportError (prog ++ ": " ++ s)
   exitWith (ExitFailure ec)
 
 dieOrForceAll :: Force -> String -> IO ()
@@ -1594,6 +1597,13 @@ dieOrForceAll _other s   = dieForcible s
 warn :: String -> IO ()
 warn = reportError
 
+-- send info messages to stdout
+infoLn :: String -> IO ()
+infoLn = putStrLn
+
+info :: String -> IO ()
+info = putStr
+
 ignoreError :: String -> IO ()
 ignoreError s = reportError (s ++ " (ignoring)")