diff options
| -rw-r--r-- | utils/ghc-pkg/Main.hs | 70 |
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)") |