Update Cabal submodule & ghc-pkg to use new module re-export types
authorEdward Z. Yang <ezyang@cs.stanford.edu>
Tue, 23 Sep 2014 14:05:25 +0000 (16:05 +0200)
committerHerbert Valerio Riedel <hvr@gnu.org>
Wed, 24 Sep 2014 21:18:28 +0000 (23:18 +0200)
Summary:
The main change is that Cabal changed the representation of module
re-exports to distinguish reexports in source .cabal files versus
re-exports in installed package registraion files.

Cabal now also does the resolution of re-exports to specific installed
packages itself, so ghc-pkg no longer has to do this. This is a cleaner
design overall because re-export resolution can fail so it is better to
do it during package configuration rather than package registration.
It also simplifies the re-export representation that ghc-pkg has to use.

Add extra ghc-pkg sanity check for module re-exports and duplicates

For re-exports, check that the defining package exists and that it
exposes the defining module (or for self-rexport exposed or hidden
modules). Also check that the defining package is actually a direct
or indirect dependency of the package doing the re-exporting.

Also add a check for duplicate modules in a package, including
re-exported modules.

Test Plan:
So far the sanity checks are totally untested. Should add some test
case to make sure the sanity checks do catch things correctly, and
don't ban legal things.

Reviewers: austin, duncan

Subscribers: angerman, simonmar, ezyang, carter

Differential Revision: https://phabricator.haskell.org/D183

GHC Trac Issues:

compiler/main/Packages.lhs
ghc.mk
libraries/Cabal
testsuite/tests/cabal/ghcpkg07.stdout
testsuite/tests/cabal/test7a.pkg
testsuite/tests/cabal/test7b.pkg
testsuite/tests/perf/haddock/all.T
utils/ghc-cabal/Main.hs
utils/ghc-cabal/ghc.mk
utils/ghc-pkg/Main.hs

index 93370d4..f0d4d4f 100644 (file)
@@ -767,11 +767,15 @@ findBroken pkgs = go [] Map.empty pkgs
 -- package name/version.  Additionally, a package may be preferred if
 -- it is in the transitive closure of packages selected using -package-id
 -- flags.
+type UnusablePackage = (PackageConfig, UnusablePackageReason)
 shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
 shadowPackages pkgs preferred
  = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
    in  Map.fromList shadowed
  where
+ check :: ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
+       -> PackageConfig
+       -> ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
  check (shadowed,pkgmap) pkg
       | Just oldpkg <- lookupUFM pkgmap pkgid
       , let
@@ -785,7 +789,7 @@ shadowPackages pkgs preferred
       | otherwise
       = (shadowed, pkgmap')
       where
-        pkgid = mkFastString (sourcePackageIdString pkg)
+        pkgid = packageKeyFS (packageKey pkg)
         pkgmap' = addToUFM pkgmap pkgid pkg
 
 -- -----------------------------------------------------------------------------
diff --git a/ghc.mk b/ghc.mk
index fb93ef0..eedb023 100644 (file)
--- a/ghc.mk
+++ b/ghc.mk
@@ -383,7 +383,7 @@ else
 # programs such as GHC and ghc-pkg, that we do not assume the stage0
 # compiler already has installed (or up-to-date enough).
 
-PACKAGES_STAGE0 = Cabal/Cabal hpc binary bin-package-db hoopl transformers
+PACKAGES_STAGE0 = binary Cabal/Cabal hpc bin-package-db hoopl transformers
 ifeq "$(Windows_Host)" "NO"
 ifneq "$(HostOS_CPP)" "ios"
 PACKAGES_STAGE0 += terminfo
@@ -413,8 +413,8 @@ PACKAGES_STAGE1 += process
 PACKAGES_STAGE1 += hpc
 PACKAGES_STAGE1 += pretty
 PACKAGES_STAGE1 += template-haskell
-PACKAGES_STAGE1 += Cabal/Cabal
 PACKAGES_STAGE1 += binary
+PACKAGES_STAGE1 += Cabal/Cabal
 PACKAGES_STAGE1 += bin-package-db
 PACKAGES_STAGE1 += hoopl
 PACKAGES_STAGE1 += transformers
index 8d59dc9..5cf626d 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 8d59dc9fba584a9fdb810f4d84f7f3ccb089dd08
+Subproject commit 5cf626df3039c8746bff814a7b97988d25707d96
index f890b5b..b76e795 100644 (file)
@@ -1,11 +1,9 @@
 Reading package info from "test.pkg" ... done.
 Reading package info from "test7a.pkg" ... done.
-reexported-modules: testpkg:A (A@testpkg-1.2.3.4-XXX)
-                    testpkg:A as A1 (A@testpkg-1.2.3.4-XXX)
-                    E as E2 (E@testpkg7a-1.0-XXX)
+reexported-modules: testpkg-1.2.3.4-XXX:A as A
+                    testpkg-1.2.3.4-XXX:A as A1 testpkg7a-1.0-XXX:E as E2
 Reading package info from "test7b.pkg" ... done.
-reexported-modules: testpkg:A as F1 (A@testpkg-1.2.3.4-XXX)
-                    testpkg7a:A as F2 (A@testpkg-1.2.3.4-XXX)
-                    testpkg7a:A1 as F3 (A@testpkg-1.2.3.4-XXX)
-                    testpkg7a:E as F4 (E@testpkg7a-1.0-XXX) E (E@testpkg7a-1.0-XXX)
-                    E2 as E3 (E@testpkg7a-1.0-XXX)
+reexported-modules: testpkg-1.2.3.4-XXX:A as F1
+                    testpkg7a-1.0-XXX:A as F2 testpkg7a-1.0-XXX:A1 as F3
+                    testpkg7a-1.0-XXX:E as F4 testpkg7a-1.0-XXX:E as E
+                    testpkg7a-1.0-XXX:E2 as E3
index f90fa73..b94f766 100644 (file)
@@ -13,6 +13,7 @@ category: none
 author: simonmar@microsoft.com
 exposed: True
 exposed-modules: E
-reexported-modules: testpkg:A, testpkg:A as A1, E as E2
+reexported-modules: testpkg-1.2.3.4-XXX:A as A, testpkg-1.2.3.4-XXX:A as A1,
+    testpkg7a-1.0-XXX:E as E2
 hs-libraries: testpkg7a-1.0
 depends: testpkg-1.2.3.4-XXX
index e89ac44..8089bd4 100644 (file)
@@ -12,7 +12,8 @@ description: A Test Package
 category: none
 author: simonmar@microsoft.com
 exposed: True
-reexported-modules: testpkg:A as F1, testpkg7a:A as F2,
-    testpkg7a:A1 as F3, testpkg7a:E as F4, E, E2 as E3
+reexported-modules: testpkg-1.2.3.4-XXX:A as F1, testpkg7a-1.0-XXX:A as F2,
+    testpkg7a-1.0-XXX:A1 as F3, testpkg7a-1.0-XXX:E as F4,
+    testpkg7a-1.0-XXX:E as E, testpkg7a-1.0-XXX:E2 as E3
 hs-libraries: testpkg7b-1.0
 depends: testpkg-1.2.3.4-XXX, testpkg7a-1.0-XXX
index ea14b03..5c8275b 100644 (file)
@@ -40,7 +40,7 @@ test('haddock.base',
 test('haddock.Cabal',
      [unless(in_tree_compiler(), skip)
      ,stats_num_field('bytes allocated',
-          [(wordsize(64), 4500376192, 5)
+          [(wordsize(64), 5840893376, 5)
             # 2012-08-14: 3255435248 (amd64/Linux)
             # 2012-08-29: 3324606664 (amd64/Linux, new codegen)
             # 2012-10-08: 3373401360 (amd64/Linux)
@@ -56,6 +56,7 @@ test('haddock.Cabal',
             # 2014-08-29: 4267311856 (x86_64/Linux - w/w for INLINABLE things)
             # 2014-09-09: 4660249216 (x86_64/Linux - Applicative/Monad changes according to Austin)
             # 2014-09-10: 4500376192 (x86_64/Linux - Applicative/Monad changes according to Joachim)
+            # 2014-09-24: 5840893376 (x86_64/Linux - Cabal update)
 
           ,(platform('i386-unknown-mingw32'), 2052220292, 5)
             # 2012-10-30:                     1733638168 (x86/Windows)
index 47eb1de..bf08912 100644 (file)
@@ -347,7 +347,7 @@ generate directory distdir dll0Modules config_args
           do cwd <- getCurrentDirectory
              let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
              let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
-                                        pd lib lbi clbi
+                                        pd ipid lib lbi clbi
                  final_ipi = installedPkgInfo {
                                  Installed.installedPackageId = ipid,
                                  Installed.haddockHTMLs = []
index ff5762a..b8d54ab 100644 (file)
@@ -42,6 +42,7 @@ $(ghc-cabal_DIST_BINARY): utils/ghc-cabal/Main.hs $(TOUCH_DEP) | $$(dir $$@)/. b
               -odir  bootstrapping \
               -hidir bootstrapping \
               -ilibraries/Cabal/Cabal \
+              -ilibraries/binary/src -DGENERICS \
               -ilibraries/filepath \
               -ilibraries/hpc \
               $(utils/ghc-cabal_dist_EXTRA_HC_OPTS)
index 45c6e8b..dd00429 100644 (file)
@@ -14,14 +14,13 @@ module Main (main) where
 import Version ( version, targetOS, targetARCH )
 import qualified GHC.PackageDb as GhcPkg
 import qualified Distribution.Simple.PackageIndex as PackageIndex
+import qualified Data.Graph as Graph
 import qualified Distribution.ModuleName as ModuleName
 import Distribution.ModuleName (ModuleName)
 import Distribution.InstalledPackageInfo as Cabal
-import Distribution.License
 import Distribution.Compat.ReadP hiding (get)
 import Distribution.ParseUtils
-import Distribution.ModuleExport
-import Distribution.Package hiding (depends)
+import Distribution.Package hiding (depends, installedPackageId)
 import Distribution.Text
 import Distribution.Version
 import Distribution.Simple.Utils (fromUTF8, toUTF8)
@@ -38,8 +37,6 @@ import System.Console.GetOpt
 import qualified Control.Exception as Exception
 import Data.Maybe
 
-import qualified Data.Set as Set
-
 import Data.Char ( isSpace, toLower )
 import Data.Ord (comparing)
 #if __GLASGOW_HASKELL__ < 709
@@ -58,7 +55,6 @@ import Data.List
 import Control.Concurrent
 
 import qualified Data.ByteString.Char8 as BS
-import Data.Binary as Bin
 
 #if defined(mingw32_HOST_OS)
 -- mingw32 needs these for getExecDir
@@ -901,9 +897,6 @@ registerPackage input verbosity my_flags auto_ghci_libs multi_instance
   validatePackageConfig pkg_expanded verbosity truncated_stack
                         auto_ghci_libs multi_instance update force
 
-  -- postprocess the package
-  pkg' <- resolveReexports truncated_stack pkg
-
   let 
      -- In the normal mode, we only allow one version of each package, so we
      -- remove all instances with the same source package id as the one we're
@@ -914,7 +907,7 @@ registerPackage input verbosity my_flags auto_ghci_libs multi_instance
                  p <- packages db_to_operate_on,
                  sourcePackageId p == sourcePackageId pkg ]
   --
-  changeDB verbosity (removes ++ [AddPackage pkg']) db_to_operate_on
+  changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
 
 parsePackageInfo
         :: String
@@ -937,47 +930,6 @@ mungePackageInfo ipi = ipi { packageKey = packageKey' }
           = OldPackageKey (sourcePackageId ipi)
       | otherwise = packageKey ipi
 
--- | Takes the "reexported-modules" field of an InstalledPackageInfo
--- and resolves the references so they point to the original exporter
--- of a module (i.e. the module is in exposed-modules, not
--- reexported-modules).  This is done by maintaining an invariant on
--- the installed package database that a reexported-module field always
--- points to the original exporter.
-resolveReexports :: PackageDBStack
-                 -> InstalledPackageInfo
-                 -> IO InstalledPackageInfo
-resolveReexports db_stack pkg = do
-  let dep_mask = Set.fromList (depends pkg)
-      deps = filter (flip Set.member dep_mask . installedPackageId)
-                    (allPackagesInStack db_stack)
-      matchExposed pkg_dep m = map ((,) (installedPackageId pkg_dep))
-                                   (filter (==m) (exposedModules pkg_dep))
-      worker ModuleExport{ exportOrigPackageName = Just pnm } pkg_dep
-        | pnm /= packageName (sourcePackageId pkg_dep) = []
-      -- Now, either the package matches, *or* we were asked to search the
-      -- true location ourselves.
-      worker ModuleExport{ exportOrigName = m } pkg_dep =
-            matchExposed pkg_dep m ++
-            map (fromMaybe (error $ "Impossible! Missing true location in " ++
-                                    display (installedPackageId pkg_dep))
-                    . exportCachedTrueOrig)
-                (filter ((==m) . exportName) (reexportedModules pkg_dep))
-      self_reexports ModuleExport{ exportOrigPackageName = Just pnm }
-        | pnm /= packageName (sourcePackageId pkg) = []
-      self_reexports ModuleExport{ exportName = m', exportOrigName = m }
-        -- Self-reexport without renaming doesn't make sense
-        | m == m' = []
-        -- *Only* match against exposed modules!
-        | otherwise = matchExposed pkg m
-
-  r <- forM (reexportedModules pkg) $ \me -> do
-    case nub (concatMap (worker me) deps ++ self_reexports me) of
-      [c] -> return me { exportCachedTrueOrig = Just c }
-      [] -> die $ "Couldn't resolve reexport " ++ display me
-      cs -> die $ "Found multiple possible ways to resolve reexport " ++
-                  display me ++ ": " ++ show cs
-  return (pkg { reexportedModules = r })
-
 -- -----------------------------------------------------------------------------
 -- Making changes to a package database
 
@@ -1070,16 +1022,25 @@ convertPackageInfoToCacheFormat pkg =
        GhcPkg.haddockHTMLs       = haddockHTMLs pkg,
        GhcPkg.exposedModules     = exposedModules pkg,
        GhcPkg.hiddenModules      = hiddenModules pkg,
-       GhcPkg.reexportedModules  = [ GhcPkg.ModuleExport m ipid' m'
-                                   | ModuleExport {
-                                       exportName = m,
-                                       exportCachedTrueOrig =
-                                         Just (InstalledPackageId ipid', m')
-                                     } <- reexportedModules pkg
-                                   ],
+       GhcPkg.reexportedModules  = map convertModuleReexport
+                                       (reexportedModules pkg),
        GhcPkg.exposed            = exposed pkg,
        GhcPkg.trusted            = trusted pkg
     }
+  where
+    convertModuleReexport :: ModuleReexport
+                          -> GhcPkg.ModuleExport String ModuleName
+    convertModuleReexport
+        ModuleReexport {
+          moduleReexportName            = m,
+          moduleReexportDefiningPackage = ipid',
+          moduleReexportDefiningName    = m'
+        }
+      = GhcPkg.ModuleExport {
+          exportModuleName         = m,
+          exportOriginalPackageId  = display ipid',
+          exportOriginalModuleName = m'
+        }
 
 instance GhcPkg.BinaryStringRep ModuleName where
   fromStringRep = ModuleName.fromString . fromUTF8 . BS.unpack
@@ -1559,7 +1520,9 @@ checkPackageConfig pkg verbosity db_stack auto_ghci_libs
   mapM_ (checkDir True  "framework-dirs") (frameworkDirs pkg)
   mapM_ (checkFile   True "haddock-interfaces") (haddockInterfaces pkg)
   mapM_ (checkDirURL True "haddock-html")       (haddockHTMLs pkg)
-  checkModules pkg
+  checkDuplicateModules pkg
+  checkModuleFiles pkg
+  checkModuleReexports db_stack pkg
   mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
   -- ToDo: check these somehow?
   --    extra_libraries :: [String],
@@ -1693,9 +1656,8 @@ doesFileExistOnPath filenames paths = go fullFilenames
         go ((p, fp) : xs) = do b <- doesFileExist fp
                                if b then return (Just p) else go xs
 
--- XXX maybe should check reexportedModules too
-checkModules :: InstalledPackageInfo -> Validate ()
-checkModules pkg = do
+checkModuleFiles :: InstalledPackageInfo -> Validate ()
+checkModuleFiles pkg = do
   mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
   where
     findModule modl =
@@ -1707,6 +1669,58 @@ checkModules pkg = do
       when (isNothing m) $
          verror ForceFiles ("cannot find any of " ++ show files)
 
+checkDuplicateModules :: InstalledPackageInfo -> Validate ()
+checkDuplicateModules pkg
+  | null dups = return ()
+  | otherwise = verror ForceAll ("package has duplicate modules: " ++
+                                     unwords (map display dups))
+  where
+    dups = [ m | (m:_:_) <- group (sort mods) ]
+    mods = exposedModules pkg ++ hiddenModules pkg
+        ++ map moduleReexportName (reexportedModules pkg)
+
+checkModuleReexports :: PackageDBStack -> InstalledPackageInfo -> Validate ()
+checkModuleReexports db_stack pkg =
+    mapM_ checkReexport (reexportedModules pkg)
+  where
+    all_pkgs = allPackagesInStack db_stack
+    ipix     = PackageIndex.fromList all_pkgs
+
+    checkReexport ModuleReexport {
+      moduleReexportDefiningPackage = definingPkgId,
+      moduleReexportDefiningName    = definingModule
+    } = case if definingPkgId == installedPackageId pkg
+                then Just pkg
+                else PackageIndex.lookupInstalledPackageId ipix definingPkgId of
+          Nothing
+           -> verror ForceAll ("module re-export refers to a non-existent " ++
+                               "defining package: " ++
+                                       display definingPkgId)
+
+          Just definingPkg
+            | not (isIndirectDependency definingPkgId)
+           -> verror ForceAll ("module re-export refers to a defining  " ++
+                               "package that is not a direct (or indirect) " ++
+                               "dependency of this package: " ++
+                                       display definingPkgId)
+
+            | definingModule `notElem` exposedModules definingPkg
+           -> verror ForceAll ("module (self) re-export refers to a module " ++
+                               display definingModule ++ " " ++
+                               "that is not defined and exposed in the " ++
+                               "defining package " ++ display definingPkgId)
+
+            | otherwise
+           -> return ()
+
+    isIndirectDependency pkgid = fromMaybe False $ do
+      thispkg  <- graphVertex (installedPackageId pkg)
+      otherpkg <- graphVertex pkgid
+      return (Graph.path depgraph thispkg otherpkg)
+    (depgraph, _, graphVertex) =
+      PackageIndex.dependencyGraph (PackageIndex.insert pkg ipix)
+
+
 checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO ()
 checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build
   | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file
@@ -2002,144 +2016,3 @@ removeFileSafe fn =
 
 absolutePath :: FilePath -> IO FilePath
 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
-
------------------------------------------------------------------------------
--- Binary instances for the Cabal InstalledPackageInfo types
---
-
-instance Binary m => Binary (InstalledPackageInfo_ m) where
-  put = putInstalledPackageInfo
-  get = getInstalledPackageInfo
-
-putInstalledPackageInfo :: Binary m => InstalledPackageInfo_ m -> Put
-putInstalledPackageInfo ipi = do
-  put (sourcePackageId ipi)
-  put (installedPackageId ipi)
-  put (packageKey ipi)
-  put (license ipi)
-  put (copyright ipi)
-  put (maintainer ipi)
-  put (author ipi)
-  put (stability ipi)
-  put (homepage ipi)
-  put (pkgUrl ipi)
-  put (synopsis ipi)
-  put (description ipi)
-  put (category ipi)
-  put (exposed ipi)
-  put (exposedModules ipi)
-  put (reexportedModules ipi)
-  put (hiddenModules ipi)
-  put (trusted ipi)
-  put (importDirs ipi)
-  put (libraryDirs ipi)
-  put (hsLibraries ipi)
-  put (extraLibraries ipi)
-  put (extraGHCiLibraries ipi)
-  put (includeDirs ipi)
-  put (includes ipi)
-  put (depends ipi)
-  put (hugsOptions ipi)
-  put (ccOptions ipi)
-  put (ldOptions ipi)
-  put (frameworkDirs ipi)
-  put (frameworks ipi)
-  put (haddockInterfaces ipi)
-  put (haddockHTMLs ipi)
-
-getInstalledPackageInfo :: Binary m => Get (InstalledPackageInfo_ m)
-getInstalledPackageInfo = do
-  sourcePackageId <- get
-  installedPackageId <- get
-  packageKey <- get
-  license <- get
-  copyright <- get
-  maintainer <- get
-  author <- get
-  stability <- get
-  homepage <- get
-  pkgUrl <- get
-  synopsis <- get
-  description <- get
-  category <- get
-  exposed <- get
-  exposedModules <- get
-  reexportedModules <- get
-  hiddenModules <- get
-  trusted <- get
-  importDirs <- get
-  libraryDirs <- get
-  hsLibraries <- get
-  extraLibraries <- get
-  extraGHCiLibraries <- get
-  includeDirs <- get
-  includes <- get
-  depends <- get
-  hugsOptions <- get
-  ccOptions <- get
-  ldOptions <- get
-  frameworkDirs <- get
-  frameworks <- get
-  haddockInterfaces <- get
-  haddockHTMLs <- get
-  return InstalledPackageInfo{..}
-
-instance Binary PackageIdentifier where
-  put pid = do put (pkgName pid); put (pkgVersion pid)
-  get = do
-    pkgName <- get
-    pkgVersion <- get
-    return PackageIdentifier{..}
-
-instance Binary License where
-  put (GPL v)              = do putWord8 0; put v
-  put (LGPL v)             = do putWord8 1; put v
-  put BSD3                 = do putWord8 2
-  put BSD4                 = do putWord8 3
-  put MIT                  = do putWord8 4
-  put PublicDomain         = do putWord8 5
-  put AllRightsReserved    = do putWord8 6
-  put OtherLicense         = do putWord8 7
-  put (Apache v)           = do putWord8 8; put v
-  put (AGPL v)             = do putWord8 9; put v
-  put BSD2                 = do putWord8 10
-  put (MPL v)              = do putWord8 11; put v
-  put (UnknownLicense str) = do putWord8 12; put str
-
-  get = do
-    n <- getWord8
-    case n of
-      0 -> do v <- get; return (GPL v)
-      1 -> do v <- get; return (LGPL v)
-      2 -> return BSD3
-      3 -> return BSD4
-      4 -> return MIT
-      5 -> return PublicDomain
-      6 -> return AllRightsReserved
-      7 -> return OtherLicense
-      8 -> do v <- get; return (Apache v)
-      9 -> do v <- get; return (AGPL v)
-      10 -> return BSD2
-      11 -> do v <- get; return (MPL v)
-      _ -> do str <- get; return (UnknownLicense str)
-
-deriving instance Binary PackageName
-deriving instance Binary InstalledPackageId
-
-instance Binary ModuleName where
-  put = put . display
-  get = fmap ModuleName.fromString get
-
-instance Binary m => Binary (ModuleExport m) where
-  put (ModuleExport a b c d) = do put a; put b; put c; put d
-  get = do a <- get; b <- get; c <- get; d <- get;
-           return (ModuleExport a b c d)
-
-instance Binary PackageKey where
-  put (PackageKey a b c) = do putWord8 0; put a; put b; put c
-  put (OldPackageKey a) = do putWord8 1; put a
-  get = do n <- getWord8
-           case n of
-            0 -> do a <- get; b <- get; c <- get; return (PackageKey a b c)
-            1 -> do a <- get; return (OldPackageKey a)
-            _ -> fail ("Binary PackageKey: bad branch " ++ show n)