X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=a13ba44644cae3ee6f8c9ef0856177b04537ae5b;hb=72547264724117d689a7fa400104185557fb2a0c;hp=39f7eebd8647fd85b47add98652407482ab2b1d8;hpb=0f39a76981957c7120e42dda04c07f394692cfdb;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 39f7eeb..a13ba44 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -1,25 +1,21 @@ {-# OPTIONS -fglasgow-exts -cpp #-} ----------------------------------------------------------------------------- -- --- (c) The University of Glasgow 2004. +-- (c) The University of Glasgow 2004-2009. -- -- Package management tool -- ----------------------------------------------------------------------------- --- TODO: --- * 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 Distribution.InstalledPackageInfo hiding (depends) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.ModuleName hiding (main) +import Distribution.InstalledPackageInfo import Distribution.Compat.ReadP import Distribution.ParseUtils -import Distribution.Package +import Distribution.Package hiding (depends) import Distribution.Text import Distribution.Version import System.FilePath @@ -60,7 +56,11 @@ import System.Posix hiding (fdToHandle) import IO ( isPermissionError ) import System.Posix.Internals +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Handle.FD (fdToHandle) +#else import GHC.Handle (fdToHandle) +#endif #if defined(GLOB) import System.Process(runInteractiveCommand) @@ -81,7 +81,9 @@ main = do (cli,_,[]) | FlagVersion `elem` cli -> bye ourCopyright (cli,nonopts,[]) -> - runit cli nonopts + case getVerbosity Normal cli of + Right v -> runit v cli nonopts + Left err -> die err (_,_,errors) -> do prog <- getProgramName die (concat errors ++ usageInfo (usageHeader prog) flags) @@ -103,6 +105,7 @@ data Flag | FlagNamesOnly | FlagIgnoreCase | FlagNoUserDb + | FlagVerbosity (Maybe String) deriving Eq flags :: [OptDescr Flag] @@ -132,9 +135,23 @@ flags = [ Option [] ["names-only"] (NoArg FlagNamesOnly) "only print package names, not versions; can only be used with list --simple-output", Option [] ["ignore-case"] (NoArg FlagIgnoreCase) - "ignore case for substring matching" + "ignore case for substring matching", + Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity") + "verbosity level (0-2, default 1)" ] +data Verbosity = Silent | Normal | Verbose + deriving (Show, Eq, Ord) + +getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity +getVerbosity v [] = Right v +getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs +getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs +getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs +getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs +getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v) +getVerbosity v (_ : fs) = getVerbosity v fs + deprecFlags :: [OptDescr Flag] deprecFlags = [ -- put deprecated flags here @@ -170,6 +187,11 @@ usageHeader prog = substProg prog $ " all the registered versions will be listed in ascending order.\n" ++ " Accepts the --simple-output flag.\n" ++ "\n" ++ + " $p dot\n" ++ + " Generate a graph of the package dependencies in a form suitable\n" ++ + " for input for the graphviz tools. For example, to generate a PDF" ++ + " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++ + "\n" ++ " $p find-module {module}\n" ++ " List registered packages exposing module {module} in the global\n" ++ " database, and also the user database if --user is given.\n" ++ @@ -208,7 +230,7 @@ usageHeader prog = substProg prog $ " entirely. When multiple of these options are given, the rightmost\n"++ " one is used as the database to act upon.\n"++ "\n"++ - " Commands that query the package database (list, latest, describe,\n"++ + " Commands that query the package database (list, tree, latest, describe,\n"++ " field) operate on the list of databases specified by the flags\n"++ " --user, --global, and --package-conf. If none of these flags are\n"++ " given, the default is --global --user.\n"++ @@ -223,12 +245,13 @@ substProg prog (c:xs) = c : substProg prog xs -- ----------------------------------------------------------------------------- -- Do the business -data Force = ForceAll | ForceFiles | NoForce +data Force = NoForce | ForceFiles | ForceAll | CannotForce + deriving (Eq,Ord) data PackageArg = Id PackageIdentifier | Substring String (String->Bool) -runit :: [Flag] -> [String] -> IO () -runit cli nonopts = do +runit :: Verbosity -> [Flag] -> [String] -> IO () +runit verbosity cli nonopts = do installSignalHandlers -- catch ^C and clean up prog <- getProgramName let @@ -274,28 +297,30 @@ runit cli nonopts = do glob filename >>= print #endif ["register", filename] -> - registerPackage filename cli auto_ghci_libs False force + registerPackage filename verbosity cli auto_ghci_libs False force ["update", filename] -> - registerPackage filename cli auto_ghci_libs True force + registerPackage filename verbosity cli auto_ghci_libs True force ["unregister", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - unregisterPackage pkgid cli force + unregisterPackage pkgid verbosity cli force ["expose", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - exposePackage pkgid cli force + exposePackage pkgid verbosity cli force ["hide", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - hidePackage pkgid cli force + hidePackage pkgid verbosity cli force ["list"] -> do - listPackages cli Nothing Nothing + listPackages verbosity cli Nothing Nothing ["list", pkgid_str] -> case substringCheck pkgid_str of Nothing -> do pkgid <- readGlobPkgId pkgid_str - listPackages cli (Just (Id pkgid)) Nothing - Just m -> listPackages cli (Just (Substring pkgid_str m)) Nothing + listPackages verbosity cli (Just (Id pkgid)) Nothing + Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing + ["dot"] -> do + showPackageDot verbosity cli ["find-module", moduleName] -> do let match = maybe (==moduleName) id (substringCheck moduleName) - listPackages cli Nothing (Just match) + listPackages verbosity cli Nothing (Just match) ["latest", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str latestPackage cli pkgid @@ -337,7 +362,7 @@ parseGlobPackageId = parse +++ (do n <- parse - string "-*" + _ <- string "-*" return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) -- globVersion means "all versions" @@ -376,19 +401,14 @@ getPkgDatabases modify my_flags = do let err_msg = "missing --global-conf option, location of global package.conf unknown\n" global_conf <- case [ f | FlagGlobalConfig f <- my_flags ] of - [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe" + [] -> do mb_dir <- getLibDir case mb_dir of Nothing -> die err_msg Just dir -> - do let path1 = dir "package.conf" - path2 = dir ".." ".." ".." - "inplace-datadir" - "package.conf" - exists1 <- doesFileExist path1 - exists2 <- doesFileExist path2 - if exists1 then return path1 - else if exists2 then return path2 - else die "Can't find package.conf" + do let path = dir "package.conf" + exists <- doesFileExist path + unless exists $ die "Can't find package.conf" + return path fs -> return (last fs) let global_conf_dir = global_conf ++ ".d" @@ -475,31 +495,35 @@ getPkgDatabases modify my_flags = do in return (flag_stack, to_modify) - db_stack <- mapM readParseDatabase final_stack + db_stack <- mapM (readParseDatabase mb_user_conf) final_stack return (db_stack, to_modify) -readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB) -readParseDatabase filename = do - str <- readFile filename `catchIO` \_ -> return emptyPackageConfig - let packages = map convertPackageInfoIn $ read str - Exception.evaluate packages - `catchError` \e-> - die ("error while parsing " ++ filename ++ ": " ++ show e) - return (filename,packages) - -emptyPackageConfig :: String -emptyPackageConfig = "[]" +readParseDatabase :: Maybe (PackageDBName,Bool) + -> PackageDBName + -> IO (PackageDBName,PackageDB) +readParseDatabase mb_user_conf filename + -- the user database (only) is allowed to be non-existent + | Just (user_conf,False) <- mb_user_conf, filename == user_conf + = return (filename, []) + | otherwise + = do str <- readFile filename + let packages = map convertPackageInfoIn $ read str + _ <- Exception.evaluate packages + `catchError` \e-> + die ("error while parsing " ++ filename ++ ": " ++ show e) + return (filename,packages) -- ----------------------------------------------------------------------------- -- Registering registerPackage :: FilePath + -> Verbosity -> [Flag] -> Bool -- auto_ghci_libs -> Bool -- update -> Force -> IO () -registerPackage input my_flags auto_ghci_libs update force = do +registerPackage input verbosity my_flags auto_ghci_libs update force = do (db_stack, Just to_modify) <- getPkgDatabases True my_flags let db_to_operate_on = my_head "register" $ @@ -508,21 +532,19 @@ registerPackage input my_flags auto_ghci_libs update force = do s <- case input of "-" -> do - putStr "Reading package info from stdin ... " + when (verbosity >= Normal) $ + putStr "Reading package info from stdin ... " getContents f -> do - putStr ("Reading package info from " ++ show f ++ " ... ") + when (verbosity >= Normal) $ + putStr ("Reading package info from " ++ show f ++ " ... ") readFile f expanded <- expandEnvVars s force pkg <- parsePackageInfo expanded - putStrLn "done." - - let unversioned_deps = filter (not . realVersion) (depends pkg) - unless (null unversioned_deps) $ - die ("Unversioned dependencies found: " ++ - unwords (map display unversioned_deps)) + when (verbosity >= Normal) $ + putStrLn "done." let truncated_stack = dropWhile ((/= to_modify).fst) db_stack -- truncate the stack for validation, because we don't allow @@ -530,7 +552,7 @@ registerPackage input my_flags auto_ghci_libs update force = do validatePackageConfig pkg truncated_stack auto_ghci_libs update force let new_details = filter not_this (snd db_to_operate_on) ++ [pkg] not_this p = package p /= package pkg - writeNewConfig to_modify new_details + writeNewConfig verbosity to_modify new_details parsePackageInfo :: String @@ -545,22 +567,23 @@ parsePackageInfo str = -- ----------------------------------------------------------------------------- -- Exposing, Hiding, Unregistering are all similar -exposePackage :: PackageIdentifier -> [Flag] -> Force -> IO () +exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () exposePackage = modifyPackage (\p -> [p{exposed=True}]) -hidePackage :: PackageIdentifier -> [Flag] -> Force -> IO () +hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () hidePackage = modifyPackage (\p -> [p{exposed=False}]) -unregisterPackage :: PackageIdentifier -> [Flag] -> Force -> IO () +unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () unregisterPackage = modifyPackage (\_ -> []) modifyPackage :: (InstalledPackageInfo -> [InstalledPackageInfo]) -> PackageIdentifier + -> Verbosity -> [Flag] -> Force -> IO () -modifyPackage fn pkgid my_flags force = do +modifyPackage fn pkgid verbosity my_flags force = do (db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags ((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) -- let ((db_name, pkgs) : rest_of_stack) = db_stack @@ -585,13 +608,15 @@ modifyPackage fn pkgid my_flags force = do " would break the following packages: " ++ unwords (map display newly_broken)) - writeNewConfig db_name new_config + writeNewConfig verbosity db_name new_config -- ----------------------------------------------------------------------------- -- Listing packages -listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO () -listPackages my_flags mPackageName mModuleName = do +listPackages :: Verbosity -> [Flag] -> Maybe PackageArg + -> Maybe (String->Bool) + -> IO () +listPackages verbosity 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 @@ -616,29 +641,60 @@ listPackages my_flags mPackageName mModuleName = do match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) pkg_map = allPackagesInStack db_stack - show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map) + broken = map package (brokenPackages pkg_map) - show_func (reverse db_stack_sorted) + show_func = if simple_output then show_simple else mapM_ show_normal - where show_normal pkg_map (db_name,pkg_confs) = + show_normal (db_name,pkg_confs) = hPutStrLn stdout (render $ text db_name <> colon $$ nest 4 packages ) - where packages = fsep (punctuate comma (map pp_pkg pkg_confs)) - broken = map package (brokenPackages pkg_map) + where packages + | verbosity >= Verbose = vcat (map pp_pkg pkg_confs) + | otherwise = fsep (punctuate comma (map pp_pkg pkg_confs)) pp_pkg p | package p `elem` broken = braces doc | exposed p = doc | otherwise = parens doc - where doc = text (display (package p)) + where doc | verbosity >= Verbose = pkg <+> parens ipid + | otherwise = pkg + where + InstalledPackageId ipid_str = installedPackageId p + ipid = text ipid_str + pkg = text (display (package p)) + + show_simple = simplePackageList my_flags . allPackagesInStack + + when (not (null broken) && verbosity /= Silent) $ do + prog <- getProgramName + putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.") - show_simple db_stack = do - let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName - else display - pkgs = map showPkg $ sortBy compPkgIdVer $ - map package (allPackagesInStack db_stack) - when (not (null pkgs)) $ - hPutStrLn stdout $ concat $ intersperse " " pkgs + show_func (reverse db_stack_sorted) + +simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO () +simplePackageList my_flags pkgs = do + let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName + else display + strs = map showPkg $ sortBy compPkgIdVer $ map package pkgs + when (not (null pkgs)) $ + hPutStrLn stdout $ concat $ intersperse " " strs + +showPackageDot :: Verbosity -> [Flag] -> IO () +showPackageDot _verbosity myflags = do + (db_stack, _) <- getPkgDatabases False myflags + let all_pkgs = allPackagesInStack db_stack + ipix = PackageIndex.listToInstalledPackageIndex all_pkgs + + putStrLn "digraph {" + let quote s = '"':s ++ "\"" + mapM_ putStrLn [ quote from ++ " -> " ++ quote to + | p <- all_pkgs, + let from = display (package p), + depid <- depends p, + Just dep <- [PackageIndex.lookupInstalledPackage ipix depid], + let to = display (package dep) + ] + putStrLn "}" -- ----------------------------------------------------------------------------- -- Prints the highest (hidden or exposed) version of a package @@ -692,6 +748,10 @@ pid `matches` pid' = (pkgName pid == pkgName pid') && (pkgVersion pid == pkgVersion pid' || not (realVersion pid)) +realVersion :: PackageIdentifier -> Bool +realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] + -- when versionBranch == [], this is a glob + matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool (Id pid) `matchesPkg` pkg = pid `matches` package pkg (Substring _ m) `matchesPkg` pkg = m (display (package pkg)) @@ -773,40 +833,64 @@ 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 = allPackagesInStack db_stack - broken_pkgs = brokenPackages pkgs - broken_ids = map package broken_pkgs - broken_why = [ (package p, filter (`elem` broken_ids) (depends p)) - | p <- broken_pkgs ] - mapM_ (putStrLn . render . show_func) broken_why - where - show_func | FlagSimpleOutput `elem` my_flags = show_simple - | otherwise = show_normal - show_simple (pid,deps) = - text (display pid) <> colon - <+> fsep (punctuate comma (map (text . display) deps)) - show_normal (pid,deps) = - text "package" <+> text (display pid) <+> text "has missing dependencies:" - $$ nest 4 (fsep (punctuate comma (map (text . display) deps))) + let simple_output = FlagSimpleOutput `elem` my_flags + + let pkgs = allPackagesInStack db_stack -brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] -brokenPackages pkgs = go [] pkgs + checkPackage p = do + (_,es) <- runValidate $ checkPackageConfig p db_stack False True + if null es + then return [] + else do + when (not simple_output) $ do + reportError ("There are problems in package " ++ display (package p) ++ ":") + _ <- reportValidateErrors es " " Nothing + return () + return [p] + + broken_pkgs <- concat `fmap` mapM checkPackage pkgs + + let filterOut pkgs1 pkgs2 = filter not_in pkgs2 + where not_in p = package p `notElem` all_ps + all_ps = map package pkgs1 + + let not_broken_pkgs = filterOut broken_pkgs pkgs + (_, trans_broken_pkgs) = closure [] not_broken_pkgs + all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs + + when (not (null all_broken_pkgs)) $ do + if simple_output + then simplePackageList my_flags all_broken_pkgs + else do + reportError ("\nThe following packages are broken, either because they have a problem\n"++ + "listed above, or because they depend on a broken package.") + mapM_ (hPutStrLn stderr . display . package) all_broken_pkgs + + when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1) + + +closure :: [InstalledPackageInfo] -> [InstalledPackageInfo] + -> ([InstalledPackageInfo], [InstalledPackageInfo]) +closure pkgs db_stack = go pkgs db_stack where go avail not_avail = case partition (depsAvailable avail) not_avail of - ([], not_avail') -> not_avail' + ([], not_avail') -> (avail, not_avail') (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo -> Bool depsAvailable pkgs_ok pkg = null dangling where dangling = filter (`notElem` pids) (depends pkg) - pids = map package pkgs_ok + pids = map installedPackageId pkgs_ok -- we want mutually recursive groups of package to show up -- as broken. (#1750) +brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] +brokenPackages pkgs = snd (closure [] pkgs) + -- ----------------------------------------------------------------------------- -- Manipulating package.conf files @@ -827,9 +911,10 @@ convertPackageInfoIn hiddenModules = map convert h } where convert = fromJust . simpleParse -writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO () -writeNewConfig filename packages = do - hPutStr stdout "Writing new package config file... " +writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO () +writeNewConfig verbosity filename packages = do + when (verbosity >= Normal) $ + hPutStr stdout "Writing new package config file... " createDirectoryIfMissing True $ takeDirectory filename let shown = concat $ intersperse ",\n " $ map (show . convertPackageInfoOut) packages @@ -839,45 +924,108 @@ writeNewConfig filename packages = do if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e - hPutStrLn stdout "done." + when (verbosity >= Normal) $ + hPutStrLn stdout "done." ----------------------------------------------------------------------------- -- Sanity-check a new package config, and automatically build GHCi libs -- if requested. +type ValidateError = (Force,String) + +newtype Validate a = V { runValidate :: IO (a, [ValidateError]) } + +instance Monad Validate where + return a = V $ return (a, []) + m >>= k = V $ do + (a, es) <- runValidate m + (b, es') <- runValidate (k a) + return (b,es++es') + +verror :: Force -> String -> Validate () +verror f s = V (return ((),[(f,s)])) + +liftIO :: IO a -> Validate a +liftIO k = V (k >>= \a -> return (a,[])) + +-- returns False if we should die +reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool +reportValidateErrors es prefix mb_force = do + oks <- mapM report es + return (and oks) + where + report (f,s) + | Just force <- mb_force + = if (force >= f) + then do reportError (prefix ++ s ++ " (ignoring)") + return True + else if f < CannotForce + then do reportError (prefix ++ s ++ " (use --force to override)") + return False + else do reportError err + return False + | otherwise = do reportError err + return False + where + err = prefix ++ s + validatePackageConfig :: InstalledPackageInfo -> PackageDBStack -> Bool -- auto-ghc-libs - -> Bool -- update + -> Bool -- update, or check -> Force -> IO () validatePackageConfig pkg db_stack auto_ghci_libs update force = do + (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update + ok <- reportValidateErrors es (display (package pkg) ++ ": ") (Just force) + when (not ok) $ exitWith (ExitFailure 1) + +checkPackageConfig :: InstalledPackageInfo + -> PackageDBStack + -> Bool -- auto-ghc-libs + -> Bool -- update, or check + -> Validate () +checkPackageConfig pkg db_stack auto_ghci_libs update = do + checkInstalledPackageId pkg db_stack update checkPackageId pkg - checkDuplicates db_stack pkg update force - mapM_ (checkDep db_stack force) (depends pkg) - checkDuplicateDepends 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) + checkDuplicates db_stack pkg update + mapM_ (checkDep db_stack) (depends pkg) + checkDuplicateDepends (depends pkg) + mapM_ (checkDir "import-dirs") (importDirs pkg) + mapM_ (checkDir "library-dirs") (libraryDirs pkg) + mapM_ (checkDir "include-dirs") (includeDirs pkg) + checkModules pkg + mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) -- ToDo: check these somehow? -- extra_libraries :: [String], -- c_includes :: [String], +checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool + -> Validate () +checkInstalledPackageId ipi db_stack update = do + let ipid@(InstalledPackageId str) = installedPackageId ipi + when (null str) $ verror CannotForce "missing id field" + let dups = [ p | p <- allPackagesInStack db_stack, + installedPackageId p == ipid ] + when (not update && not (null dups)) $ + verror CannotForce $ + "package(s) with this id already exist: " ++ + unwords (map (display.packageId) dups) + -- 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 -- 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 () +checkPackageId :: InstalledPackageInfo -> Validate () checkPackageId ipi = 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) + [] -> verror CannotForce ("invalid package identifier: " ++ str) + _ -> verror CannotForce ("ambiguous package identifier: " ++ str) -checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Force -> IO () -checkDuplicates db_stack pkg update force = do +checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate () +checkDuplicates db_stack pkg update = do let pkgid = package pkg (_top_db_name, pkgs) : _ = db_stack @@ -885,80 +1033,88 @@ 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 " ++ display pkgid ++ " is already installed") + verror CannotForce $ + "package " ++ display pkgid ++ " is already installed" let uncasep = map toLower . display dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs) - when (not update && not (null dups)) $ dieOrForceAll force $ + when (not update && not (null dups)) $ verror ForceAll $ "Package names may be treated case-insensitively in the future.\n"++ "Package " ++ display pkgid ++ " overlaps with: " ++ unwords (map display dups) -checkDir :: Force -> String -> IO () -checkDir force d +checkDir :: String -> String -> Validate () +checkDir thisfield d | "$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) - (dieOrForceFile force (d ++ " doesn't exist or isn't a directory")) - -checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO () -checkDep db_stack force pkgid - | pkgid `elem` pkgids || (not real_version && name_exists) = return () - | otherwise = dieOrForceAll force ("dependency " ++ display pkgid - ++ " doesn't exist") + there <- liftIO $ doesDirectoryExist d + when (not there) $ + verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory") + +checkDep :: PackageDBStack -> InstalledPackageId -> Validate () +checkDep db_stack pkgid + | pkgid `elem` pkgids = return () + | otherwise = verror ForceAll ("dependency \"" ++ display 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 = allPackagesInStack db_stack - pkgids = map package all_pkgs + pkgids = map installedPackageId all_pkgs -checkDuplicateDepends :: Force -> [PackageIdentifier] -> IO () -checkDuplicateDepends force deps +checkDuplicateDepends :: [InstalledPackageId] -> Validate () +checkDuplicateDepends deps | null dups = return () - | otherwise = dieOrForceAll force ("package has duplicate dependencies: " ++ + | otherwise = verror ForceAll ("package has duplicate dependencies: " ++ unwords (map display dups)) where dups = [ p | (p:_:_) <- group (sort deps) ] -realVersion :: PackageIdentifier -> Bool -realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] - -checkHSLib :: [String] -> Bool -> Force -> String -> IO () -checkHSLib dirs auto_ghci_libs force lib = do +checkHSLib :: [String] -> Bool -> String -> Validate () +checkHSLib dirs auto_ghci_libs 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 - [] -> 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 + m <- liftIO $ doesFileExistOnPath batch_lib_file dirs + case m of + Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++ + " on library path") + Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs + +doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath) +doesFileExistOnPath file path = go path + where go [] = return Nothing + go (p:ps) = do b <- doesFileExistIn file p + if b then return (Just p) else go ps + +doesFileExistIn :: String -> String -> IO Bool +doesFileExistIn lib d | "$topdir" `isPrefixOf` d = return True | "$httptopdir" `isPrefixOf` d = return True - | otherwise = doesFileExist (d ++ '/':lib) + | otherwise = doesFileExist (d lib) + +checkModules :: InstalledPackageInfo -> Validate () +checkModules pkg = do + mapM_ findModule (exposedModules pkg ++ hiddenModules pkg) + where + findModule modl = do + -- there's no .hi file for GHC.Prim + if modl == fromString "GHC.Prim" then return () else do + let file = toFilePath modl <.> "hi" + m <- liftIO $ doesFileExistOnPath file (importDirs pkg) + when (isNothing m) $ + verror ForceFiles ("file " ++ file ++ " is missing") checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file | otherwise = do - 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 () - where - ghci_lib_file = lib ++ ".o" + m <- doesFileExistOnPath ghci_lib_file dirs + when (isNothing m && ghci_lib_file /= "HSrts.o") $ + hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file) + where + ghci_lib_file = lib <.> "o" -- automatically build the GHCi version of a batch lib, -- using ld --whole-archive. @@ -971,7 +1127,7 @@ autoBuildGHCiLib dir batch_file ghci_file = do #if defined(darwin_HOST_OS) r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file] #elif defined(mingw32_HOST_OS) - execDir <- getExecDir "/bin/ghc-pkg.exe" + execDir <- getLibDir r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] #else r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] @@ -1063,13 +1219,11 @@ 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)") +ignoreError s = reportError (s ++ " (ignoring)") + +reportError :: String -> IO () +reportError s = do hFlush stdout; hPutStrLn stderr s dieForcible :: String -> IO () dieForcible s = die (s ++ " (use --force to override)") @@ -1088,26 +1242,33 @@ 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) +getLibDir :: IO (Maybe String) +getLibDir = fmap (fmap ( "lib")) $ getExecDir "/bin/ghc-pkg.exe" + -- (getExecDir cmd) returns the directory in which the current -- 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))))) - where - len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32. +getExecDir :: String -> IO (Maybe String) +getExecDir cmd = + getExecPath >>= maybe (return Nothing) removeCmdSuffix + where initN n = reverse . drop n . reverse + removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath + +getExecPath :: IO (Maybe String) +getExecPath = + allocaArray len $ \buf -> do + ret <- getModuleFileName nullPtr buf len + if ret == 0 then return Nothing + else liftM Just $ peekCString buf + where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. + +foreign import stdcall unsafe "GetModuleFileNameA" + getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 #else -getExecDir :: String -> IO (Maybe String) -getExecDir _ = return Nothing +getLibDir :: IO (Maybe String) +getLibDir = return Nothing #endif ----------------------------------------- @@ -1121,8 +1282,8 @@ installSignalHandlers = do (Exception.ErrorCall "interrupted") -- #if !defined(mingw32_HOST_OS) - installHandler sigQUIT (Catch interrupt) Nothing - installHandler sigINT (Catch interrupt) Nothing + _ <- installHandler sigQUIT (Catch interrupt) Nothing + _ <- installHandler sigINT (Catch interrupt) Nothing return () #elif __GLASGOW_HASKELL__ >= 603 -- GHC 6.3+ has support for console events on Windows @@ -1134,7 +1295,7 @@ installSignalHandlers = do sig_handler Break = interrupt sig_handler _ = return () - installHandler (Catch sig_handler) + _ <- installHandler (Catch sig_handler) return () #else return () -- nothing @@ -1145,12 +1306,12 @@ isInfixOf :: (Eq a) => [a] -> [a] -> Bool isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) #endif -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -catchIO = Exception.catch - #if mingw32_HOST_OS || mingw32_TARGET_OS throwIOIO :: Exception.IOException -> IO a throwIOIO = Exception.throwIO + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch #endif catchError :: IO a -> (String -> IO a) -> IO a @@ -1216,8 +1377,12 @@ openNewFile dir template = do oflags = rw_flags .|. o_EXCL +#if __GLASGOW_HASKELL__ < 611 + withFilePath = withCString +#endif + findTempName x = do - fd <- withCString filepath $ \ f -> + fd <- withFilePath filepath $ \ f -> c_open f oflags 0o666 if fd < 0 then do