Commit e14a9732 authored by Edward Z. Yang's avatar Edward Z. Yang

Generalize exposed-modules field in installed package database

Summary:
Instead of recording exposed-modules and reexported-modules as seperate
fields in the installed package database, this commit merges them into
a single field (exposed-modules).  The motivation for this change is
in preparation for the inclusion of *signatures* into the installed
package database, which may also be reexported.  Merging the representation
means that we can treat reexports uniformly, no matter if they're a normal
module or a signature.

This commit adds a stub for signatures, but that code isn't wired up to
anything yet.

Contains Cabal submodule update to accommodate these changes.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, duncan, austin

Subscribers: thomie, carter, simonmar

Differential Revision: https://phabricator.haskell.org/D421
parent 452d6aa9
......@@ -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
-- -----------------------------------------------------------------------------
......
......@@ -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
......
Subproject commit bb7e8f8b0170deb9c0486b10f4a9898503427d9f
Subproject commit 1f8a0a20c7a010b50fbafc0effde9bcd663d8716
......@@ -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)
......@@ -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
......
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
......@@ -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
......@@ -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
......@@ -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
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 of
else PackageIndex.lookupInstalledPackageId ipix definingPkgId
in case mpkg of
Nothing
-> verror ForceAll ("module re-export refers to a non-existent " ++
-> 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 " ++
-> 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)
......
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