X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=2157d071a118ffae2ecbdde84e526db501cadf2e;hp=3f8b0b366ba550e5dfa006a00381395ddd4b1820;hb=37557940c005d34fc755203139cfaa555fdb3cb8;hpb=b93ff3a3d656fb35a8ca8d15f1f24c4280b1adef diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 3f8b0b3..2157d07 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -8,62 +8,53 @@ ----------------------------------------------------------------------------- -- TODO: --- - validate modules --- - expanding of variables in new-style package conf --- - version manipulation (checking whether old version exists, --- hiding old version?) +-- * validate modules +-- * expanding of variables in new-style package conf +-- * version manipulation (checking whether old version exists, +-- hiding old version?) module Main (main) where -import Version ( version, targetOS, targetARCH ) +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 ) +import System.FilePath + +#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 #include "../../includes/ghcconfig.h" -#if __GLASGOW_HASKELL__ >= 504 import System.Console.GetOpt import Text.PrettyPrint import qualified Control.Exception as Exception import Data.Maybe -#else -import GetOpt -import Pretty -import qualified Exception -import Maybe -#endif -import Data.Char ( isSpace ) +import Data.Char ( isSpace ) import Monad import Directory -import System ( getArgs, getProgName, getEnv, - exitWith, ExitCode(..) - ) +import System ( getArgs, getProgName, getEnv, exitWith, ExitCode(..) ) import System.IO -#if __GLASGOW_HASKELL__ >= 600 import System.IO.Error (try) -#else -import System.IO (try) -#endif import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy ) #ifdef mingw32_HOST_OS import Foreign - -#if __GLASGOW_HASKELL__ >= 504 import Foreign.C.String -#else -import CString -#endif #endif +import IO ( isPermissionError, isDoesNotExistError ) + -- ----------------------------------------------------------------------------- -- Entry point @@ -71,15 +62,15 @@ main :: IO () main = do args <- getArgs - case getOpt Permute flags args of - (cli,_,[]) | FlagHelp `elem` cli -> do - prog <- getProgramName - bye (usageInfo (usageHeader prog) flags) - (cli,_,[]) | FlagVersion `elem` cli -> - bye ourCopyright - (cli,nonopts,[]) -> - runit cli nonopts - (_,_,errors) -> tryOldCmdLine errors args + case getOpt Permute (flags ++ deprecFlags) args of + (cli,_,[]) | FlagHelp `elem` cli -> do + prog <- getProgramName + bye (usageInfo (usageHeader prog) flags) + (cli,_,[]) | FlagVersion `elem` cli -> + bye ourCopyright + (cli,nonopts,[]) -> + runit cli nonopts + (_,_,errors) -> tryOldCmdLine errors args -- If the new command-line syntax fails, then we try the old. If that -- fails too, then we output the original errors and the new syntax @@ -87,11 +78,11 @@ main = do tryOldCmdLine :: [String] -> [String] -> IO () tryOldCmdLine errors args = do case getOpt Permute oldFlags args of - (cli@(_:_),[],[]) -> - oldRunit cli - _failed -> do - prog <- getProgramName - die (concat errors ++ usageInfo (usageHeader prog) flags) + (cli@(_:_),[],[]) -> + oldRunit cli + _failed -> do + prog <- getProgramName + die (concat errors ++ usageInfo (usageHeader prog) flags) -- ----------------------------------------------------------------------------- -- Command-line syntax @@ -101,39 +92,49 @@ data Flag | FlagGlobal | FlagHelp | FlagVersion - | FlagConfig FilePath + | FlagConfig FilePath | FlagGlobalConfig FilePath | FlagForce + | FlagForceFiles | FlagAutoGHCiLibs | FlagDefinedName String String | FlagSimpleOutput + | FlagNamesOnly deriving Eq flags :: [OptDescr Flag] flags = [ Option [] ["user"] (NoArg FlagUser) - "use the current user's package database", + "use the current user's package database", Option [] ["global"] (NoArg FlagGlobal) - "(default) use the global package database", + "(default) use the global package database", Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE") - "act upon specified package config file (only)", + "act upon specified package config file (only)", Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE") - "location of the global package config", + "location of the global package config", Option [] ["force"] (NoArg FlagForce) - "ignore missing dependencies, directories, and libraries", + "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)", + "automatically build libs for GHCi (with register)", Option ['?'] ["help"] (NoArg FlagHelp) - "display this help and exit", - Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE") - "define NAME as VALUE", + "display this help and exit", Option ['V'] ["version"] (NoArg FlagVersion) - "output version information and exit", + "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", + Option [] ["names-only"] (NoArg FlagNamesOnly) + "only print package names, not versions; can only be used with list --simple-output" ] - where - toDefined str = + +deprecFlags :: [OptDescr Flag] +deprecFlags = [ + Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE") + "define NAME as VALUE" + ] + where + toDefined str = case break (=='=') str of (nm,[]) -> FlagDefinedName nm [] (nm,_:val) -> FlagDefinedName nm val @@ -166,10 +167,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" ++ @@ -189,52 +195,61 @@ 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 - auto_ghci_libs = FlagAutoGHCiLibs `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 ] -- -- first, parse the command case nonopts of - ["register", filename] -> - registerPackage filename defines cli auto_ghci_libs False force - ["update", filename] -> - registerPackage filename defines cli auto_ghci_libs True force + ["register", filename] -> + registerPackage filename defines cli auto_ghci_libs False force + ["update", filename] -> + registerPackage filename defines cli auto_ghci_libs True force ["unregister", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - unregisterPackage pkgid cli + pkgid <- readGlobPkgId pkgid_str + unregisterPackage pkgid cli ["expose", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - exposePackage pkgid cli + pkgid <- readGlobPkgId pkgid_str + exposePackage pkgid cli ["hide", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - hidePackage pkgid cli + pkgid <- readGlobPkgId pkgid_str + hidePackage pkgid cli ["list"] -> do - listPackages cli Nothing + listPackages cli Nothing Nothing ["list", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - listPackages cli (Just pkgid) + pkgid <- readGlobPkgId pkgid_str + listPackages cli (Just pkgid) Nothing + ["find-module", moduleName] -> do + listPackages cli Nothing (Just moduleName) ["latest", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - latestPackage cli pkgid + pkgid <- readGlobPkgId pkgid_str + latestPackage cli pkgid ["describe", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - describePackage cli pkgid + pkgid <- readGlobPkgId pkgid_str + describePackage cli pkgid ["field", pkgid_str, field] -> do - pkgid <- readGlobPkgId pkgid_str - describeField cli pkgid field + pkgid <- readGlobPkgId pkgid_str + describeField cli pkgid field + ["check"] -> do + checkConsistency cli [] -> do - die ("missing command\n" ++ - usageInfo (usageHeader prog) flags) + die ("missing command\n" ++ + usageInfo (usageHeader prog) flags) (_cmd:_) -> do - die ("command-line syntax error\n" ++ - usageInfo (usageHeader prog) flags) + die ("command-line syntax error\n" ++ + usageInfo (usageHeader prog) flags) parseCheck :: ReadP a a -> String -> String -> IO a -parseCheck parser str what = +parseCheck parser str what = case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of [x] -> return x _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what) @@ -246,7 +261,7 @@ readGlobPkgId :: String -> IO PackageIdentifier readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier" parseGlobPackageId :: ReadP r PackageIdentifier -parseGlobPackageId = +parseGlobPackageId = parsePackageId +++ (do n <- parsePackageName; string "-*" @@ -260,20 +275,20 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] } -- Package databases -- Some commands operate on a single database: --- register, unregister, expose, hide +-- register, unregister, expose, hide -- however these commands also check the union of the available databases -- in order to check consistency. For example, register will check that -- dependencies exist before registering a package. -- -- Some commands operate on multiple databases, with overlapping semantics: --- list, describe, field +-- list, describe, field type PackageDBName = FilePath type PackageDB = [InstalledPackageInfo] type PackageDBStack = [(PackageDBName,PackageDB)] - -- A stack of package databases. Convention: head is the topmost - -- in the stack. Earlier entries override later one. + -- A stack of package databases. Convention: head is the topmost + -- in the stack. Earlier entries override later one. getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack getPkgDatabases modify flags = do @@ -282,12 +297,12 @@ getPkgDatabases modify flags = do -- 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 <- + global_conf <- case [ f | FlagGlobalConfig f <- flags ] of - [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe" - case mb_dir of - Nothing -> die err_msg - Just dir -> return (dir `joinFileName` "package.conf") + [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe" + case mb_dir of + Nothing -> die err_msg + Just dir -> return (dir "package.conf") fs -> return (last fs) let global_conf_dir = global_conf ++ ".d" @@ -304,53 +319,53 @@ getPkgDatabases modify flags = do appdir <- getAppUserDataDirectory "ghc" let - subdir = targetARCH ++ '-':targetOS ++ '-':version - archdir = appdir `joinFileName` subdir - user_conf = archdir `joinFileName` "package.conf" + subdir = targetARCH ++ '-':targetOS ++ '-':version + archdir = appdir subdir + user_conf = archdir "package.conf" user_exists <- doesFileExist user_conf -- If the user database doesn't exist, and this command isn't a -- "modify" command, then we won't attempt to create or use it. let sys_databases - | modify || user_exists = user_conf : global_confs ++ [global_conf] - | otherwise = global_confs ++ [global_conf] + | modify || user_exists = user_conf : global_confs ++ [global_conf] + | otherwise = global_confs ++ [global_conf] e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") let env_stack = - case e_pkg_path of - Left _ -> sys_databases - Right path - | last cs == "" -> init cs ++ sys_databases - | otherwise -> cs - where cs = parseSearchPath path - - -- The "global" database is always the one at the bottom of the stack. - -- This is the database we modify by default. + case e_pkg_path of + Left _ -> sys_databases + Right path + | last cs == "" -> init cs ++ sys_databases + | otherwise -> cs + where cs = splitSearchPath path + + -- The "global" database is always the one at the bottom of the stack. + -- This is the database we modify by default. virt_global_conf = last env_stack -- -f flags on the command line add to the database stack, unless any -- of them are present in the stack already. - let flag_stack = filter (`notElem` env_stack) - [ f | FlagConfig f <- reverse flags ] ++ env_stack + let flag_stack = filter (`notElem` env_stack) + [ f | FlagConfig f <- reverse flags ] ++ env_stack -- Now we have the full stack of databases. Next, if the current -- command is a "modify" type command, then we truncate the stack -- so that the topmost element is the database being modified. final_stack <- - if not modify + if not modify then return flag_stack - else let - go (FlagUser : fs) = modifying user_conf - go (FlagGlobal : fs) = modifying virt_global_conf - go (FlagConfig f : fs) = modifying f - go (_ : fs) = go fs - go [] = modifying virt_global_conf - - modifying f - | f `elem` flag_stack = return (dropWhile (/= f) flag_stack) - | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.") - in - go flags + else let + go (FlagUser : fs) = modifying user_conf + go (FlagGlobal : fs) = modifying virt_global_conf + go (FlagConfig f : fs) = modifying f + go (_ : fs) = go fs + go [] = modifying virt_global_conf + + modifying f + | f `elem` flag_stack = return (dropWhile (/= f) flag_stack) + | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.") + in + go flags db_stack <- mapM readParseDatabase final_stack return db_stack @@ -360,8 +375,8 @@ readParseDatabase filename = do str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig let packages = read str Exception.evaluate packages - `Exception.catch` \_ -> - die (filename ++ ": parse error in package config file") + `Exception.catch` \_ -> + die (filename ++ ": parse error in package config file") return (filename,packages) emptyPackageConfig :: String @@ -371,50 +386,49 @@ emptyPackageConfig = "[]" -- Registering registerPackage :: FilePath - -> [(String,String)] -- defines - -> [Flag] - -> Bool -- auto_ghci_libs - -> Bool -- update - -> Bool -- force - -> IO () + -> [(String,String)] -- defines + -> [Flag] + -> Bool -- auto_ghci_libs + -> Bool -- update + -> Force + -> IO () registerPackage input defines flags auto_ghci_libs update force = do db_stack <- getPkgDatabases True flags let - db_to_operate_on = my_head "db" db_stack - db_filename = fst db_to_operate_on + db_to_operate_on = my_head "db" db_stack + db_filename = fst db_to_operate_on -- - checkConfigAccess db_filename s <- case input of "-" -> do - putStr "Reading package info from stdin ... " + putStr "Reading package info from stdin ... " getContents f -> do putStr ("Reading package info from " ++ show f ++ " ... ") - readFile f + readFile f expanded <- expandEnvVars s defines force - pkg0 <- parsePackageInfo expanded defines force + pkg <- parsePackageInfo expanded defines putStrLn "done." - let pkg = resolveDeps db_stack pkg0 validatePackageConfig pkg db_stack auto_ghci_libs update force - let new_details = snd db_to_operate_on ++ [pkg] - savePackageConfig db_filename - maybeRestoreOldConfig db_filename $ + 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 = + :: String + -> [(String,String)] + -> IO InstalledPackageInfo +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 @@ -436,56 +450,61 @@ modifyPackage 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 $ + | package pkg `elem` pids = fn pkg + | otherwise = [pkg] + savingOldConfig db_name $ writeNewConfig db_name new_config -- ----------------------------------------------------------------------------- -- Listing packages -listPackages :: [Flag] -> Maybe PackageIdentifier -> IO () -listPackages flags mPackageName = do +listPackages :: [Flag] -> Maybe PackageIdentifier -> Maybe String -> IO () +listPackages flags mPackageName mModuleName = do let simple_output = FlagSimpleOutput `elem` flags db_stack <- getPkgDatabases False 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)) - db_stack + map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs)) + db_stack + | Just this <- mModuleName = -- packages which expose mModuleName + map (\(conf,pkgs) -> (conf, filter (this `exposedInPkg`) pkgs)) + db_stack | otherwise = db_stack - db_stack_sorted + db_stack_sorted = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ] - where sort_pkgs = sortBy cmpPkgIds - cmpPkgIds pkg1 pkg2 = - case pkgName p1 `compare` pkgName p2 of - LT -> LT - GT -> GT - EQ -> pkgVersion p1 `compare` pkgVersion p2 - where (p1,p2) = (package pkg1, package pkg2) + where sort_pkgs = sortBy cmpPkgIds + cmpPkgIds pkg1 pkg2 = + case pkgName p1 `compare` pkgName p2 of + LT -> LT + GT -> GT + 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) = - hPutStrLn stdout (render $ - text (db_name ++ ":") $$ nest 4 packages - ) - where packages = fsep (punctuate comma (map pp_pkg pkg_confs)) - pp_pkg p - | exposed p = doc - | otherwise = parens doc - where doc = text (showPackageId (package p)) - - show_easy db_stack = do - let pkgs = map showPackageId $ sortBy compPkgIdVer $ + where show_normal pkg_map (db_name,pkg_confs) = + hPutStrLn stdout (render $ + 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_simple db_stack = do + let showPkg = if FlagNamesOnly `elem` flags then pkgName + else showPackageId + pkgs = map showPkg $ sortBy compPkgIdVer $ map package (concatMap snd db_stack) when (null pkgs) $ die "no matches" hPutStrLn stdout $ concat $ intersperse " " pkgs @@ -515,10 +534,10 @@ describePackage flags pkgid = do findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo] findPackages db_stack pkgid = case [ p | p <- all_pkgs, pkgid `matchesPkg` p ] of - [] -> die ("cannot find package " ++ showPackageId pkgid) - ps -> return ps + [] -> die ("cannot find package " ++ showPackageId pkgid) + ps -> return ps where - all_pkgs = concat (map snd db_stack) + all_pkgs = concat (map snd db_stack) matches :: PackageIdentifier -> PackageIdentifier -> Bool pid `matches` pid' @@ -531,6 +550,9 @@ pid `matchesPkg` pkg = pid `matches` package pkg compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 +exposedInPkg :: String -> InstalledPackageInfo -> Bool +moduleName `exposedInPkg` pkg = moduleName `elem` exposedModules pkg + -- ----------------------------------------------------------------------------- -- Field @@ -540,8 +562,38 @@ describeField flags pkgid field = do case toField field of Nothing -> die ("unknown field: " ++ field) Just fn -> do - ps <- findPackages db_stack pkgid - mapM_ (putStrLn.fn) ps + ps <- findPackages db_stack pkgid + let top_dir = takeDirectory (fst (last db_stack)) + mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps) + +mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo] +-- Replace the strings "$topdir" and "$httptopdir" 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' + | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p' + | otherwise = p + + toHttpPath p = "file:///" ++ 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: @@ -555,84 +607,115 @@ toField "c_includes" = Just $ strList . includes toField "package_deps" = Just $ strList . map showPackageId. depends toField "extra_cc_opts" = Just $ strList . ccOptions toField "extra_ld_opts" = Just $ strList . ldOptions -toField "framework_dirs" = Just $ strList . frameworkDirs -toField "extra_frameworks"= Just $ strList . frameworks -toField s = showInstalledPackageInfoField s +toField "framework_dirs" = Just $ strList . frameworkDirs +toField "extra_frameworks"= Just $ strList . frameworks +toField s = showInstalledPackageInfoField s strList :: [String] -> String strList = show + -- ----------------------------------------------------------------------------- --- Manipulating package.conf files +-- 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 -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 + +-- ----------------------------------------------------------------------------- +-- Manipulating package.conf files writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO () writeNewConfig filename packages = do hPutStr stdout "Writing new package config file... " - h <- openFile filename WriteMode - hPutStrLn h (show packages) + createDirectoryIfMissing True $ takeDirectory 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 + let shown = concat $ intersperse ",\n " $ map show packages + fileContents = "[" ++ shown ++ "\n]" + hPutStrLn h fileContents 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 -- if requested. validatePackageConfig :: InstalledPackageInfo - -> PackageDBStack - -> Bool -- auto-ghc-libs - -> Bool -- update - -> Bool -- force - -> IO () + -> PackageDBStack + -> Bool -- auto-ghc-libs + -> Bool -- update + -> Force + -> IO () validatePackageConfig pkg db_stack auto_ghci_libs update force = do checkPackageId pkg - checkDuplicates db_stack pkg update force - mapM_ (checkDep db_stack force) (depends pkg) - mapM_ (checkDir force) (importDirs pkg) - mapM_ (checkDir force) (libraryDirs pkg) - mapM_ (checkDir force) (includeDirs pkg) + 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) -- ToDo: check these somehow? - -- extra_libraries :: [String], - -- c_includes :: [String], + -- extra_libraries :: [String], + -- c_includes :: [String], -- When the package name and version are put together, sometimes we can --- end up with a package id that cannot be parsed. This will lead to +-- end up with a package id that cannot be parsed. This will lead to -- difficulties when the user wants to refer to the package later, so -- we check that the package id can be parsed properly here. checkPackageId :: InstalledPackageInfo -> IO () @@ -643,38 +726,11 @@ checkPackageId ipi = [] -> die ("invalid package identifier: " ++ str) _ -> die ("ambiguous package identifier: " ++ str) -resolveDeps :: PackageDBStack -> InstalledPackageInfo -> InstalledPackageInfo -resolveDeps db_stack p = updateDeps p - where - -- The input package spec is allowed to give a package dependency - -- without a version number; e.g. - -- depends: base - -- Here, we update these dependencies without version numbers to - -- match the actual versions of the relevant packages installed. - updateDeps p = p{depends = map resolveDep (depends p)} - - resolveDep dep_pkgid - | realVersion dep_pkgid = dep_pkgid - | otherwise = lookupDep dep_pkgid - - lookupDep dep_pkgid - = let - name = pkgName dep_pkgid - in - case [ pid | p <- concat (map snd db_stack), - let pid = package p, - pkgName pid == name ] of - (pid:_) -> pid -- Found installed package, - -- replete with its version - [] -> 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 + pkgid = package pkg + (_top_db_name, pkgs) : _ = db_stack -- -- Check whether this package id already exists in this DB -- @@ -683,43 +739,48 @@ 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 + | "$topdir" `isPrefixOf` d = return () + | "$httptopdir" `isPrefixOf` d = return () + -- can't check these, because we don't know what $(http)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 - ++ " doesn't exist") + | 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 - - all_pkgs = concat (map snd db_stack) - pkgids = map package all_pkgs + -- 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 ++ - " on library path") - (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs + [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++ + " on library path") + (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs doesLibExistIn :: String -> String -> IO Bool doesLibExistIn lib d - | "$topdir" `isPrefixOf` d = return True + | "$topdir" `isPrefixOf` d = return True + | "$httptopdir" `isPrefixOf` d = return True | otherwise = doesFileExist (d ++ '/':lib) checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () @@ -729,11 +790,11 @@ checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build bs <- mapM (doesLibExistIn ghci_lib_file) dirs case [dir | (exists,dir) <- zip bs dirs, exists] of [] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file) - (_:_) -> return () + (_:_) -> return () where ghci_lib_file = lib ++ ".o" --- automatically build the GHCi version of a batch lib, +-- automatically build the GHCi version of a batch lib, -- using ld --whole-archive. autoBuildGHCiLib :: String -> String -> String -> IO () @@ -758,7 +819,7 @@ autoBuildGHCiLib dir batch_file ghci_file = do #if not_yet findModules :: [FilePath] -> IO [String] -findModules paths = +findModules paths = mms <- mapM searchDir paths return (concat mms) @@ -769,22 +830,22 @@ searchDir path prefix = do searchEntries path prefix [] = return [] searchEntries path prefix (f:fs) | looks_like_a_module = do - ms <- searchEntries path prefix fs - return (prefix `joinModule` f : ms) + ms <- searchEntries path prefix fs + return (prefix `joinModule` f : ms) | looks_like_a_component = do - ms <- searchDir (path `joinFilename` f) (prefix `joinModule` f) + ms <- searchDir (path f) (prefix `joinModule` f) ms' <- searchEntries path prefix fs - return (ms ++ ms') + return (ms ++ ms') | otherwise - searchEntries path prefix fs + searchEntries path prefix fs where - (base,suffix) = splitFileExt f - looks_like_a_module = - suffix `elem` haskell_suffixes && - all okInModuleName base - looks_like_a_component = - null suffix && all okInModuleName base + (base,suffix) = splitFileExt f + looks_like_a_module = + suffix `elem` haskell_suffixes && + all okInModuleName base + looks_like_a_component = + null suffix && all okInModuleName base okInModuleName c @@ -793,13 +854,13 @@ okInModuleName c -- ----------------------------------------------------------------------------- -- The old command-line syntax, supported for backwards compatibility -data OldFlag +data OldFlag = OF_Config FilePath | OF_Input FilePath | OF_List | OF_ListLocal | OF_Add Bool {- True => replace existing info -} - | OF_Remove String | OF_Show String + | OF_Remove String | OF_Show String | OF_Field String | OF_AutoGHCiLibs | OF_Force | OF_DefinedName String String | OF_GlobalConfig FilePath @@ -810,7 +871,7 @@ isAction OF_Config{} = False isAction OF_Field{} = False isAction OF_Input{} = False isAction OF_AutoGHCiLibs{} = False -isAction OF_Force{} = False +isAction OF_Force{} = False isAction OF_DefinedName{} = False isAction OF_GlobalConfig{} = False isAction _ = True @@ -818,34 +879,34 @@ isAction _ = True oldFlags :: [OptDescr OldFlag] oldFlags = [ Option ['f'] ["config-file"] (ReqArg OF_Config "FILE") - "use the specified package config file", + "use the specified package config file", Option ['l'] ["list-packages"] (NoArg OF_List) - "list packages in all config files", + "list packages in all config files", Option ['L'] ["list-local-packages"] (NoArg OF_ListLocal) - "list packages in the specified config file", + "list packages in the specified config file", Option ['a'] ["add-package"] (NoArg (OF_Add False)) - "add a new package", + "add a new package", Option ['u'] ["update-package"] (NoArg (OF_Add True)) - "update package with new configuration", + "update package with new configuration", Option ['i'] ["input-file"] (ReqArg OF_Input "FILE") - "read new package info from specified file", + "read new package info from specified file", Option ['s'] ["show-package"] (ReqArg OF_Show "NAME") - "show the configuration for package NAME", + "show the configuration for package NAME", Option [] ["field"] (ReqArg OF_Field "FIELD") - "(with --show-package) Show field FIELD only", + "(with --show-package) Show field FIELD only", Option [] ["force"] (NoArg OF_Force) - "ignore missing directories/libraries", + "ignore missing directories/libraries", Option ['r'] ["remove-package"] (ReqArg OF_Remove "NAME") - "remove an installed package", + "remove an installed package", Option ['g'] ["auto-ghci-libs"] (NoArg OF_AutoGHCiLibs) - "automatically build libs for GHCi (with -a)", + "automatically build libs for GHCi (with -a)", Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE") - "define NAME as VALUE", + "define NAME as VALUE", Option [] ["global-conf"] (ReqArg OF_GlobalConfig "FILE") - "location of the global package config" + "location of the global package config" ] where - toDefined str = + toDefined str = case break (=='=') str of (nm,[]) -> OF_DefinedName nm [] (nm,_:val) -> OF_DefinedName nm val @@ -858,36 +919,36 @@ oldRunit clis = do conv (OF_Config f) = Just (FlagConfig f) conv _ = Nothing - + let fields = [ f | OF_Field f <- clis ] - let auto_ghci_libs = any isAuto clis - where isAuto OF_AutoGHCiLibs = True; isAuto _ = False + let auto_ghci_libs = any isAuto clis + 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 ] case [ c | c <- clis, isAction c ] of - [ OF_List ] -> listPackages new_flags Nothing - [ OF_ListLocal ] -> listPackages new_flags Nothing - [ OF_Add upd ] -> - registerPackage input_file defines new_flags auto_ghci_libs upd force + [ OF_List ] -> listPackages new_flags Nothing Nothing + [ OF_ListLocal ] -> listPackages new_flags Nothing Nothing + [ OF_Add upd ] -> + registerPackage input_file defines new_flags auto_ghci_libs upd force [ OF_Remove pkgid_str ] -> do - pkgid <- readPkgId pkgid_str - unregisterPackage pkgid new_flags + pkgid <- readPkgId pkgid_str + unregisterPackage pkgid new_flags [ OF_Show pkgid_str ] - | null fields -> do - pkgid <- readPkgId pkgid_str - describePackage new_flags pkgid - | otherwise -> do - pkgid <- readPkgId pkgid_str - mapM_ (describeField new_flags pkgid) fields - _ -> do - prog <- getProgramName - die (usageInfo (usageHeader prog) flags) + | null fields -> do + pkgid <- readPkgId pkgid_str + describePackage new_flags pkgid + | otherwise -> do + pkgid <- readPkgId pkgid_str + mapM_ (describeField new_flags pkgid) fields + _ -> do + prog <- getProgramName + die (usageInfo (usageHeader prog) flags) my_head :: String -> [a] -> a my_head s [] = error s @@ -896,26 +957,26 @@ 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 go ('$':'{':str) acc | (var, '}':rest) <- break close str = do value <- lookupEnvVar var - go rest (reverse value ++ acc) - where close c = c == '}' || c == '\n' -- don't span newlines + go rest (reverse value ++ acc) + where close c = c == '}' || c == '\n' -- don't span newlines go (c:str) acc - = go str (c:acc) + = go str (c:acc) lookupEnvVar :: String -> IO String - lookupEnvVar nm = + lookupEnvVar nm = case lookup nm defines of Just x | not (null x) -> return x - _ -> - catch (System.getEnv nm) - (\ _ -> do dieOrForce force ("Unable to expand variable " ++ - show nm) - return "") + _ -> + catch (System.getEnv nm) + (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ + show nm) + return "") ----------------------------------------------------------------------------- @@ -929,115 +990,55 @@ bye :: String -> IO a bye s = putStr s >> exitWith ExitSuccess die :: String -> IO a -die s = do +die s = do hFlush stdout prog <- getProgramName 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 +-- Cut and pasted from ghc/compiler/SysTools #if defined(mingw32_HOST_OS) +subst :: Char -> Char -> String -> String subst a b ls = map (\ x -> if x == a then b else x) ls + +unDosifyPath :: FilePath -> FilePath unDosifyPath xs = subst '\\' '/' xs getExecDir :: String -> IO (Maybe String) -- (getExecDir cmd) returns the directory in which the current --- executable, which should be called 'cmd', is running +-- executable, which should be called 'cmd', is running -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd, -- you'll get "/a/b/c" back as the result getExecDir cmd = allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else do s <- peekCString buf - return (Just (reverse (drop (length cmd) - (reverse (unDosifyPath s))))) + ret <- getModuleFileName nullPtr buf len + if ret == 0 then return Nothing + else do s <- peekCString buf + return (Just (reverse (drop (length cmd) + (reverse (unDosifyPath s))))) where len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32. foreign import stdcall unsafe "GetModuleFileNameA" getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 #else -getExecDir :: String -> IO (Maybe String) +getExecDir :: String -> IO (Maybe String) getExecDir _ = return Nothing #endif - --- ----------------------------------------------------------------------------- --- FilePath utils - --- | The 'joinFileName' function is the opposite of 'splitFileName'. --- It joins directory and file names to form a complete file path. --- --- The general rule is: --- --- > dir `joinFileName` basename == path --- > where --- > (dir,basename) = splitFileName path --- --- There might be an exceptions to the rule but in any case the --- reconstructed path will refer to the same object (file or directory). --- An example exception is that on Windows some slashes might be converted --- to backslashes. -joinFileName :: String -> String -> FilePath -joinFileName "" fname = fname -joinFileName "." fname = fname -joinFileName dir "" = dir -joinFileName dir fname - | isPathSeparator (last dir) = dir++fname - | otherwise = dir++pathSeparator:fname - --- | Checks whether the character is a valid path separator for the host --- platform. The valid character is a 'pathSeparator' but since the Windows --- operating system also accepts a slash (\"\/\") since DOS 2, the function --- checks for it on this platform, too. -isPathSeparator :: Char -> Bool -isPathSeparator ch = ch == pathSeparator || ch == '/' - --- | Provides a platform-specific character used to separate directory levels in --- a path string that reflects a hierarchical file system organization. The --- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash --- (@\"\\\"@) on the Windows operating system. -pathSeparator :: Char -#ifdef mingw32_HOST_OS -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif - --- | The function splits the given string to substrings --- using the 'searchPathSeparator'. -parseSearchPath :: String -> [FilePath] -parseSearchPath path = split path - where - split :: String -> [String] - split s = - case rest' of - [] -> [chunk] - _:rest -> chunk : split rest - where - chunk = - case chunk' of -#ifdef mingw32_HOST_OS - ('\"':xs@(_:_)) | last xs == '\"' -> init xs -#endif - _ -> chunk' - - (chunk', rest') = break (==searchPathSeparator) s - --- | A platform-specific character used to separate search path strings in --- environment variables. The separator is a colon (\":\") on Unix and Macintosh, --- and a semicolon (\";\") on the Windows operating system. -searchPathSeparator :: Char -#if mingw32_HOST_OS || mingw32_TARGET_OS -searchPathSeparator = ';' -#else -searchPathSeparator = ':' -#endif -