X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=b1aaaba7b09d0c11b38d3e688d00294f6f4cd8b6;hp=2296c670dcc64d127557853ccd1d922ca97b6c1f;hb=34cc75e1a62638f2833815746ebce0a9114dc26b;hpb=8396eb36ed1aa4ca23b44afba163e41282e01096 diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 2296c67..b1aaaba 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -16,6 +16,7 @@ module Main (main) where import Version ( version, targetOS, targetARCH ) +import Distribution.ModuleName hiding (main) import Distribution.InstalledPackageInfo hiding (depends) import Distribution.Compat.ReadP import Distribution.ParseUtils @@ -32,7 +33,11 @@ import Prelude import System.Console.GetOpt import Text.PrettyPrint +#if __GLASGOW_HASKELL__ >= 609 import qualified Control.Exception as Exception +#else +import qualified Control.Exception.Extensible as Exception +#endif import Data.Maybe import Data.Char ( isSpace, toLower ) @@ -43,24 +48,20 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs, getProgName, getEnv ) import System.IO import System.IO.Error (try) -import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub, - unfoldr, break, partition ) -#if __GLASGOW_HASKELL__ > 604 -import Data.List ( isInfixOf ) -#else -import Data.List ( tails ) -#endif +import Data.List import Control.Concurrent -#ifdef mingw32_HOST_OS import Foreign -import Foreign.C.String +import Foreign.C +#ifdef mingw32_HOST_OS import GHC.ConsoleHandler #else -import System.Posix +import System.Posix hiding (fdToHandle) #endif -import IO ( isPermissionError, isDoesNotExistError ) +import IO ( isPermissionError ) +import System.Posix.Internals +import GHC.Handle (fdToHandle) #if defined(GLOB) import System.Process(runInteractiveCommand) @@ -102,6 +103,7 @@ data Flag | FlagSimpleOutput | FlagNamesOnly | FlagIgnoreCase + | FlagNoUserDb deriving Eq flags :: [OptDescr Flag] @@ -114,6 +116,8 @@ flags = [ "use the specified package config file", Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE") "location of the global package config", + Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb) + "never read the user package database", Option [] ["force"] (NoArg FlagForce) "ignore missing dependencies, directories, and libraries", Option [] ["force-files"] (NoArg FlagForceFiles) @@ -220,7 +224,8 @@ 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) @@ -356,14 +361,15 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] } type PackageDBName = FilePath type PackageDB = [InstalledPackageInfo] -type PackageDBStack = [(PackageDBName,PackageDB)] +type NamedPackageDB = (PackageDBName, PackageDB) +type PackageDBStack = [NamedPackageDB] -- 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 :: Bool -> [Flag] -> IO (PackageDBStack, Maybe PackageDBName) 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 @@ -372,19 +378,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" @@ -397,18 +398,21 @@ getPkgDatabases modify my_flags = do , isSuffixOf ".conf" file] else return [] + let no_user_db = FlagNoUserDb `elem` my_flags + -- get the location of the user package database, and create it if necessary -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set) appdir <- try $ getAppUserDataDirectory "ghc" mb_user_conf <- + if no_user_db then return Nothing else case appdir of Right dir -> do let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version user_conf = dir subdir "package.conf" user_exists <- doesFileExist user_conf return (Just (user_conf,user_exists)) - Left ex -> + Left _ -> return Nothing -- If the user database doesn't exist, and this command isn't a @@ -425,7 +429,7 @@ getPkgDatabases modify my_flags = do Right path | last cs == "" -> init cs ++ sys_databases | otherwise -> cs - where cs = splitSearchPath path + 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. @@ -433,20 +437,20 @@ getPkgDatabases modify my_flags = do let db_flags = [ f | Just f <- map is_db_flag my_flags ] where is_db_flag FlagUser - | Just (user_conf,user_exists) <- mb_user_conf + | Just (user_conf, _user_exists) <- mb_user_conf = Just user_conf is_db_flag FlagGlobal = Just virt_global_conf is_db_flag (FlagConfig f) = Just f is_db_flag _ = Nothing - final_stack <- + (final_stack, to_modify) <- if not modify then -- For a "read" command, we use all the databases -- specified on the command line. If there are no -- command-line flags specifying databases, the default -- is to use all the ones we know about. - if null db_flags then return env_stack - else return (reverse (nub db_flags)) + if null db_flags then return (env_stack, Nothing) + else return (reverse (nub db_flags), Nothing) else let -- For a "modify" command, treat all the databases as -- a stack, where we are modifying the top one, but it @@ -460,28 +464,31 @@ getPkgDatabases modify my_flags = do [ f | FlagConfig f <- reverse my_flags ] ++ env_stack - 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.") + -- the database we actually modify is the one mentioned + -- rightmost on the command-line. + to_modify = if null db_flags + then Just virt_global_conf + else Just (last db_flags) in - if null db_flags - then modifying virt_global_conf - else modifying (head db_flags) - - db_stack <- mapM readParseDatabase final_stack - return db_stack - -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 = "[]" + return (flag_stack, to_modify) + + db_stack <- mapM (readParseDatabase mb_user_conf) final_stack + return (db_stack, to_modify) + +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 @@ -493,12 +500,11 @@ registerPackage :: FilePath -> Force -> IO () registerPackage input my_flags auto_ghci_libs update force = do - db_stack <- getPkgDatabases True my_flags + (db_stack, Just to_modify) <- getPkgDatabases True my_flags let - db_to_operate_on = my_head "db" db_stack - db_filename = fst db_to_operate_on + db_to_operate_on = my_head "register" $ + filter ((== to_modify).fst) db_stack -- - s <- case input of "-" -> do @@ -513,10 +519,18 @@ registerPackage input my_flags auto_ghci_libs update force = do pkg <- parsePackageInfo expanded putStrLn "done." - validatePackageConfig pkg db_stack auto_ghci_libs update force + let unversioned_deps = filter (not . realVersion) (depends pkg) + unless (null unversioned_deps) $ + die ("Unversioned dependencies found: " ++ + unwords (map display unversioned_deps)) + + let truncated_stack = dropWhile ((/= to_modify).fst) db_stack + -- truncate the stack for validation, because we don't allow + -- packages lower in the stack to refer to those higher up. + 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 db_filename new_details + writeNewConfig to_modify new_details parsePackageInfo :: String @@ -547,19 +561,25 @@ modifyPackage -> Force -> IO () modifyPackage fn pkgid my_flags force = do - db_stack <- getPkgDatabases True{-modify-} my_flags - let old_broken = brokenPackages (allPackagesInStack db_stack) - let ((db_name, pkgs) : rest_of_stack) = db_stack - ps <- findPackages [(db_name,pkgs)] (Id pkgid) - let pids = map package ps - let new_config = concat (map modify pkgs) + (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 +-- ps <- findPackages [(db_name,pkgs)] (Id pkgid) + let + pids = map package ps modify pkg | package pkg `elem` pids = fn pkg | otherwise = [pkg] - let new_stack = (db_name,new_config) : rest_of_stack + new_config = concat (map modify pkgs) + + let + old_broken = brokenPackages (allPackagesInStack db_stack) + rest_of_stack = [ (nm, mypkgs) + | (nm, mypkgs) <- db_stack, nm /= db_name ] + new_stack = (db_name,new_config) : rest_of_stack new_broken = map package (brokenPackages (allPackagesInStack new_stack)) newly_broken = filter (`notElem` map package old_broken) new_broken - + -- when (not (null newly_broken)) $ dieOrForceAll force ("unregistering " ++ display pkgid ++ " would break the following packages: " @@ -573,7 +593,7 @@ modifyPackage fn pkgid my_flags force = do listPackages :: [Flag] -> Maybe PackageArg -> Maybe (String->Bool) -> IO () listPackages my_flags mPackageName mModuleName = do let simple_output = FlagSimpleOutput `elem` my_flags - db_stack <- getPkgDatabases False 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)) @@ -612,20 +632,22 @@ listPackages my_flags mPackageName mModuleName = do | otherwise = parens doc where doc = text (display (package p)) - 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_simple = simplePackageList my_flags . allPackagesInStack + +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 -- ----------------------------------------------------------------------------- -- Prints the highest (hidden or exposed) version of a package latestPackage :: [Flag] -> PackageIdentifier -> IO () latestPackage my_flags pkgid = do - db_stack <- getPkgDatabases False my_flags + (db_stack, _) <- getPkgDatabases False my_flags ps <- findPackages db_stack (Id pkgid) show_pkg (sortBy compPkgIdVer (map package ps)) where @@ -637,13 +659,13 @@ latestPackage my_flags pkgid = do describePackage :: [Flag] -> PackageArg -> IO () describePackage my_flags pkgarg = do - db_stack <- getPkgDatabases False my_flags + (db_stack, _) <- getPkgDatabases False my_flags ps <- findPackages db_stack pkgarg doDump ps dumpPackages :: [Flag] -> IO () dumpPackages my_flags = do - db_stack <- getPkgDatabases False my_flags + (db_stack, _) <- getPkgDatabases False my_flags doDump (allPackagesInStack db_stack) doDump :: [InstalledPackageInfo] -> IO () @@ -652,13 +674,20 @@ doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo -- PackageId is can have globVersion for the version findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] findPackages db_stack pkgarg - = case [ p | p <- all_pkgs, pkgarg `matchesPkg` p ] of - [] -> dieWith 2 ("cannot find package " ++ pkg_msg pkgarg) + = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg + +findPackagesByDB :: PackageDBStack -> PackageArg + -> IO [(NamedPackageDB, [InstalledPackageInfo])] +findPackagesByDB db_stack pkgarg + = case [ (db, matched) + | db@(_, pkgs) <- db_stack, + let matched = filter (pkgarg `matchesPkg`) pkgs, + not (null matched) ] of + [] -> die ("cannot find package " ++ pkg_msg pkgarg) ps -> return ps where - all_pkgs = allPackagesInStack db_stack pkg_msg (Id pkgid) = display pkgid - pkg_msg (Substring pkgpat _) = "matching "++pkgpat + pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat matches :: PackageIdentifier -> PackageIdentifier -> Bool pid `matches` pid' @@ -677,7 +706,7 @@ compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 describeField :: [Flag] -> PackageArg -> [String] -> IO () describeField my_flags pkgarg fields = do - db_stack <- getPkgDatabases False my_flags + (db_stack, _) <- getPkgDatabases False my_flags fns <- toFields fields ps <- findPackages db_stack pkgarg let top_dir = takeDirectory (fst (last db_stack)) @@ -743,33 +772,54 @@ strList = show checkConsistency :: [Flag] -> IO () checkConsistency my_flags = do - db_stack <- getPkgDatabases True my_flags + (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 -brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] -brokenPackages pkgs = go [] pkgs + let pkgs = allPackagesInStack db_stack + + 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 - (new_avail, not_avail) -> go (new_avail ++ avail) not_avail + ([], not_avail') -> (avail, not_avail') + (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo -> Bool @@ -780,6 +830,9 @@ brokenPackages pkgs = go [] pkgs -- 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 @@ -818,20 +871,70 @@ writeNewConfig filename packages = do -- 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 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) - 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], @@ -840,16 +943,16 @@ validatePackageConfig pkg db_stack auto_ghci_libs update force = do -- 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 @@ -857,33 +960,34 @@ 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")) + there <- liftIO $ doesDirectoryExist d + when (not there) $ + verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory") -checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO () -checkDep db_stack force pkgid +checkDep :: PackageDBStack -> PackageIdentifier -> Validate () +checkDep db_stack pkgid | pkgid `elem` pkgids || (not real_version && name_exists) = return () - | otherwise = dieOrForceAll force ("dependency " ++ display pkgid - ++ " doesn't exist") + | 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. @@ -895,34 +999,59 @@ checkDep db_stack force pkgid all_pkgs = allPackagesInStack db_stack pkgids = map package all_pkgs +checkDuplicateDepends :: [PackageIdentifier] -> Validate () +checkDuplicateDepends deps + | null dups = return () + | 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. @@ -935,7 +1064,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] @@ -1027,13 +1156,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)") @@ -1052,26 +1179,34 @@ 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 unDosifyPath = subst '\\' '/' + 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 ----------------------------------------- @@ -1081,10 +1216,11 @@ installSignalHandlers :: IO () installSignalHandlers = do threadid <- myThreadId let - interrupt = throwTo threadid (Exception.ErrorCall "interrupted") + interrupt = Exception.throwTo threadid + (Exception.ErrorCall "interrupted") -- #if !defined(mingw32_HOST_OS) - installHandler sigQUIT (Catch interrupt) Nothing + installHandler sigQUIT (Catch interrupt) Nothing installHandler sigINT (Catch interrupt) Nothing return () #elif __GLASGOW_HASKELL__ >= 603 @@ -1108,65 +1244,43 @@ isInfixOf :: (Eq a) => [a] -> [a] -> Bool isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) #endif -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#if __GLASGOW_HASKELL__ >= 609 -catchIO = Exception.catch -#else -catchIO io handler = io `Exception.catch` handler' - where handler' (Exception.IOException ioe) = handler ioe - handler' e = Exception.throw e -#endif - +#if mingw32_HOST_OS || mingw32_TARGET_OS throwIOIO :: Exception.IOException -> IO a -#if __GLASGOW_HASKELL__ >= 609 throwIOIO = Exception.throwIO -#else -throwIOIO ioe = Exception.throwIO (Exception.IOException ioe) + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch #endif catchError :: IO a -> (String -> IO a) -> IO a -#if __GLASGOW_HASKELL__ >= 609 -catchError io handler = io `Exception.catch` handler' - where handler' (Exception.ErrorCall err) = handler err -#else catchError io handler = io `Exception.catch` handler' where handler' (Exception.ErrorCall err) = handler err - handler' e = Exception.throw e -#endif - -onException :: IO a -> IO () -> IO a -#if __GLASGOW_HASKELL__ >= 609 -onException = Exception.onException -#else -onException io what = io `Exception.catch` \e -> do what - Exception.throw e -#endif -- copied from Cabal's Distribution.Simple.Utils, except that we want -- to use text files here, rather than binary files. writeFileAtomic :: FilePath -> String -> IO () writeFileAtomic targetFile content = do - (tmpFile, tmpHandle) <- openTempFile targetDir template - do hPutStr tmpHandle content - hClose tmpHandle + (newFile, newHandle) <- openNewFile targetDir template + do hPutStr newHandle content + hClose newHandle #if mingw32_HOST_OS || mingw32_TARGET_OS - renameFile tmpFile targetFile + renameFile newFile targetFile -- If the targetFile exists then renameFile will fail `catchIO` \err -> do exists <- doesFileExist targetFile if exists then do removeFile targetFile -- Big fat hairy race condition - renameFile tmpFile targetFile + renameFile newFile targetFile -- If the removeFile succeeds and the renameFile fails -- then we've lost the atomic property. else throwIOIO err #else - renameFile tmpFile targetFile + renameFile newFile targetFile #endif - `onException` do hClose tmpHandle - removeFile tmpFile + `Exception.onException` do hClose newHandle + removeFile newFile where template = targetName <.> "tmp" targetDir | null targetDir_ = "." @@ -1174,3 +1288,80 @@ writeFileAtomic targetFile content = do --TODO: remove this when takeDirectory/splitFileName is fixed -- to always return a valid dir (targetDir_,targetName) = splitFileName targetFile + +-- Ugh, this is a copy/paste of code from the base library, but +-- if uses 666 rather than 600 for the permissions. +openNewFile :: FilePath -> String -> IO (FilePath, Handle) +openNewFile dir template = do + pid <- c_getpid + findTempName pid + where + -- We split off the last extension, so we can use .foo.ext files + -- for temporary files (hidden on Unix OSes). Unfortunately we're + -- below filepath in the hierarchy here. + (prefix,suffix) = + case break (== '.') $ reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, "") -> (reverse rev_suffix, "") + -- Second case: template contains at least one '.'. Strip the + -- dot from the prefix and prepend it to the suffix (if we don't + -- do this, the unique number will get added after the '.' and + -- thus be part of the extension, which is wrong.) + (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) + -- Otherwise, something is wrong, because (break (== '.')) should + -- always return a pair with either the empty string or a string + -- beginning with '.' as the second component. + _ -> error "bug in System.IO.openTempFile" + + oflags = rw_flags .|. o_EXCL + + findTempName x = do + fd <- withCString filepath $ \ f -> + c_open f oflags 0o666 + if fd < 0 + then do + errno <- getErrno + if errno == eEXIST + then findTempName (x+1) + else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) + else do + -- XXX We want to tell fdToHandle what the filepath is, + -- as any exceptions etc will only be able to report the + -- fd currently + h <- +#if __GLASGOW_HASKELL__ >= 609 + fdToHandle fd +#else + fdToHandle (fromIntegral fd) +#endif + `Exception.onException` c_close fd + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = dir `combine` filename + +-- XXX Copied from GHC.Handle +std_flags, output_flags, rw_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +rw_flags = output_flags .|. o_RDWR + +-- | The function splits the given string to substrings +-- using 'isSearchPathSeparator'. +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 isSearchPathSeparator s