import IO ( isPermissionError )
import System.Posix.Internals
+#if __GLASGOW_HASKELL__ >= 611
+import GHC.IO.Handle.FD (fdToHandle)
+#else
import GHC.Handle (fdToHandle)
+#endif
#if defined(GLOB)
import System.Process(runInteractiveCommand)
(cli,_,[]) | FlagVersion `elem` cli ->
bye ourCopyright
(cli,nonopts,[]) ->
- runit cli nonopts
+ case getVerbosity Normal cli of
+ Right v -> runit v cli nonopts
+ Left err -> die err
(_,_,errors) -> do
prog <- getProgramName
die (concat errors ++ usageInfo (usageHeader prog) flags)
| FlagNamesOnly
| FlagIgnoreCase
| FlagNoUserDb
+ | FlagVerbosity (Maybe String)
deriving Eq
flags :: [OptDescr Flag]
Option [] ["names-only"] (NoArg FlagNamesOnly)
"only print package names, not versions; can only be used with list --simple-output",
Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
- "ignore case for substring matching"
+ "ignore case for substring matching",
+ Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
+ "verbosity level (0-2, default 1)"
]
+data Verbosity = Silent | Normal | Verbose
+ deriving (Show, Eq, Ord)
+
+getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
+getVerbosity v [] = Right v
+getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
+getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
+getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
+getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
+getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
+getVerbosity v (_ : fs) = getVerbosity v fs
+
deprecFlags :: [OptDescr Flag]
deprecFlags = [
-- put deprecated flags here
data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
-runit :: [Flag] -> [String] -> IO ()
-runit cli nonopts = do
+runit :: Verbosity -> [Flag] -> [String] -> IO ()
+runit verbosity cli nonopts = do
installSignalHandlers -- catch ^C and clean up
prog <- getProgramName
let
glob filename >>= print
#endif
["register", filename] ->
- registerPackage filename cli auto_ghci_libs False force
+ registerPackage filename verbosity cli auto_ghci_libs False force
["update", filename] ->
- registerPackage filename cli auto_ghci_libs True force
+ registerPackage filename verbosity cli auto_ghci_libs True force
["unregister", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
- unregisterPackage pkgid cli force
+ unregisterPackage pkgid verbosity cli force
["expose", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
- exposePackage pkgid cli force
+ exposePackage pkgid verbosity cli force
["hide", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
- hidePackage pkgid cli force
+ hidePackage pkgid verbosity cli force
["list"] -> do
listPackages cli Nothing Nothing
["list", pkgid_str] ->
parse
+++
(do n <- parse
- string "-*"
+ _ <- string "-*"
return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
-- globVersion means "all versions"
| otherwise
= do str <- readFile filename
let packages = map convertPackageInfoIn $ read str
- Exception.evaluate packages
+ _ <- Exception.evaluate packages
`catchError` \e->
die ("error while parsing " ++ filename ++ ": " ++ show e)
return (filename,packages)
-- Registering
registerPackage :: FilePath
+ -> Verbosity
-> [Flag]
-> Bool -- auto_ghci_libs
-> Bool -- update
-> Force
-> IO ()
-registerPackage input my_flags auto_ghci_libs update force = do
+registerPackage input verbosity my_flags auto_ghci_libs update force = do
(db_stack, Just to_modify) <- getPkgDatabases True my_flags
let
db_to_operate_on = my_head "register" $
s <-
case input of
"-" -> do
- putStr "Reading package info from stdin ... "
+ when (verbosity >= Normal) $
+ putStr "Reading package info from stdin ... "
getContents
f -> do
- putStr ("Reading package info from " ++ show f ++ " ... ")
+ when (verbosity >= Normal) $
+ putStr ("Reading package info from " ++ show f ++ " ... ")
readFile f
expanded <- expandEnvVars s force
pkg <- parsePackageInfo expanded
- putStrLn "done."
+ when (verbosity >= Normal) $
+ putStrLn "done."
let unversioned_deps = filter (not . realVersion) (depends pkg)
unless (null unversioned_deps) $
validatePackageConfig pkg truncated_stack auto_ghci_libs update force
let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]
not_this p = package p /= package pkg
- writeNewConfig to_modify new_details
+ writeNewConfig verbosity to_modify new_details
parsePackageInfo
:: String
-- -----------------------------------------------------------------------------
-- Exposing, Hiding, Unregistering are all similar
-exposePackage :: PackageIdentifier -> [Flag] -> Force -> IO ()
+exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
exposePackage = modifyPackage (\p -> [p{exposed=True}])
-hidePackage :: PackageIdentifier -> [Flag] -> Force -> IO ()
+hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
hidePackage = modifyPackage (\p -> [p{exposed=False}])
-unregisterPackage :: PackageIdentifier -> [Flag] -> Force -> IO ()
+unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
unregisterPackage = modifyPackage (\_ -> [])
modifyPackage
:: (InstalledPackageInfo -> [InstalledPackageInfo])
-> PackageIdentifier
+ -> Verbosity
-> [Flag]
-> Force
-> IO ()
-modifyPackage fn pkgid my_flags force = do
+modifyPackage fn pkgid verbosity my_flags force = do
(db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags
((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
-- let ((db_name, pkgs) : rest_of_stack) = db_stack
" would break the following packages: "
++ unwords (map display newly_broken))
- writeNewConfig db_name new_config
+ writeNewConfig verbosity db_name new_config
-- -----------------------------------------------------------------------------
-- Listing packages
else do
when (not simple_output) $ do
reportError ("There are problems in package " ++ display (package p) ++ ":")
- reportValidateErrors es " " Nothing
+ _ <- reportValidateErrors es " " Nothing
return ()
return [p]
hiddenModules = map convert h }
where convert = fromJust . simpleParse
-writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
-writeNewConfig filename packages = do
- hPutStr stdout "Writing new package config file... "
+writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
+writeNewConfig verbosity filename packages = do
+ when (verbosity >= Normal) $
+ hPutStr stdout "Writing new package config file... "
createDirectoryIfMissing True $ takeDirectory filename
let shown = concat $ intersperse ",\n "
$ map (show . convertPackageInfoOut) packages
if isPermissionError e
then die (filename ++ ": you don't have permission to modify this file")
else ioError e
- hPutStrLn stdout "done."
+ when (verbosity >= Normal) $
+ hPutStrLn stdout "done."
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
getExecDir :: String -> IO (Maybe String)
getExecDir cmd =
getExecPath >>= maybe (return Nothing) removeCmdSuffix
- where unDosifyPath = subst '\\' '/'
- initN n = reverse . drop n . reverse
+ where initN n = reverse . drop n . reverse
removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
getExecPath :: IO (Maybe String)
(Exception.ErrorCall "interrupted")
--
#if !defined(mingw32_HOST_OS)
- installHandler sigQUIT (Catch interrupt) Nothing
- installHandler sigINT (Catch interrupt) Nothing
+ _ <- installHandler sigQUIT (Catch interrupt) Nothing
+ _ <- installHandler sigINT (Catch interrupt) Nothing
return ()
#elif __GLASGOW_HASKELL__ >= 603
-- GHC 6.3+ has support for console events on Windows
sig_handler Break = interrupt
sig_handler _ = return ()
- installHandler (Catch sig_handler)
+ _ <- installHandler (Catch sig_handler)
return ()
#else
return () -- nothing
oflags = rw_flags .|. o_EXCL
+#if __GLASGOW_HASKELL__ < 611
+ withFilePath = withCString
+#endif
+
findTempName x = do
- fd <- withCString filepath $ \ f ->
+ fd <- withFilePath filepath $ \ f ->
c_open f oflags 0o666
if fd < 0
then do