X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=b2f7d1833cf66035d1b73f9a6c4c1a5ffbae2bdb;hb=5f0c4f9aa291cdc291fcdc0c4a30fdce1f91230d;hp=3b0b4385df83ccc7df329a45539aaa9b62b76eb3;hpb=cf81f273637efb4e2199493814ca57d9d447f839;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 3b0b438..b2f7d18 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -52,7 +52,7 @@ import System.IO.Error (try) #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 @@ -400,8 +400,9 @@ registerPackage input defines flags auto_ghci_libs update force = do 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 + 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 savePackageConfig db_filename maybeRestoreOldConfig db_filename $ writeNewConfig db_filename new_details @@ -618,16 +619,15 @@ validatePackageConfig :: InstalledPackageInfo -> 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], @@ -671,7 +671,7 @@ resolveDeps db_stack p = updateDeps p -- the version-less one checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool - -> IO [PackageIdentifier] + -> IO () checkDuplicates db_stack pkg update force = do let pkgid = package pkg @@ -682,103 +682,6 @@ checkDuplicates db_stack pkg update force = do 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 () @@ -851,30 +754,6 @@ autoBuildGHCiLib dir batch_file ghci_file = do 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 @@ -1062,18 +941,6 @@ dieOrForce force s | 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