X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=896fd7c4747d9a73772e3be2cc50797e7d3ff6d8;hb=cc318c842a9d6bbc90a7ef3f24450b4cbac0e2c8;hp=829034578a73cc9478192f0a239137ba2b2f9def;hpb=349e0e18a3de8098a8c96c05b52c48100d728bcc;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 8290345..896fd7c 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -106,6 +106,7 @@ data Flag | FlagConfig FilePath | FlagGlobalConfig FilePath | FlagForce + | FlagForceFiles | FlagAutoGHCiLibs | FlagDefinedName String String | FlagSimpleOutput @@ -123,6 +124,8 @@ flags = [ "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) @@ -132,7 +135,7 @@ flags = [ 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 = @@ -168,10 +171,15 @@ usageHeader prog = substProg prog $ " 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" ++ @@ -191,11 +199,16 @@ substProg prog (c:xs) = c : substProg prog xs -- ----------------------------------------------------------------------------- -- 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 ] -- @@ -228,6 +241,8 @@ runit cli nonopts = do ["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) @@ -377,7 +392,7 @@ registerPackage :: FilePath -> [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 @@ -397,7 +412,7 @@ registerPackage input defines flags auto_ghci_libs update force = do expanded <- expandEnvVars s defines force - pkg0 <- parsePackageInfo expanded defines force + pkg0 <- parsePackageInfo expanded defines putStrLn "done." let pkg = resolveDeps db_stack pkg0 @@ -410,9 +425,8 @@ registerPackage input defines flags auto_ghci_libs update force = do 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) @@ -469,21 +483,23 @@ listPackages flags mPackageName = do 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" @@ -540,7 +556,34 @@ describeField flags pkgid field = do 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: @@ -561,6 +604,41 @@ toField s = showInstalledPackageInfoField s 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 @@ -610,11 +688,11 @@ validatePackageConfig :: InstalledPackageInfo -> 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) @@ -662,9 +740,8 @@ resolveDeps db_stack p = updateDeps p [] -> 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 @@ -676,37 +753,40 @@ checkDuplicates db_stack pkg update force = do -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 @@ -859,7 +939,7 @@ oldRunit clis = do 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 ] @@ -889,7 +969,7 @@ my_head s (x:xs) = x -- --------------------------------------------------------------------------- -- 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 @@ -906,7 +986,7 @@ expandEnvVars str defines force = go str "" 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 "") @@ -928,10 +1008,20 @@ die s = do 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