X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=19be560ea0a1c271f0e8c678ec801b0fadf11346;hb=be18544c3e59cab7f76bf3d07fe6aa27cf157b02;hp=9c6ba71485c21d36f720fdce9e725df3e005d74d;hpb=f23e95f72f1a8dcdf1532697a1116b0699a3f68a;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 9c6ba71..19be560 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -18,11 +18,17 @@ module Main (main) where import Version ( version, targetOS, targetARCH ) import Distribution.InstalledPackageInfo import Distribution.Compat.ReadP -import Distribution.ParseUtils ( showError ) +import Distribution.ParseUtils import Distribution.Package import Distribution.Version -import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) -import Compat.RawSystem ( rawSystem ) + +#ifdef USING_COMPAT +import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) +import Compat.RawSystem ( rawSystem ) +#else +import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) +import System.Cmd ( rawSystem ) +#endif import Prelude @@ -135,7 +141,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 = @@ -171,10 +177,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" ++ @@ -236,6 +247,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) @@ -422,7 +435,9 @@ parsePackageInfo parsePackageInfo str defines = case parseInstalledPackageInfo str of ParseOk _warns ok -> return ok - ParseFailed err -> die (showError err) + ParseFailed err -> case locatedErrorMsg err of + (Nothing, s) -> die s + (Just l, s) -> die (show l ++ ": " ++ s) -- ----------------------------------------------------------------------------- -- Exposing, Hiding, Unregistering are all similar @@ -476,21 +491,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" @@ -547,7 +564,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: @@ -568,6 +612,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