| 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
expanded <- expandEnvVars s defines force
- pkg0 <- parsePackageInfo expanded defines force
+ pkg0 <- parsePackageInfo expanded defines
putStrLn "done."
let pkg = resolveDeps db_stack pkg0
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)
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"
Nothing -> die ("unknown field: " ++ field)
Just fn -> do
ps <- findPackages db_stack pkgid
- mapM_ (putStrLn.fn) ps
+ let top_dir = getFilenameDir (fst (last db_stack))
+ mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps)
+
+mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
+-- Replace the string "$topdir" at the beginning of a path
+-- with the current topdir (obtained from the -B option).
+mungePackagePaths top_dir ps = map munge_pkg ps
+ where
+ munge_pkg p = p{ importDirs = munge_paths (importDirs p),
+ includeDirs = munge_paths (includeDirs p),
+ libraryDirs = munge_paths (libraryDirs p),
+ frameworkDirs = munge_paths (frameworkDirs p),
+ haddockInterfaces = munge_paths (haddockInterfaces p),
+ haddockHTMLs = munge_paths (haddockHTMLs p)
+ }
+
+ munge_paths = map munge_path
+
+ munge_path p
+ | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
+ | otherwise = p
+
+maybePrefixMatch :: String -> String -> Maybe String
+maybePrefixMatch [] rest = Just rest
+maybePrefixMatch (_:_) [] = Nothing
+maybePrefixMatch (p:pat) (r:rest)
+ | p == r = maybePrefixMatch pat rest
+ | otherwise = Nothing
toField :: String -> Maybe (InstalledPackageInfo -> String)
-- backwards compatibility:
strList :: [String] -> String
strList = show
+
+-- -----------------------------------------------------------------------------
+-- Check: Check consistency of installed packages
+
+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
-> PackageDBStack
-> Bool -- auto-ghc-libs
-> Bool -- update
- -> Bool -- force
+ -> Force
-> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
checkPackageId pkg
- 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)
[] -> dep_pkgid -- No installed package; use
-- the version-less one
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool
- -> IO ()
-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
-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
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
+
+dieOrForceFile :: Force -> String -> IO ()
+dieOrForceFile ForceAll s = ignoreError s
+dieOrForceFile ForceFiles s = ignoreError s
+dieOrForceFile _other s = dieForcible s
+
+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
projects / ghc-hetmet.git / blobdiff