diff options
author | Edward Z. Yang <ezyang@cs.stanford.edu> | 2014-09-23 16:05:25 +0200 |
---|---|---|
committer | Herbert Valerio Riedel <hvr@gnu.org> | 2014-09-24 23:18:28 +0200 |
commit | 4b648be19c75e6c6a8e6f9f93fa12c7a4176f0ae (patch) | |
tree | 9ac36c659e391d72825ce896a3424a22823b7703 | |
parent | 165072b334ebb2ccbef38a963ac4d126f1e08c96 (diff) | |
download | haskell-4b648be19c75e6c6a8e6f9f93fa12c7a4176f0ae.tar.gz |
Update Cabal submodule & ghc-pkg to use new module re-export types
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:
-rw-r--r-- | compiler/main/Packages.lhs | 6 | ||||
-rw-r--r-- | ghc.mk | 4 | ||||
m--------- | libraries/Cabal | 0 | ||||
-rw-r--r-- | testsuite/tests/cabal/ghcpkg07.stdout | 14 | ||||
-rw-r--r-- | testsuite/tests/cabal/test7a.pkg | 3 | ||||
-rw-r--r-- | testsuite/tests/cabal/test7b.pkg | 5 | ||||
-rw-r--r-- | testsuite/tests/perf/haddock/all.T | 3 | ||||
-rw-r--r-- | utils/ghc-cabal/Main.hs | 2 | ||||
-rw-r--r-- | utils/ghc-cabal/ghc.mk | 1 | ||||
-rw-r--r-- | utils/ghc-pkg/Main.hs | 279 |
10 files changed, 98 insertions, 219 deletions
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 93370d47b3..f0d4d4f1fc 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -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 -- ----------------------------------------------------------------------------- @@ -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 diff --git a/libraries/Cabal b/libraries/Cabal -Subproject 8d59dc9fba584a9fdb810f4d84f7f3ccb089dd0 +Subproject 5cf626df3039c8746bff814a7b97988d25707d9 diff --git a/testsuite/tests/cabal/ghcpkg07.stdout b/testsuite/tests/cabal/ghcpkg07.stdout index f890b5bfe1..b76e795388 100644 --- a/testsuite/tests/cabal/ghcpkg07.stdout +++ b/testsuite/tests/cabal/ghcpkg07.stdout @@ -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 diff --git a/testsuite/tests/cabal/test7a.pkg b/testsuite/tests/cabal/test7a.pkg index f90fa7320f..b94f76673e 100644 --- a/testsuite/tests/cabal/test7a.pkg +++ b/testsuite/tests/cabal/test7a.pkg @@ -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 diff --git a/testsuite/tests/cabal/test7b.pkg b/testsuite/tests/cabal/test7b.pkg index e89ac444d8..8089bd4e7e 100644 --- a/testsuite/tests/cabal/test7b.pkg +++ b/testsuite/tests/cabal/test7b.pkg @@ -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 diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T index ea14b03199..5c8275bf80 100644 --- a/testsuite/tests/perf/haddock/all.T +++ b/testsuite/tests/perf/haddock/all.T @@ -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) diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs index 47eb1de4fd..bf08912c74 100644 --- a/utils/ghc-cabal/Main.hs +++ b/utils/ghc-cabal/Main.hs @@ -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 = [] diff --git a/utils/ghc-cabal/ghc.mk b/utils/ghc-cabal/ghc.mk index ff5762a655..b8d54abfcb 100644 --- a/utils/ghc-cabal/ghc.mk +++ b/utils/ghc-cabal/ghc.mk @@ -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) diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 45c6e8b9c4..dd00429470 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -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) |