X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=7f727d7966496db668b09bbaf2a8f62cdfe27098;hp=13b9e2ffdfe728821602b48f70fe4a36ed9fd946;hb=eed437cdefb952e6c70e58012b23d436e74710af;hpb=9e3757d1db9c14f45fd59376c2cd594893bad5b3 diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 13b9e2f..7f727d7 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -16,10 +16,11 @@ module Main (main) where import Version ( version, targetOS, targetARCH ) -import Distribution.InstalledPackageInfo +import Distribution.InstalledPackageInfo hiding (depends) import Distribution.Compat.ReadP import Distribution.ParseUtils import Distribution.Package +import Distribution.Text import Distribution.Version import System.FilePath import System.Cmd ( rawSystem ) @@ -36,7 +37,7 @@ import Data.Maybe import Data.Char ( isSpace, toLower ) import Control.Monad -import System.Directory ( doesDirectoryExist, getDirectoryContents, +import System.Directory ( doesDirectoryExist, getDirectoryContents, doesFileExist, renameFile, removeFile ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs, getProgName, getEnv ) @@ -188,6 +189,11 @@ usageHeader prog = substProg prog $ " Extract the specified field of the package description for the\n" ++ " specified package. Accepts comma-separated multiple fields.\n" ++ "\n" ++ + " $p dump\n" ++ + " Dump the registered description for every package. This is like\n" ++ + " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++ + " by tools that parse the results, rather than humans.\n" ++ + "\n" ++ " Substring matching is supported for {module} in find-module and\n" ++ " for {pkg} in list, describe, and field, where a '*' indicates\n" ++ " open substring ends (prefix*, *suffix, *infix*).\n" ++ @@ -303,6 +309,10 @@ runit cli nonopts = do (splitFields fields) ["check"] -> do checkConsistency cli + + ["dump"] -> do + dumpPackages cli + [] -> do die ("missing command\n" ++ usageInfo (usageHeader prog) flags) @@ -321,9 +331,10 @@ readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier" parseGlobPackageId :: ReadP r PackageIdentifier parseGlobPackageId = - parsePackageId + parse +++ - (do n <- parsePackageName; string "-*" + (do n <- parse + string "-*" return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) -- globVersion means "all versions" @@ -349,15 +360,18 @@ type PackageDBStack = [(PackageDBName,PackageDB)] -- A stack of package databases. Convention: head is the topmost -- in the stack. Earlier entries override later one. +allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] +allPackagesInStack = concatMap snd + getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack -getPkgDatabases modify flags = do +getPkgDatabases modify my_flags = do -- first we determine the location of the global package config. On Windows, -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the -- location is passed to the binary using the --global-config flag by the -- wrapper script. let err_msg = "missing --global-conf option, location of global package.conf unknown\n" global_conf <- - case [ f | FlagGlobalConfig f <- flags ] of + case [ f | FlagGlobalConfig f <- my_flags ] of [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe" case mb_dir of Nothing -> die err_msg @@ -402,7 +416,7 @@ getPkgDatabases modify flags = do -- This is the database we modify by default. virt_global_conf = last env_stack - let db_flags = [ f | Just f <- map is_db_flag flags ] + let db_flags = [ f | Just f <- map is_db_flag my_flags ] where is_db_flag FlagUser = Just user_conf is_db_flag FlagGlobal = Just virt_global_conf is_db_flag (FlagConfig f) = Just f @@ -426,7 +440,7 @@ getPkgDatabases modify flags = do -- stack, unless any of them are present in the stack -- already. flag_stack = filter (`notElem` env_stack) - [ f | FlagConfig f <- reverse flags ] + [ f | FlagConfig f <- reverse my_flags ] ++ env_stack modifying f @@ -443,7 +457,7 @@ getPkgDatabases modify flags = do readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB) readParseDatabase filename = do str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig - let packages = read str + let packages = map convertPackageInfoIn $ read str Exception.evaluate packages `Exception.catch` \e-> die ("error while parsing " ++ filename ++ ": " ++ show e) @@ -461,8 +475,8 @@ registerPackage :: FilePath -> Bool -- update -> Force -> IO () -registerPackage input flags auto_ghci_libs update force = do - db_stack <- getPkgDatabases True flags +registerPackage input my_flags auto_ghci_libs update force = do + db_stack <- getPkgDatabases True my_flags let db_to_operate_on = my_head "db" db_stack db_filename = fst db_to_operate_on @@ -508,15 +522,15 @@ hidePackage :: PackageIdentifier -> [Flag] -> IO () hidePackage = modifyPackage (\p -> [p{exposed=False}]) unregisterPackage :: PackageIdentifier -> [Flag] -> IO () -unregisterPackage = modifyPackage (\p -> []) +unregisterPackage = modifyPackage (\_ -> []) modifyPackage :: (InstalledPackageInfo -> [InstalledPackageInfo]) -> PackageIdentifier -> [Flag] -> IO () -modifyPackage fn pkgid flags = do - db_stack <- getPkgDatabases True{-modify-} flags +modifyPackage fn pkgid my_flags = do + db_stack <- getPkgDatabases True{-modify-} my_flags let ((db_name, pkgs) : _) = db_stack ps <- findPackages [(db_name,pkgs)] (Id pkgid) let pids = map package ps @@ -531,9 +545,9 @@ modifyPackage fn pkgid flags = do -- Listing packages listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO () -listPackages flags mPackageName mModuleName = do - let simple_output = FlagSimpleOutput `elem` flags - db_stack <- getPkgDatabases False flags +listPackages my_flags mPackageName mModuleName = do + let simple_output = FlagSimpleOutput `elem` my_flags + db_stack <- getPkgDatabases False my_flags let db_stack_filtered -- if a package is given, filter out all other packages | Just this <- mPackageName = map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs)) @@ -553,9 +567,9 @@ listPackages flags mPackageName mModuleName = do EQ -> pkgVersion p1 `compare` pkgVersion p2 where (p1,p2) = (package pkg1, package pkg2) - match `exposedInPkg` pkg = any match (exposedModules pkg) + match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) - pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack + pkg_map = map (\p -> (package p, p)) $ allPackagesInStack db_stack show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map) show_func (reverse db_stack_sorted) @@ -569,13 +583,13 @@ listPackages flags mPackageName mModuleName = do | isBrokenPackage p pkg_map = braces doc | exposed p = doc | otherwise = parens doc - where doc = text (showPackageId (package p)) + where doc = text (display (package p)) show_simple db_stack = do - let showPkg = if FlagNamesOnly `elem` flags then pkgName - else showPackageId + let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName + else display pkgs = map showPkg $ sortBy compPkgIdVer $ - map package (concatMap snd db_stack) + map package (allPackagesInStack db_stack) when (not (null pkgs)) $ hPutStrLn stdout $ concat $ intersperse " " pkgs @@ -583,22 +597,30 @@ listPackages flags mPackageName mModuleName = do -- Prints the highest (hidden or exposed) version of a package latestPackage :: [Flag] -> PackageIdentifier -> IO () -latestPackage flags pkgid = do - db_stack <- getPkgDatabases False flags +latestPackage my_flags pkgid = do + db_stack <- getPkgDatabases False my_flags ps <- findPackages db_stack (Id pkgid) show_pkg (sortBy compPkgIdVer (map package ps)) where show_pkg [] = die "no matches" - show_pkg pids = hPutStrLn stdout (showPackageId (last pids)) + show_pkg pids = hPutStrLn stdout (display (last pids)) -- ----------------------------------------------------------------------------- -- Describe describePackage :: [Flag] -> PackageArg -> IO () -describePackage flags pkgarg = do - db_stack <- getPkgDatabases False flags +describePackage my_flags pkgarg = do + db_stack <- getPkgDatabases False my_flags ps <- findPackages db_stack pkgarg - mapM_ (putStrLn . showInstalledPackageInfo) ps + doDump ps + +dumpPackages :: [Flag] -> IO () +dumpPackages my_flags = do + db_stack <- getPkgDatabases False my_flags + doDump (allPackagesInStack db_stack) + +doDump :: [InstalledPackageInfo] -> IO () +doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo -- PackageId is can have globVersion for the version findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] @@ -607,8 +629,8 @@ findPackages db_stack pkgarg [] -> die ("cannot find package " ++ pkg_msg pkgarg) ps -> return ps where - all_pkgs = concat (map snd db_stack) - pkg_msg (Id pkgid) = showPackageId pkgid + all_pkgs = allPackagesInStack db_stack + pkg_msg (Id pkgid) = display pkgid pkg_msg (Substring pkgpat _) = "matching "++pkgpat matches :: PackageIdentifier -> PackageIdentifier -> Bool @@ -618,7 +640,7 @@ pid `matches` pid' matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool (Id pid) `matchesPkg` pkg = pid `matches` package pkg -(Substring _ m) `matchesPkg` pkg = m (showPackageId (package pkg)) +(Substring _ m) `matchesPkg` pkg = m (display (package pkg)) compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 @@ -627,8 +649,8 @@ compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 -- Field describeField :: [Flag] -> PackageArg -> [String] -> IO () -describeField flags pkgarg fields = do - db_stack <- getPkgDatabases False flags +describeField my_flags pkgarg fields = do + db_stack <- getPkgDatabases False my_flags fns <- toFields fields ps <- findPackages db_stack pkgarg let top_dir = takeDirectory (fst (last db_stack)) @@ -678,7 +700,7 @@ toField "hs_libraries" = Just $ strList . hsLibraries toField "extra_libraries" = Just $ strList . extraLibraries toField "include_dirs" = Just $ strList . includeDirs toField "c_includes" = Just $ strList . includes -toField "package_deps" = Just $ strList . map showPackageId. depends +toField "package_deps" = Just $ strList . map display. depends toField "extra_cc_opts" = Just $ strList . ccOptions toField "extra_ld_opts" = Just $ strList . ldOptions toField "framework_dirs" = Just $ strList . frameworkDirs @@ -693,11 +715,11 @@ strList = show -- Check: Check consistency of installed packages checkConsistency :: [Flag] -> IO () -checkConsistency flags = do - db_stack <- getPkgDatabases True flags +checkConsistency my_flags = do + db_stack <- getPkgDatabases True my_flags -- check behaves like modify for the purposes of deciding which -- databases to use, because ordering is important. - let pkgs = map (\p -> (package p, p)) $ concatMap snd db_stack + let pkgs = map (\p -> (package p, p)) $ allPackagesInStack db_stack broken_pkgs = do (pid, p) <- pkgs let broken_deps = missingPackageDeps p pkgs @@ -705,14 +727,14 @@ checkConsistency flags = do return (pid, broken_deps) mapM_ (putStrLn . render . show_func) broken_pkgs where - show_func | FlagSimpleOutput `elem` flags = show_simple + show_func | FlagSimpleOutput `elem` my_flags = show_simple | otherwise = show_normal show_simple (pid,deps) = - text (showPackageId pid) <> colon - <+> fsep (punctuate comma (map (text . showPackageId) deps)) + text (display pid) <> colon + <+> fsep (punctuate comma (map (text . display) deps)) show_normal (pid,deps) = - text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:" - $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps))) + text "package" <+> text (display pid) <+> text "has missing dependencies:" + $$ nest 4 (fsep (punctuate comma (map (text . display) deps))) missingPackageDeps :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] @@ -725,7 +747,7 @@ missingPackageDeps pkg pkg_map = isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg (filter notme pkg_map) - where notme (p,ipi) = package pkg /= p + where notme (p, _ipi) = package pkg /= p -- remove p from the database when we invoke missingPackageDeps, -- because we want mutually recursive groups of package to show up -- as broken. (#1750) @@ -733,6 +755,23 @@ isBrokenPackage pkg pkg_map -- ----------------------------------------------------------------------------- -- Manipulating package.conf files +type InstalledPackageInfoString = InstalledPackageInfo_ String + +convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString +convertPackageInfoOut + (pkgconf@(InstalledPackageInfo { exposedModules = e, + hiddenModules = h })) = + pkgconf{ exposedModules = map display e, + hiddenModules = map display h } + +convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo +convertPackageInfoIn + (pkgconf@(InstalledPackageInfo { exposedModules = e, + hiddenModules = h })) = + pkgconf{ exposedModules = map convert e, + hiddenModules = map convert h } + where convert = fromJust . simpleParse + writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO () writeNewConfig filename packages = do hPutStr stdout "Writing new package config file... " @@ -741,7 +780,8 @@ writeNewConfig filename packages = do if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e - let shown = concat $ intersperse ",\n " $ map show packages + let shown = concat $ intersperse ",\n " + $ map (show . convertPackageInfoOut) packages fileContents = "[" ++ shown ++ "\n]" hPutStrLn h fileContents hClose h @@ -805,8 +845,8 @@ validatePackageConfig pkg db_stack auto_ghci_libs update force = do -- we check that the package id can be parsed properly here. checkPackageId :: InstalledPackageInfo -> IO () checkPackageId ipi = - let str = showPackageId (package ipi) in - case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of + let str = display (package ipi) in + case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of [_] -> return () [] -> die ("invalid package identifier: " ++ str) _ -> die ("ambiguous package identifier: " ++ str) @@ -820,16 +860,16 @@ checkDuplicates db_stack pkg update force = do -- Check whether this package id already exists in this DB -- when (not update && (pkgid `elem` map package pkgs)) $ - die ("package " ++ showPackageId pkgid ++ " is already installed") + die ("package " ++ display pkgid ++ " is already installed") let - uncasep = map toLower . showPackageId + uncasep = map toLower . display dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs) when (not update && not (null dups)) $ dieOrForceAll force $ "Package names may be treated case-insensitively in the future.\n"++ - "Package " ++ showPackageId pkgid ++ - " overlaps with: " ++ unwords (map showPackageId dups) + "Package " ++ display pkgid ++ + " overlaps with: " ++ unwords (map display dups) checkDir :: Force -> String -> IO () @@ -845,7 +885,7 @@ checkDir force d checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO () checkDep db_stack force pkgid | pkgid `elem` pkgids || (not real_version && name_exists) = return () - | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid + | otherwise = dieOrForceAll force ("dependency " ++ display pkgid ++ " doesn't exist") where -- for backwards compat, we treat 0.0 as a special version, @@ -855,7 +895,7 @@ checkDep db_stack force pkgid name_exists = any (\p -> pkgName (package p) == name) all_pkgs name = pkgName pkgid - all_pkgs = concat (map snd db_stack) + all_pkgs = allPackagesInStack db_stack pkgids = map package all_pkgs realVersion :: PackageIdentifier -> Bool @@ -948,7 +988,7 @@ okInModuleName c -- expanding environment variables in the package configuration expandEnvVars :: String -> Force -> IO String -expandEnvVars str force = go str "" +expandEnvVars str0 force = go str0 "" where go "" acc = return $! reverse acc go ('$':'{':str) acc | (var, '}':rest) <- break close str @@ -999,8 +1039,8 @@ dieForcible :: String -> IO () dieForcible s = die (s ++ " (use --force to override)") my_head :: String -> [a] -> a -my_head s [] = error s -my_head s (x:xs) = x +my_head s [] = error s +my_head _ (x : _) = x ----------------------------------------- -- Cut and pasted from ghc/compiler/main/SysTools