summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/main/PackageConfig.hs27
-rw-r--r--compiler/main/Packages.lhs23
m---------libraries/Cabal0
-rw-r--r--libraries/bin-package-db/GHC/PackageDb.hs98
-rw-r--r--testsuite/tests/cabal/Makefile4
-rw-r--r--testsuite/tests/cabal/ghcpkg07.stdout13
-rw-r--r--testsuite/tests/cabal/test7a.pkg4
-rw-r--r--testsuite/tests/cabal/test7b.pkg4
-rw-r--r--utils/ghc-pkg/Main.hs123
9 files changed, 190 insertions, 106 deletions
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index 3f2bf1680b..b94ea65a65 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -75,6 +75,25 @@ instance Outputable SourcePackageId where
instance Outputable PackageName where
ppr (PackageName str) = ftext str
+-- | Pretty-print an 'ExposedModule' in the same format used by the textual
+-- installed package database.
+pprExposedModule :: (Outputable a, Outputable b) => ExposedModule a b -> SDoc
+pprExposedModule (ExposedModule exposedName exposedReexport exposedSignature) =
+ sep [ ppr exposedName
+ , case exposedReexport of
+ Just m -> sep [text "from", pprOriginalModule m]
+ Nothing -> empty
+ , case exposedSignature of
+ Just m -> sep [text "is", pprOriginalModule m]
+ Nothing -> empty
+ ]
+
+-- | Pretty-print an 'OriginalModule' in the same format used by the textual
+-- installed package database.
+pprOriginalModule :: (Outputable a, Outputable b) => OriginalModule a b -> SDoc
+pprOriginalModule (OriginalModule originalPackageId originalModuleName) =
+ ppr originalPackageId <> char ':' <> ppr originalModuleName
+
defaultPackageConfig :: PackageConfig
defaultPackageConfig = emptyInstalledPackageInfo
@@ -101,9 +120,11 @@ pprPackageConfig InstalledPackageInfo {..} =
field "id" (ppr installedPackageId),
field "key" (ppr packageKey),
field "exposed" (ppr exposed),
- field "exposed-modules" (fsep (map ppr exposedModules)),
+ field "exposed-modules"
+ (if all isExposedModule exposedModules
+ then fsep (map pprExposedModule exposedModules)
+ else pprWithCommas pprExposedModule exposedModules),
field "hidden-modules" (fsep (map ppr hiddenModules)),
- field "reexported-modules" (fsep (map ppr haddockHTMLs)),
field "trusted" (ppr trusted),
field "import-dirs" (fsep (map text importDirs)),
field "library-dirs" (fsep (map text libraryDirs)),
@@ -122,6 +143,8 @@ pprPackageConfig InstalledPackageInfo {..} =
]
where
field name body = text name <> colon <+> nest 4 body
+ isExposedModule (ExposedModule _ Nothing Nothing) = True
+ isExposedModule _ = False
-- -----------------------------------------------------------------------------
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index a308a990d1..d757461f54 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -35,7 +35,6 @@ module Packages (
collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
packageHsLibs,
- ModuleExport(..),
-- * Utils
packageKeyPackageIdString,
@@ -1047,16 +1046,17 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
ppr orig <+> text "in package" <+> ppr pk)))
es :: Bool -> [(ModuleName, e)]
- es e =
- [(m, sing pk m pkg (fromExposedModules e)) | m <- exposed_mods] ++
- [(m, sing pk' m' pkg' (fromReexportedModules e pkg))
- | ModuleExport {
- exportModuleName = m,
- exportOriginalPackageId = ipid',
- exportOriginalModuleName = m'
- } <- reexported_mods
- , let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
- pkg' = pkg_lookup pk' ]
+ es e = do
+ -- TODO: signature support
+ ExposedModule m exposedReexport _exposedSignature <- exposed_mods
+ let (pk', m', pkg', origin') =
+ case exposedReexport of
+ Nothing -> (pk, m, pkg, fromExposedModules e)
+ Just (OriginalModule ipid' m') ->
+ let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
+ pkg' = pkg_lookup pk'
+ in (pk', m', pkg', fromReexportedModules e pkg')
+ return (m, sing pk' m' pkg' origin')
esmap :: UniqFM e
esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
@@ -1068,7 +1068,6 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
exposed_mods = exposedModules pkg
- reexported_mods = reexportedModules pkg
hidden_mods = hiddenModules pkg
-- | This is a quick and efficient module map, which only contains an entry
diff --git a/libraries/Cabal b/libraries/Cabal
-Subproject bb7e8f8b0170deb9c0486b10f4a9898503427d9
+Subproject 1f8a0a20c7a010b50fbafc0effde9bcd663d871
diff --git a/libraries/bin-package-db/GHC/PackageDb.hs b/libraries/bin-package-db/GHC/PackageDb.hs
index 76fa697990..e1715e69e5 100644
--- a/libraries/bin-package-db/GHC/PackageDb.hs
+++ b/libraries/bin-package-db/GHC/PackageDb.hs
@@ -37,7 +37,8 @@
--
module GHC.PackageDb (
InstalledPackageInfo(..),
- ModuleExport(..),
+ ExposedModule(..),
+ OriginalModule(..),
BinaryStringRep(..),
emptyInstalledPackageInfo,
readPackageDbForGhc,
@@ -86,26 +87,58 @@ data InstalledPackageInfo instpkgid srcpkgid srcpkgname pkgkey modulename
includeDirs :: [FilePath],
haddockInterfaces :: [FilePath],
haddockHTMLs :: [FilePath],
- exposedModules :: [modulename],
+ exposedModules :: [ExposedModule instpkgid modulename],
hiddenModules :: [modulename],
- reexportedModules :: [ModuleExport instpkgid modulename],
exposed :: Bool,
trusted :: Bool
}
deriving (Eq, Show)
-class BinaryStringRep a where
- fromStringRep :: BS.ByteString -> a
- toStringRep :: a -> BS.ByteString
+-- | An original module is a fully-qualified module name (installed package ID
+-- plus module name) representing where a module was *originally* defined
+-- (i.e., the 'exposedReexport' field of the original ExposedModule entry should
+-- be 'Nothing'). Invariant: an OriginalModule never points to a reexport.
+data OriginalModule instpkgid modulename
+ = OriginalModule {
+ originalPackageId :: instpkgid,
+ originalModuleName :: modulename
+ }
+ deriving (Eq, Show)
-data ModuleExport instpkgid modulename
- = ModuleExport {
- exportModuleName :: modulename,
- exportOriginalPackageId :: instpkgid,
- exportOriginalModuleName :: modulename
+-- | Represents a module name which is exported by a package, stored in the
+-- 'exposedModules' field. A module export may be a reexport (in which
+-- case 'exposedReexport' is filled in with the original source of the module),
+-- and may be a signature (in which case 'exposedSignature is filled in with
+-- what the signature was compiled against). Thus:
+--
+-- * @ExposedModule n Nothing Nothing@ represents an exposed module @n@ which
+-- was defined in this package.
+--
+-- * @ExposedModule n (Just o) Nothing@ represents a reexported module @n@
+-- which was originally defined in @o@.
+--
+-- * @ExposedModule n Nothing (Just s)@ represents an exposed signature @n@
+-- which was compiled against the implementation @s@.
+--
+-- * @ExposedModule n (Just o) (Just s)@ represents a reexported signature
+-- which was originally defined in @o@ and was compiled against the
+-- implementation @s@.
+--
+-- We use two 'Maybe' data types instead of an ADT with four branches or
+-- four fields because this representation allows us to treat
+-- reexports/signatures uniformly.
+data ExposedModule instpkgid modulename
+ = ExposedModule {
+ exposedName :: modulename,
+ exposedReexport :: Maybe (OriginalModule instpkgid modulename),
+ exposedSignature :: Maybe (OriginalModule instpkgid modulename)
}
deriving (Eq, Show)
+class BinaryStringRep a where
+ fromStringRep :: BS.ByteString -> a
+ toStringRep :: a -> BS.ByteString
+
emptyInstalledPackageInfo :: (BinaryStringRep a, BinaryStringRep b,
BinaryStringRep c, BinaryStringRep d)
=> InstalledPackageInfo a b c d e
@@ -132,7 +165,6 @@ emptyInstalledPackageInfo =
haddockHTMLs = [],
exposedModules = [],
hiddenModules = [],
- reexportedModules = [],
exposed = False,
trusted = False
}
@@ -288,7 +320,7 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
ldOptions ccOptions
includes includeDirs
haddockInterfaces haddockHTMLs
- exposedModules hiddenModules reexportedModules
+ exposedModules hiddenModules
exposed trusted) = do
put (toStringRep installedPackageId)
put (toStringRep sourcePackageId)
@@ -309,9 +341,8 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
put includeDirs
put haddockInterfaces
put haddockHTMLs
- put (map toStringRep exposedModules)
+ put exposedModules
put (map toStringRep hiddenModules)
- put reexportedModules
put exposed
put trusted
@@ -337,7 +368,6 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
haddockHTMLs <- get
exposedModules <- get
hiddenModules <- get
- reexportedModules <- get
exposed <- get
trusted <- get
return (InstalledPackageInfo
@@ -352,9 +382,8 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
ldOptions ccOptions
includes includeDirs
haddockInterfaces haddockHTMLs
- (map fromStringRep exposedModules)
+ exposedModules
(map fromStringRep hiddenModules)
- reexportedModules
exposed trusted)
instance Binary Version where
@@ -367,15 +396,26 @@ instance Binary Version where
return (Version a b)
instance (BinaryStringRep a, BinaryStringRep b) =>
- Binary (ModuleExport a b) where
- put (ModuleExport a b c) = do
- put (toStringRep a)
- put (toStringRep b)
- put (toStringRep c)
+ Binary (OriginalModule a b) where
+ put (OriginalModule originalPackageId originalModuleName) = do
+ put (toStringRep originalPackageId)
+ put (toStringRep originalModuleName)
get = do
- a <- get
- b <- get
- c <- get
- return (ModuleExport (fromStringRep a)
- (fromStringRep b)
- (fromStringRep c))
+ originalPackageId <- get
+ originalModuleName <- get
+ return (OriginalModule (fromStringRep originalPackageId)
+ (fromStringRep originalModuleName))
+
+instance (BinaryStringRep a, BinaryStringRep b) =>
+ Binary (ExposedModule a b) where
+ put (ExposedModule exposedName exposedReexport exposedSignature) = do
+ put (toStringRep exposedName)
+ put exposedReexport
+ put exposedSignature
+ get = do
+ exposedName <- get
+ exposedReexport <- get
+ exposedSignature <- get
+ return (ExposedModule (fromStringRep exposedName)
+ exposedReexport
+ exposedSignature)
diff --git a/testsuite/tests/cabal/Makefile b/testsuite/tests/cabal/Makefile
index 062850f76f..1e4cd6970d 100644
--- a/testsuite/tests/cabal/Makefile
+++ b/testsuite/tests/cabal/Makefile
@@ -244,9 +244,9 @@ ghcpkg07:
$(LOCAL_GHC_PKG07) init $(PKGCONF07)
$(LOCAL_GHC_PKG07) register --force test.pkg 2>/dev/null
$(LOCAL_GHC_PKG07) register --force test7a.pkg 2>/dev/null
- $(LOCAL_GHC_PKG07) field testpkg7a reexported-modules
+ $(LOCAL_GHC_PKG07) field testpkg7a exposed-modules
$(LOCAL_GHC_PKG07) register --force test7b.pkg 2>/dev/null
- $(LOCAL_GHC_PKG07) field testpkg7b reexported-modules
+ $(LOCAL_GHC_PKG07) field testpkg7b exposed-modules
recache_reexport:
@rm -rf recache_reexport_db/package.cache
diff --git a/testsuite/tests/cabal/ghcpkg07.stdout b/testsuite/tests/cabal/ghcpkg07.stdout
index b76e795388..717a9971a1 100644
--- a/testsuite/tests/cabal/ghcpkg07.stdout
+++ b/testsuite/tests/cabal/ghcpkg07.stdout
@@ -1,9 +1,10 @@
Reading package info from "test.pkg" ... done.
Reading package info from "test7a.pkg" ... done.
-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
+exposed-modules:
+ E, A from testpkg-1.2.3.4-XXX:A, A1 from testpkg-1.2.3.4-XXX:A,
+ E2 from testpkg7a-1.0-XXX:E
Reading package info from "test7b.pkg" ... done.
-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
+exposed-modules:
+ F1 from testpkg-1.2.3.4-XXX:A, F2 from testpkg7a-1.0-XXX:A,
+ F3 from testpkg7a-1.0-XXX:A1, F4 from testpkg7a-1.0-XXX:E,
+ E from testpkg7a-1.0-XXX:E, E3 from testpkg7a-1.0-XXX:E2
diff --git a/testsuite/tests/cabal/test7a.pkg b/testsuite/tests/cabal/test7a.pkg
index b94f76673e..7eaeea2a8a 100644
--- a/testsuite/tests/cabal/test7a.pkg
+++ b/testsuite/tests/cabal/test7a.pkg
@@ -12,8 +12,6 @@ description: A Test Package
category: none
author: simonmar@microsoft.com
exposed: True
-exposed-modules: E
-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
+exposed-modules: E, A from testpkg-1.2.3.4-XXX:A, A1 from testpkg-1.2.3.4-XXX:A, E2 from testpkg7a-1.0-XXX:E
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 8089bd4e7e..f0bc6871f0 100644
--- a/testsuite/tests/cabal/test7b.pkg
+++ b/testsuite/tests/cabal/test7b.pkg
@@ -12,8 +12,6 @@ description: A Test Package
category: none
author: simonmar@microsoft.com
exposed: True
-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
+exposed-modules: F1 from testpkg-1.2.3.4-XXX:A, F2 from testpkg7a-1.0-XXX:A, F3 from testpkg7a-1.0-XXX:A1, F4 from testpkg7a-1.0-XXX:E, E from testpkg7a-1.0-XXX:E, E3 from testpkg7a-1.0-XXX:E2
hs-libraries: testpkg7b-1.0
depends: testpkg-1.2.3.4-XXX, testpkg7a-1.0-XXX
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index dd00429470..a67dbb2330 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -1020,27 +1020,16 @@ convertPackageInfoToCacheFormat pkg =
GhcPkg.includeDirs = includeDirs pkg,
GhcPkg.haddockInterfaces = haddockInterfaces pkg,
GhcPkg.haddockHTMLs = haddockHTMLs pkg,
- GhcPkg.exposedModules = exposedModules pkg,
+ GhcPkg.exposedModules = map convertExposed (exposedModules pkg),
GhcPkg.hiddenModules = hiddenModules 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'
- }
+ where convertExposed (ExposedModule n reexport sig) =
+ GhcPkg.ExposedModule n (fmap convertOriginal reexport)
+ (fmap convertOriginal sig)
+ convertOriginal (OriginalModule ipid m) =
+ GhcPkg.OriginalModule (display ipid) m
instance GhcPkg.BinaryStringRep ModuleName where
fromStringRep = ModuleName.fromString . fromUTF8 . BS.unpack
@@ -1521,8 +1510,8 @@ checkPackageConfig pkg verbosity db_stack auto_ghci_libs
mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
checkDuplicateModules pkg
- checkModuleFiles pkg
- checkModuleReexports db_stack pkg
+ checkExposedModules db_stack pkg
+ checkOtherModules pkg
mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
-- ToDo: check these somehow?
-- extra_libraries :: [String],
@@ -1656,11 +1645,27 @@ doesFileExistOnPath filenames paths = go fullFilenames
go ((p, fp) : xs) = do b <- doesFileExist fp
if b then return (Just p) else go xs
-checkModuleFiles :: InstalledPackageInfo -> Validate ()
-checkModuleFiles pkg = do
- mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
+-- | Perform validation checks (module file existence checks) on the
+-- @hidden-modules@ field.
+checkOtherModules :: InstalledPackageInfo -> Validate ()
+checkOtherModules pkg = mapM_ (checkModuleFile pkg) (hiddenModules pkg)
+
+-- | Perform validation checks (module file existence checks and module
+-- reexport checks) on the @exposed-modules@ field.
+checkExposedModules :: PackageDBStack -> InstalledPackageInfo -> Validate ()
+checkExposedModules db_stack pkg =
+ mapM_ checkExposedModule (exposedModules pkg)
where
- findModule modl =
+ checkExposedModule (ExposedModule modl reexport _sig) = do
+ let checkOriginal = checkModuleFile pkg modl
+ checkReexport = checkOriginalModule "module reexport" db_stack pkg
+ maybe checkOriginal checkReexport reexport
+
+-- | Validates the existence of an appropriate @hi@ file associated with
+-- a module. Used for both @hidden-modules@ and @exposed-modules@ which
+-- are not reexports.
+checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate ()
+checkModuleFile pkg modl =
-- there's no interface file for GHC.Prim
unless (modl == ModuleName.fromString "GHC.Prim") $ do
let files = [ ModuleName.toFilePath modl <.> extension
@@ -1669,6 +1674,11 @@ checkModuleFiles pkg = do
when (isNothing m) $
verror ForceFiles ("cannot find any of " ++ show files)
+-- | Validates that @exposed-modules@ and @hidden-modules@ do not have duplicate
+-- entries.
+-- ToDo: this needs updating for signatures: signatures can validly show up
+-- multiple times in the @exposed-modules@ list as long as their backing
+-- implementations agree.
checkDuplicateModules :: InstalledPackageInfo -> Validate ()
checkDuplicateModules pkg
| null dups = return ()
@@ -1676,42 +1686,57 @@ checkDuplicateModules pkg
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 " ++
+ mods = map exposedName (exposedModules pkg) ++ hiddenModules pkg
+
+-- | Validates an original module entry, either the origin of a module reexport
+-- or the backing implementation of a signature, by checking that it exists,
+-- really is an original definition, and is accessible from the dependencies of
+-- the package.
+-- ToDo: If the original module in question is a backing signature
+-- implementation, then we should also check that the original module in
+-- question is NOT a signature (however, if it is a reexport, then it's fine
+-- for the original module to be a signature.)
+checkOriginalModule :: String
+ -> PackageDBStack
+ -> InstalledPackageInfo
+ -> OriginalModule
+ -> Validate ()
+checkOriginalModule fieldName db_stack pkg
+ (OriginalModule definingPkgId definingModule) =
+ let mpkg = if definingPkgId == installedPackageId pkg
+ then Just pkg
+ else PackageIndex.lookupInstalledPackageId ipix definingPkgId
+ in case mpkg of
+ Nothing
+ -> verror ForceAll (fieldName ++ " refers to a non-existent " ++
"defining package: " ++
display definingPkgId)
- Just definingPkg
- | not (isIndirectDependency definingPkgId)
- -> verror ForceAll ("module re-export refers to a defining " ++
+ Just definingPkg
+ | not (isIndirectDependency definingPkgId)
+ -> verror ForceAll (fieldName ++ " 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 " ++
+ | otherwise
+ -> case find ((==definingModule).exposedName)
+ (exposedModules definingPkg) of
+ Nothing ->
+ verror ForceAll (fieldName ++ " refers to a module " ++
+ display definingModule ++ " " ++
+ "that is not exposed in the " ++
+ "defining package " ++ display definingPkgId)
+ Just (ExposedModule {exposedReexport = Just _} ) ->
+ verror ForceAll (fieldName ++ " refers to a module " ++
display definingModule ++ " " ++
- "that is not defined and exposed in the " ++
+ "that is reexported but not defined in the " ++
"defining package " ++ display definingPkgId)
+ _ -> return ()
- | otherwise
- -> return ()
+ where
+ all_pkgs = allPackagesInStack db_stack
+ ipix = PackageIndex.fromList all_pkgs
isIndirectDependency pkgid = fromMaybe False $ do
thispkg <- graphVertex (installedPackageId pkg)
View Lorry Controller Status