#else
import System.IO (try)
#endif
-import Data.List ( isPrefixOf, isSuffixOf, intersperse, groupBy, sortBy )
+import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy )
#ifdef mingw32_HOST_OS
import Foreign
#endif
#endif
+import IO ( isPermissionError, isDoesNotExistError )
+
-- -----------------------------------------------------------------------------
-- Entry point
| FlagConfig FilePath
| FlagGlobalConfig FilePath
| FlagForce
+ | FlagForceFiles
| FlagAutoGHCiLibs
| FlagDefinedName String String
| FlagSimpleOutput
"location of the global package config",
Option [] ["force"] (NoArg FlagForce)
"ignore missing dependencies, directories, and libraries",
+ Option [] ["force-files"] (NoArg FlagForceFiles)
+ "ignore missing directories and libraries only",
Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
"automatically build libs for GHCi (with register)",
Option ['?'] ["help"] (NoArg FlagHelp)
Option ['V'] ["version"] (NoArg FlagVersion)
"output version information and exit",
Option [] ["simple-output"] (NoArg FlagSimpleOutput)
- "print output in easy-to-parse format when running command 'list'"
+ "print output in easy-to-parse format for some commands"
]
where
toDefined str =
" List registered packages in the global database, and also the\n" ++
" user database if --user is given. If a package name is given\n" ++
" all the registered versions will be listed in ascending order.\n" ++
+ " Accepts the --simple-output flag.\n" ++
"\n" ++
" $p latest pkg\n" ++
" Prints the highest registered version of a package.\n" ++
"\n" ++
+ " $p check\n" ++
+ " Check the consistency of package depenencies and list broken packages.\n" ++
+ " Accepts the --simple-output flag.\n" ++
+ "\n" ++
" $p describe {pkg-id}\n" ++
" Give the registered description for the specified package. The\n" ++
" description is returned in precisely the syntax required by $p\n" ++
-- -----------------------------------------------------------------------------
-- Do the business
+data Force = ForceAll | ForceFiles | NoForce
+
runit :: [Flag] -> [String] -> IO ()
runit cli nonopts = do
prog <- getProgramName
let
- force = FlagForce `elem` cli
+ force
+ | FlagForce `elem` cli = ForceAll
+ | FlagForceFiles `elem` cli = ForceFiles
+ | otherwise = NoForce
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
defines = [ (nm,val) | FlagDefinedName nm val <- cli ]
--
["field", pkgid_str, field] -> do
pkgid <- readGlobPkgId pkgid_str
describeField cli pkgid field
+ ["check"] -> do
+ checkConsistency cli
[] -> do
die ("missing command\n" ++
usageInfo (usageHeader prog) flags)
-> [Flag]
-> Bool -- auto_ghci_libs
-> Bool -- update
- -> Bool -- force
+ -> Force
-> IO ()
registerPackage input defines flags auto_ghci_libs update force = do
db_stack <- getPkgDatabases True flags
db_to_operate_on = my_head "db" db_stack
db_filename = fst db_to_operate_on
--
- checkConfigAccess db_filename
s <-
case input of
expanded <- expandEnvVars s defines force
- pkg0 <- parsePackageInfo expanded defines force
+ pkg0 <- parsePackageInfo expanded defines
putStrLn "done."
let pkg = resolveDeps db_stack pkg0
- overlaps <- validatePackageConfig pkg db_stack auto_ghci_libs update force
- new_details <- updatePackageDB db_stack overlaps (snd db_to_operate_on) pkg
- savePackageConfig db_filename
- maybeRestoreOldConfig db_filename $
+ validatePackageConfig pkg db_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
+ savingOldConfig db_filename $
writeNewConfig db_filename new_details
parsePackageInfo
:: String
-> [(String,String)]
- -> Bool
-> IO InstalledPackageInfo
-parsePackageInfo str defines force =
+parsePackageInfo str defines =
case parseInstalledPackageInfo str of
ParseOk _warns ok -> return ok
ParseFailed err -> die (showError err)
modifyPackage fn pkgid flags = do
db_stack <- getPkgDatabases True{-modify-} flags
let ((db_name, pkgs) : _) = db_stack
- checkConfigAccess db_name
ps <- findPackages [(db_name,pkgs)] pkgid
let pids = map package ps
- savePackageConfig db_name
let new_config = concat (map modify pkgs)
modify pkg
| package pkg `elem` pids = fn pkg
| otherwise = [pkg]
- maybeRestoreOldConfig db_name $
+ savingOldConfig db_name $
writeNewConfig db_name new_config
-- -----------------------------------------------------------------------------
EQ -> pkgVersion p1 `compare` pkgVersion p2
where (p1,p2) = (package pkg1, package pkg2)
- show_func = if simple_output then show_easy else mapM_ show_regular
+ pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack
+ show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
show_func (reverse db_stack_sorted)
- where show_regular (db_name,pkg_confs) =
+ where show_normal pkg_map (db_name,pkg_confs) =
hPutStrLn stdout (render $
- text (db_name ++ ":") $$ nest 4 packages
+ text db_name <> colon $$ nest 4 packages
)
where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
pp_pkg p
+ | isBrokenPackage p pkg_map = braces doc
| exposed p = doc
| otherwise = parens doc
where doc = text (showPackageId (package p))
- show_easy db_stack = do
+ show_simple db_stack = do
let pkgs = map showPackageId $ sortBy compPkgIdVer $
map package (concatMap snd db_stack)
when (null pkgs) $ die "no matches"
strList :: [String] -> String
strList = show
+
-- -----------------------------------------------------------------------------
--- Manipulating package.conf files
+-- Check: Check consistency of installed packages
-checkConfigAccess :: FilePath -> IO ()
-checkConfigAccess filename = do
- access <- getPermissions filename
- when (not (writable access))
- (die (filename ++ ": you don't have permission to modify this file"))
-
-maybeRestoreOldConfig :: FilePath -> IO () -> IO ()
-maybeRestoreOldConfig filename io
- = io `catch` \e -> do
- hPutStrLn stderr (show e)
- hPutStr stdout ("\nWARNING: an error was encountered while the new \n"++
- "configuration was being written. Attempting to \n"++
- "restore the old configuration... ")
- renameFile (filename ++ ".old") filename
- hPutStrLn stdout "done."
- ioError e
+checkConsistency :: [Flag] -> IO ()
+checkConsistency flags = do
+ db_stack <- getPkgDatabases False flags
+ let pkgs = map (\p -> (package p, p)) $ concatMap snd db_stack
+ broken_pkgs = do
+ (pid, p) <- pkgs
+ let broken_deps = missingPackageDeps p pkgs
+ guard (not . null $ broken_deps)
+ return (pid, broken_deps)
+ mapM_ (putStrLn . render . show_func) broken_pkgs
+ where
+ show_func | FlagSimpleOutput `elem` flags = show_simple
+ | otherwise = show_normal
+ show_simple (pid,deps) =
+ text (showPackageId pid) <> colon
+ <+> fsep (punctuate comma (map (text . showPackageId) deps))
+ show_normal (pid,deps) =
+ text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:"
+ $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps)))
+
+missingPackageDeps :: InstalledPackageInfo
+ -> [(PackageIdentifier, InstalledPackageInfo)]
+ -> [PackageIdentifier]
+missingPackageDeps pkg pkg_map =
+ [ d | d <- depends pkg, isNothing (lookup d pkg_map)] ++
+ [ d | d <- depends pkg, Just p <- return (lookup d pkg_map), isBrokenPackage p pkg_map]
+
+isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool
+isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg pkg_map
+
+
+-- -----------------------------------------------------------------------------
+-- Manipulating package.conf files
writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
writeNewConfig filename packages = do
hPutStr stdout "Writing new package config file... "
- h <- openFile filename WriteMode
+ createDirectoryIfMissing True $ getFilenameDir filename
+ h <- openFile filename WriteMode `catch` \e ->
+ if isPermissionError e
+ then die (filename ++ ": you don't have permission to modify this file")
+ else ioError e
hPutStrLn h (show packages)
hClose h
hPutStrLn stdout "done."
-savePackageConfig :: FilePath -> IO ()
-savePackageConfig filename = do
+savingOldConfig :: FilePath -> IO () -> IO ()
+savingOldConfig filename io = Exception.block $ do
hPutStr stdout "Saving old package config file... "
-- mv rather than cp because we've already done an hGetContents
-- on this file so we won't be able to open it for writing
-- unless we move the old one out of the way...
let oldFile = filename ++ ".old"
- doesExist <- doesFileExist oldFile `catch` (\ _ -> return False)
- when doesExist (removeFile oldFile `catch` (const $ return ()))
- catch (renameFile filename oldFile)
- (\ err -> do
- hPutStrLn stderr (unwords [ "Unable to rename "
- , show filename
- , " to "
- , show oldFile
- ])
- ioError err)
+ restore_on_error <- catch (renameFile filename oldFile >> return True) $
+ \err -> do
+ unless (isDoesNotExistError err) $ do
+ hPutStrLn stderr (unwords ["Unable to rename", show filename,
+ "to", show oldFile])
+ ioError err
+ return False
hPutStrLn stdout "done."
+ io `catch` \e -> do
+ hPutStrLn stderr (show e)
+ hPutStr stdout ("\nWARNING: an error was encountered while writing"
+ ++ "the new configuration.\n")
+ when restore_on_error $ do
+ hPutStr stdout "Attempting to restore the old configuration..."
+ do renameFile oldFile filename
+ hPutStrLn stdout "done."
+ `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err)
+ ioError e
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
-> PackageDBStack
-> Bool -- auto-ghc-libs
-> Bool -- update
- -> Bool -- force
- -> IO [PackageIdentifier]
+ -> Force
+ -> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
checkPackageId pkg
- overlaps <- checkDuplicates db_stack pkg update force
+ checkDuplicates db_stack pkg update
mapM_ (checkDep db_stack force) (depends pkg)
mapM_ (checkDir force) (importDirs pkg)
mapM_ (checkDir force) (libraryDirs pkg)
mapM_ (checkDir force) (includeDirs pkg)
mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg)
- return overlaps
-- ToDo: check these somehow?
-- extra_libraries :: [String],
-- c_includes :: [String],
[] -> dep_pkgid -- No installed package; use
-- the version-less one
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool
- -> IO [PackageIdentifier]
-checkDuplicates db_stack pkg update force = do
+checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO ()
+checkDuplicates db_stack pkg update = do
let
pkgid = package pkg
(_top_db_name, pkgs) : _ = db_stack
when (not update && (pkgid `elem` map package pkgs)) $
die ("package " ++ showPackageId pkgid ++ " is already installed")
- --
- -- Check whether any of the dependencies of the current package
- -- conflict with each other.
- --
- let
- all_pkgs = concat (map snd db_stack)
-
- allModules p = exposedModules p ++ hiddenModules p
-
- our_dependencies = closePackageDeps all_pkgs [pkg]
- all_dep_modules = concat (map (\p -> zip (allModules p) (repeat p))
- our_dependencies)
-
- overlaps = [ (m, map snd group)
- | group@((m,_):_) <- groupBy eqfst (sortBy cmpfst all_dep_modules),
- length group > 1 ]
- where eqfst (a,_) (b,_) = a == b
- cmpfst (a,_) (b,_) = a `compare` b
-
- when (not (null overlaps)) $
- diePrettyOrForce force $ vcat [
- text "package" <+> text (showPackageId (package pkg)) <+>
- text "has conflicting dependencies:",
- let complain_about (mod,ps) =
- text mod <+> text "is in the following packages:" <+>
- sep (map (text.showPackageId.package) ps)
- in
- nest 3 (vcat (map complain_about overlaps))
- ]
-
- --
- -- Now check whether exposing this package will result in conflicts, and
- -- Figure out which packages we need to hide to resolve the conflicts.
- --
- let
- closure_exposed_pkgs = closePackageDeps pkgs (filter exposed pkgs)
-
- new_dep_modules = concat $ map allModules $
- filter (\p -> package p `notElem`
- map package closure_exposed_pkgs) $
- our_dependencies
-
- pkgs_with_overlapping_modules =
- [ (p, overlapping_mods)
- | p <- closure_exposed_pkgs,
- let overlapping_mods =
- filter (`elem` new_dep_modules) (allModules p),
- (_:_) <- [overlapping_mods] --trick to get the non-empty ones
- ]
-
- to_hide = map package
- $ filter exposed
- $ closePackageDepsUpward pkgs
- $ map fst pkgs_with_overlapping_modules
-
- when (not update && exposed pkg && not (null pkgs_with_overlapping_modules)) $ do
- diePretty $ vcat [
- text "package" <+> text (showPackageId (package pkg)) <+>
- text "conflicts with the following packages, which are",
- text "either exposed or a dependency (direct or indirect) of an exposed package:",
- let complain_about (p, mods)
- = text (showPackageId (package p)) <+> text "contains modules" <+>
- sep (punctuate comma (map text mods)) in
- nest 3 (vcat (map complain_about pkgs_with_overlapping_modules)),
- text "Using 'update' instead of 'register' will cause the following packages",
- text "to be hidden, which will eliminate the conflict:",
- nest 3 (sep (map (text.showPackageId) to_hide))
- ]
-
- when (not (null to_hide)) $ do
- hPutStrLn stderr $ render $
- sep [text "Warning: hiding the following packages to avoid conflict: ",
- nest 2 (sep (map (text.showPackageId) to_hide))]
-
- return to_hide
-
-
-closure :: (a->[a]->Bool) -> (a -> [a]) -> [a] -> [a] -> [a]
-closure pred more [] res = res
-closure pred more (p:ps) res
- | p `pred` res = closure pred more ps res
- | otherwise = closure pred more (more p ++ ps) (p:res)
-
-closePackageDeps :: [InstalledPackageInfo] -> [InstalledPackageInfo]
- -> [InstalledPackageInfo]
-closePackageDeps db start
- = closure (\p ps -> package p `elem` map package ps) getDepends start []
- where
- getDepends p = [ pkg | dep <- depends p, pkg <- lookupPkg dep ]
- lookupPkg p = [ q | q <- db, p == package q ]
-
-closePackageDepsUpward :: [InstalledPackageInfo] -> [InstalledPackageInfo]
- -> [InstalledPackageInfo]
-closePackageDepsUpward db start
- = closure (\p ps -> package p `elem` map package ps) getUpwardDepends start []
- where
- getUpwardDepends p = [ pkg | pkg <- db, package p `elem` depends pkg ]
-checkDir :: Bool -> String -> IO ()
+checkDir :: Force -> String -> IO ()
checkDir force d
| "$topdir" `isPrefixOf` d = return ()
-- can't check this, because we don't know what $topdir is
| otherwise = do
there <- doesDirectoryExist d
when (not there)
- (dieOrForce force (d ++ " doesn't exist or isn't a directory"))
+ (dieOrForceFile force (d ++ " doesn't exist or isn't a directory"))
-checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO ()
+checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
checkDep db_stack force pkgid
- | not real_version || pkgid `elem` pkgids = return ()
- | otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid
+ | pkgid `elem` pkgids || (not real_version && name_exists) = return ()
+ | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid
++ " doesn't exist")
where
-- for backwards compat, we treat 0.0 as a special version,
-- and don't check that it actually exists.
real_version = realVersion pkgid
+ name_exists = any (\p -> pkgName (package p) == name) all_pkgs
+ name = pkgName pkgid
+
all_pkgs = concat (map snd db_stack)
pkgids = map package all_pkgs
realVersion :: PackageIdentifier -> Bool
realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
-checkHSLib :: [String] -> Bool -> Bool -> String -> IO ()
+checkHSLib :: [String] -> Bool -> Force -> String -> IO ()
checkHSLib dirs auto_ghci_libs force lib = do
let batch_lib_file = "lib" ++ lib ++ ".a"
bs <- mapM (doesLibExistIn batch_lib_file) dirs
case [ dir | (exists,dir) <- zip bs dirs, exists ] of
- [] -> dieOrForce force ("cannot find " ++ batch_lib_file ++
+ [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++
" on library path")
(dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
hPutStrLn stderr (" done.")
-- -----------------------------------------------------------------------------
--- Updating the DB with the new package.
-
-updatePackageDB
- :: PackageDBStack -- the full stack
- -> [PackageIdentifier] -- packages to hide
- -> [InstalledPackageInfo] -- packages in *this* DB
- -> InstalledPackageInfo -- the new package
- -> IO [InstalledPackageInfo]
-updatePackageDB db_stack to_hide pkgs new_pkg = do
- let
- pkgid = package new_pkg
-
- pkgs' = [ maybe_hide p | p <- pkgs, package p /= pkgid ]
-
- -- When update is on, and we're exposing the new package,
- -- we hide any packages which conflict (see checkDuplicates)
- -- in the current DB.
- maybe_hide p
- | exposed new_pkg && package p `elem` to_hide = p{ exposed = False }
- | otherwise = p
- --
- return (pkgs'++ [new_pkg])
-
--- -----------------------------------------------------------------------------
-- Searching for modules
#if not_yet
where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"])
- force = OF_Force `elem` clis
+ force = if OF_Force `elem` clis then ForceAll else NoForce
defines = [ (nm,val) | OF_DefinedName nm val <- clis ]
-- ---------------------------------------------------------------------------
-- expanding environment variables in the package configuration
-expandEnvVars :: String -> [(String, String)] -> Bool -> IO String
+expandEnvVars :: String -> [(String, String)] -> Force -> IO String
expandEnvVars str defines force = go str ""
where
go "" acc = return $! reverse acc
Just x | not (null x) -> return x
_ ->
catch (System.getEnv nm)
- (\ _ -> do dieOrForce force ("Unable to expand variable " ++
+ (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
show nm)
return "")
hPutStrLn stderr (prog ++ ": " ++ s)
exitWith (ExitFailure 1)
-dieOrForce :: Bool -> String -> IO ()
-dieOrForce force s
- | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
- | otherwise = die (s ++ " (use --force to override)")
+dieOrForceAll :: Force -> String -> IO ()
+dieOrForceAll ForceAll s = ignoreError s
+dieOrForceAll _other s = dieForcible s
-diePretty :: Doc -> IO ()
-diePretty doc = do
- hFlush stdout
- prog <- getProgramName
- hPutStrLn stderr $ render $ (text prog <> colon $$ nest 2 doc)
- exitWith (ExitFailure 1)
+dieOrForceFile :: Force -> String -> IO ()
+dieOrForceFile ForceAll s = ignoreError s
+dieOrForceFile ForceFiles s = ignoreError s
+dieOrForceFile _other s = dieForcible s
-diePrettyOrForce :: Bool -> Doc -> IO ()
-diePrettyOrForce force doc
- | force = do hFlush stdout; hPutStrLn stderr (render (doc $$ text "(ignoring)"))
- | otherwise = diePretty (doc $$ text "(use --force to override)")
+ignoreError :: String -> IO ()
+ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
+
+dieForcible :: String -> IO ()
+dieForcible s = die (s ++ " (use --force to override)")
-----------------------------------------
-- Cut and pasted from ghc/compiler/SysTools
pathSeparator = '/'
#endif
+getFilenameDir :: FilePath -> FilePath
+getFilenameDir fn = case break isPathSeparator (reverse fn) of
+ (xs, "") -> "."
+ (_, sep:ys) -> reverse ys
+
-- | The function splits the given string to substrings
-- using the 'searchPathSeparator'.
parseSearchPath :: String -> [FilePath]
projects / ghc-hetmet.git / blobdiff