Remove most of the conflict checking and auto-hiding

Now that the module restriction has been lifted, the auto-hiding is
mostly not required.  GHC itself automatically hides old versions of a
package.

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 3b0b438..3f8b0b3 100644 (file)
--- 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,8 @@ 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 = snd db_to_operate_on ++ [pkg]
   savePackageConfig db_filename
   maybeRestoreOldConfig db_filename $
     writeNewConfig db_filename new_details
@@ -618,16 +618,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 +670,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 +681,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 +753,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 +940,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