#else
import System.IO (try)
#endif
-import Data.List ( isPrefixOf, isSuffixOf, intersperse, groupBy, sortBy )
+import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy )
#ifdef mingw32_HOST_OS
import Foreign
#endif
#endif
+import IO ( isPermissionError, isDoesNotExistError )
+
-- -----------------------------------------------------------------------------
-- Entry point
db_to_operate_on = my_head "db" db_stack
db_filename = fst db_to_operate_on
--
- checkConfigAccess db_filename
s <-
case input of
putStrLn "done."
let pkg = resolveDeps db_stack pkg0
- overlaps <- validatePackageConfig pkg db_stack auto_ghci_libs update force
- new_details <- updatePackageDB db_stack overlaps (snd db_to_operate_on) pkg
- savePackageConfig db_filename
- maybeRestoreOldConfig db_filename $
+ validatePackageConfig pkg db_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
+ savingOldConfig db_filename $
writeNewConfig db_filename new_details
parsePackageInfo
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 $
+ savingOldConfig db_name $
writeNewConfig db_name new_config
-- -----------------------------------------------------------------------------
-- -----------------------------------------------------------------------------
-- Manipulating package.conf files
-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
-
writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
writeNewConfig filename packages = do
hPutStr stdout "Writing new package config file... "
- h <- openFile filename WriteMode
+ createDirectoryIfMissing True $ getFilenameDir 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
hPutStrLn h (show packages)
hClose h
hPutStrLn stdout "done."
-savePackageConfig :: FilePath -> IO ()
-savePackageConfig filename = do
+savingOldConfig :: FilePath -> IO () -> IO ()
+savingOldConfig filename io = 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
-> Bool -- auto-ghc-libs
-> Bool -- update
-> Bool -- force
- -> IO [PackageIdentifier]
+ -> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
checkPackageId pkg
- overlaps <- checkDuplicates db_stack pkg update force
+ 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)
- return overlaps
-- ToDo: check these somehow?
-- extra_libraries :: [String],
-- c_includes :: [String],
-- the version-less one
checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool
- -> IO [PackageIdentifier]
+ -> IO ()
checkDuplicates db_stack pkg update force = do
let
pkgid = package pkg
when (not update && (pkgid `elem` map package pkgs)) $
die ("package " ++ showPackageId pkgid ++ " is already installed")
- --
- -- Check whether any of the dependencies of the current package
- -- conflict with each other.
- --
- let
- all_pkgs = concat (map snd db_stack)
-
- allModules p = exposedModules p ++ hiddenModules p
-
- our_dependencies = closePackageDeps all_pkgs [pkg]
- all_dep_modules = concat (map (\p -> zip (allModules p) (repeat p))
- our_dependencies)
-
- overlaps = [ (m, map snd group)
- | group@((m,_):_) <- groupBy eqfst (sortBy cmpfst all_dep_modules),
- length group > 1 ]
- where eqfst (a,_) (b,_) = a == b
- cmpfst (a,_) (b,_) = a `compare` b
-
- when (not (null overlaps)) $
- diePrettyOrForce force $ vcat [
- text "package" <+> text (showPackageId (package pkg)) <+>
- text "has conflicting dependencies:",
- let complain_about (mod,ps) =
- text mod <+> text "is in the following packages:" <+>
- sep (map (text.showPackageId.package) ps)
- in
- nest 3 (vcat (map complain_about overlaps))
- ]
-
- --
- -- Now check whether exposing this package will result in conflicts, and
- -- Figure out which packages we need to hide to resolve the conflicts.
- --
- let
- closure_exposed_pkgs = closePackageDeps pkgs (filter exposed pkgs)
-
- new_dep_modules = concat $ map allModules $
- filter (\p -> package p `notElem`
- map package closure_exposed_pkgs) $
- our_dependencies
-
- pkgs_with_overlapping_modules =
- [ (p, overlapping_mods)
- | p <- closure_exposed_pkgs,
- let overlapping_mods =
- filter (`elem` new_dep_modules) (allModules p),
- (_:_) <- [overlapping_mods] --trick to get the non-empty ones
- ]
-
- to_hide = map package
- $ filter exposed
- $ closePackageDepsUpward pkgs
- $ map fst pkgs_with_overlapping_modules
-
- when (not update && exposed pkg && not (null pkgs_with_overlapping_modules)) $ do
- diePretty $ vcat [
- text "package" <+> text (showPackageId (package pkg)) <+>
- text "conflicts with the following packages, which are",
- text "either exposed or a dependency (direct or indirect) of an exposed package:",
- let complain_about (p, mods)
- = text (showPackageId (package p)) <+> text "contains modules" <+>
- sep (punctuate comma (map text mods)) in
- nest 3 (vcat (map complain_about pkgs_with_overlapping_modules)),
- text "Using 'update' instead of 'register' will cause the following packages",
- text "to be hidden, which will eliminate the conflict:",
- nest 3 (sep (map (text.showPackageId) to_hide))
- ]
-
- when (not (null to_hide)) $ do
- hPutStrLn stderr $ render $
- sep [text "Warning: hiding the following packages to avoid conflict: ",
- nest 2 (sep (map (text.showPackageId) to_hide))]
-
- return to_hide
-
-
-closure :: (a->[a]->Bool) -> (a -> [a]) -> [a] -> [a] -> [a]
-closure pred more [] res = res
-closure pred more (p:ps) res
- | p `pred` res = closure pred more ps res
- | otherwise = closure pred more (more p ++ ps) (p:res)
-
-closePackageDeps :: [InstalledPackageInfo] -> [InstalledPackageInfo]
- -> [InstalledPackageInfo]
-closePackageDeps db start
- = closure (\p ps -> package p `elem` map package ps) getDepends start []
- where
- getDepends p = [ pkg | dep <- depends p, pkg <- lookupPkg dep ]
- lookupPkg p = [ q | q <- db, p == package q ]
-
-closePackageDepsUpward :: [InstalledPackageInfo] -> [InstalledPackageInfo]
- -> [InstalledPackageInfo]
-closePackageDepsUpward db start
- = closure (\p ps -> package p `elem` map package ps) getUpwardDepends start []
- where
- getUpwardDepends p = [ pkg | pkg <- db, package p `elem` depends pkg ]
checkDir :: Bool -> String -> IO ()
hPutStrLn stderr (" done.")
-- -----------------------------------------------------------------------------
--- Updating the DB with the new package.
-
-updatePackageDB
- :: PackageDBStack -- the full stack
- -> [PackageIdentifier] -- packages to hide
- -> [InstalledPackageInfo] -- packages in *this* DB
- -> InstalledPackageInfo -- the new package
- -> IO [InstalledPackageInfo]
-updatePackageDB db_stack to_hide pkgs new_pkg = do
- let
- pkgid = package new_pkg
-
- pkgs' = [ maybe_hide p | p <- pkgs, package p /= pkgid ]
-
- -- When update is on, and we're exposing the new package,
- -- we hide any packages which conflict (see checkDuplicates)
- -- in the current DB.
- maybe_hide p
- | exposed new_pkg && package p `elem` to_hide = p{ exposed = False }
- | otherwise = p
- --
- return (pkgs'++ [new_pkg])
-
--- -----------------------------------------------------------------------------
-- Searching for modules
#if not_yet
| force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
| otherwise = die (s ++ " (use --force to override)")
-diePretty :: Doc -> IO ()
-diePretty doc = do
- hFlush stdout
- prog <- getProgramName
- hPutStrLn stderr $ render $ (text prog <> colon $$ nest 2 doc)
- exitWith (ExitFailure 1)
-
-diePrettyOrForce :: Bool -> Doc -> IO ()
-diePrettyOrForce force doc
- | force = do hFlush stdout; hPutStrLn stderr (render (doc $$ text "(ignoring)"))
- | otherwise = diePretty (doc $$ text "(use --force to override)")
-
-----------------------------------------
-- Cut and pasted from ghc/compiler/SysTools
pathSeparator = '/'
#endif
+getFilenameDir :: FilePath -> FilePath
+getFilenameDir fn = case break isPathSeparator (reverse fn) of
+ (xs, "") -> "."
+ (_, sep:ys) -> reverse ys
+
-- | The function splits the given string to substrings
-- using the 'searchPathSeparator'.
parseSearchPath :: String -> [FilePath]
projects / ghc-hetmet.git / blobdiff