Commit 4b648be1 authored by Edward Z. Yang's avatar Edward Z. Yang Committed by Herbert Valerio Riedel

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:
parent 165072b3
......@@ -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
......
Subproject commit 8d59dc9fba584a9fdb810f4d84f7f3ccb089dd08
Subproject commit 5cf626df3039c8746bff814a7b97988d25707d96
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
......@@ -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
......@@ -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
......@@ -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)
......
......@@ -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 = []
......
......@@ -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)
......
......@@ -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)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment