X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=344a21edb89cd5278db8146a3496b270e5b1acfe;hb=e5e6f6a16796cba5e2b6bd376481cf2cd0ba9734;hp=0f026982264257b55eb931b1e7436a8d5a93cab7;hpb=0202ff18c5c6c612a7a0518a1e0bdb54d879a1f7;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 0f02698..344a21e 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -43,24 +43,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) @@ -359,14 +355,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 @@ -414,7 +411,7 @@ getPkgDatabases modify my_flags = do 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 @@ -431,7 +428,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. @@ -439,20 +436,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 @@ -466,16 +463,16 @@ 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) + return (flag_stack, to_modify) db_stack <- mapM readParseDatabase final_stack - return db_stack + return (db_stack, to_modify) readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB) readParseDatabase filename = do @@ -499,12 +496,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 @@ -519,10 +515,13 @@ 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 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 @@ -553,19 +552,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: " @@ -579,7 +584,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)) @@ -631,7 +636,7 @@ listPackages my_flags mPackageName mModuleName = do 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 @@ -643,13 +648,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 () @@ -658,13 +663,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' @@ -683,7 +695,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)) @@ -749,7 +761,7 @@ 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 @@ -774,8 +786,8 @@ brokenPackages pkgs = go [] pkgs 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') -> not_avail' + (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo -> Bool @@ -834,6 +846,7 @@ 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) + checkDuplicateDepends force (depends pkg) mapM_ (checkDir force) (importDirs pkg) mapM_ (checkDir force) (libraryDirs pkg) mapM_ (checkDir force) (includeDirs pkg) @@ -901,6 +914,14 @@ checkDep db_stack force pkgid all_pkgs = allPackagesInStack db_stack pkgids = map package all_pkgs +checkDuplicateDepends :: Force -> [PackageIdentifier] -> IO () +checkDuplicateDepends force deps + | null dups = return () + | otherwise = dieOrForceAll force ("package has duplicate dependencies: " ++ + unwords (map display dups)) + where + dups = [ p | (p:_:_) <- group (sort deps) ] + realVersion :: PackageIdentifier -> Bool realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] @@ -1123,12 +1144,14 @@ catchIO io handler = io `Exception.catch` handler' 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) #endif +#endif catchError :: IO a -> (String -> IO a) -> IO a #if __GLASGOW_HASKELL__ >= 609 @@ -1140,7 +1163,7 @@ catchError io handler = io `Exception.catch` handler' handler' e = Exception.throw e #endif -onException :: IO a -> IO () -> IO a +onException :: IO a -> IO b -> IO a #if __GLASGOW_HASKELL__ >= 609 onException = Exception.onException #else @@ -1153,26 +1176,26 @@ onException io what = io `Exception.catch` \e -> do what -- 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 + `onException` do hClose newHandle + removeFile newFile where template = targetName <.> "tmp" targetDir | null targetDir_ = "." @@ -1180,3 +1203,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 + `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