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 ...@@ -75,6 +75,25 @@ instance Outputable SourcePackageId where
instance Outputable PackageName where instance Outputable PackageName where
ppr (PackageName str) = ftext str 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 :: PackageConfig
defaultPackageConfig = emptyInstalledPackageInfo defaultPackageConfig = emptyInstalledPackageInfo
...@@ -101,9 +120,11 @@ pprPackageConfig InstalledPackageInfo {..} = ...@@ -101,9 +120,11 @@ pprPackageConfig InstalledPackageInfo {..} =
field "id" (ppr installedPackageId), field "id" (ppr installedPackageId),
field "key" (ppr packageKey), field "key" (ppr packageKey),
field "exposed" (ppr exposed), 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 "hidden-modules" (fsep (map ppr hiddenModules)),
field "reexported-modules" (fsep (map ppr haddockHTMLs)),
field "trusted" (ppr trusted), field "trusted" (ppr trusted),
field "import-dirs" (fsep (map text importDirs)), field "import-dirs" (fsep (map text importDirs)),
field "library-dirs" (fsep (map text libraryDirs)), field "library-dirs" (fsep (map text libraryDirs)),
...@@ -122,6 +143,8 @@ pprPackageConfig InstalledPackageInfo {..} = ...@@ -122,6 +143,8 @@ pprPackageConfig InstalledPackageInfo {..} =
] ]
where where
field name body = text name <> colon <+> nest 4 body field name body = text name <> colon <+> nest 4 body
isExposedModule (ExposedModule _ Nothing Nothing) = True
isExposedModule _ = False
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
......
...@@ -35,7 +35,6 @@ module Packages ( ...@@ -35,7 +35,6 @@ module Packages (
collectIncludeDirs, collectLibraryPaths, collectLinkOpts, collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
packageHsLibs, packageHsLibs,
ModuleExport(..),
-- * Utils -- * Utils
packageKeyPackageIdString, packageKeyPackageIdString,
...@@ -1047,16 +1046,17 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo ...@@ -1047,16 +1046,17 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
ppr orig <+> text "in package" <+> ppr pk))) ppr orig <+> text "in package" <+> ppr pk)))
es :: Bool -> [(ModuleName, e)] es :: Bool -> [(ModuleName, e)]
es e = es e = do
[(m, sing pk m pkg (fromExposedModules e)) | m <- exposed_mods] ++ -- TODO: signature support
[(m, sing pk' m' pkg' (fromReexportedModules e pkg)) ExposedModule m exposedReexport _exposedSignature <- exposed_mods
| ModuleExport { let (pk', m', pkg', origin') =
exportModuleName = m, case exposedReexport of
exportOriginalPackageId = ipid', Nothing -> (pk, m, pkg, fromExposedModules e)
exportOriginalModuleName = m' Just (OriginalModule ipid' m') ->
} <- reexported_mods let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
, let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map) pkg' = pkg_lookup pk'
pkg' = pkg_lookup pk' ] in (pk', m', pkg', fromReexportedModules e pkg')
return (m, sing pk' m' pkg' origin')
esmap :: UniqFM e esmap :: UniqFM e
esmap = listToUFM (es False) -- parameter here doesn't matter, orig will esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
...@@ -1068,7 +1068,6 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo ...@@ -1068,7 +1068,6 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
exposed_mods = exposedModules pkg exposed_mods = exposedModules pkg
reexported_mods = reexportedModules pkg
hidden_mods = hiddenModules pkg hidden_mods = hiddenModules pkg
-- | This is a quick and efficient module map, which only contains an entry -- | This is a quick and efficient module map, which only contains an entry
......
Subproject commit bb7e8f8b0170deb9c0486b10f4a9898503427d9f Subproject commit 1f8a0a20c7a010b50fbafc0effde9bcd663d8716
...@@ -37,7 +37,8 @@ ...@@ -37,7 +37,8 @@
-- --
module GHC.PackageDb ( module GHC.PackageDb (
InstalledPackageInfo(..), InstalledPackageInfo(..),
ModuleExport(..), ExposedModule(..),
OriginalModule(..),
BinaryStringRep(..), BinaryStringRep(..),
emptyInstalledPackageInfo, emptyInstalledPackageInfo,
readPackageDbForGhc, readPackageDbForGhc,
...@@ -86,26 +87,58 @@ data InstalledPackageInfo instpkgid srcpkgid srcpkgname pkgkey modulename ...@@ -86,26 +87,58 @@ data InstalledPackageInfo instpkgid srcpkgid srcpkgname pkgkey modulename
includeDirs :: [FilePath], includeDirs :: [FilePath],
haddockInterfaces :: [FilePath], haddockInterfaces :: [FilePath],
haddockHTMLs :: [FilePath], haddockHTMLs :: [FilePath],
exposedModules :: [modulename], exposedModules :: [ExposedModule instpkgid modulename],
hiddenModules :: [modulename], hiddenModules :: [modulename],
reexportedModules :: [ModuleExport instpkgid modulename],
exposed :: Bool, exposed :: Bool,
trusted :: Bool trusted :: Bool
} }
deriving (Eq, Show) deriving (Eq, Show)
class BinaryStringRep a where -- | An original module is a fully-qualified module name (installed package ID
fromStringRep :: BS.ByteString -> a -- plus module name) representing where a module was *originally* defined
toStringRep :: a -> BS.ByteString -- (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 -- | Represents a module name which is exported by a package, stored in the
= ModuleExport { -- 'exposedModules' field. A module export may be a reexport (in which
exportModuleName :: modulename, -- case 'exposedReexport' is filled in with the original source of the module),
exportOriginalPackageId :: instpkgid, -- and may be a signature (in which case 'exposedSignature is filled in with
exportOriginalModuleName :: modulename -- 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) deriving (Eq, Show)
class BinaryStringRep a where
fromStringRep :: BS.ByteString -> a
toStringRep :: a -> BS.ByteString
emptyInstalledPackageInfo :: (BinaryStringRep a, BinaryStringRep b, emptyInstalledPackageInfo :: (BinaryStringRep a, BinaryStringRep b,
BinaryStringRep c, BinaryStringRep d) BinaryStringRep c, BinaryStringRep d)
=> InstalledPackageInfo a b c d e => InstalledPackageInfo a b c d e
...@@ -132,7 +165,6 @@ emptyInstalledPackageInfo = ...@@ -132,7 +165,6 @@ emptyInstalledPackageInfo =
haddockHTMLs = [], haddockHTMLs = [],
exposedModules = [], exposedModules = [],
hiddenModules = [], hiddenModules = [],
reexportedModules = [],
exposed = False, exposed = False,
trusted = False trusted = False
} }
...@@ -288,7 +320,7 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, ...@@ -288,7 +320,7 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
ldOptions ccOptions ldOptions ccOptions
includes includeDirs includes includeDirs
haddockInterfaces haddockHTMLs haddockInterfaces haddockHTMLs
exposedModules hiddenModules reexportedModules exposedModules hiddenModules
exposed trusted) = do exposed trusted) = do
put (toStringRep installedPackageId) put (toStringRep installedPackageId)
put (toStringRep sourcePackageId) put (toStringRep sourcePackageId)
...@@ -309,9 +341,8 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, ...@@ -309,9 +341,8 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
put includeDirs put includeDirs
put haddockInterfaces put haddockInterfaces
put haddockHTMLs put haddockHTMLs
put (map toStringRep exposedModules) put exposedModules
put (map toStringRep hiddenModules) put (map toStringRep hiddenModules)
put reexportedModules
put exposed put exposed
put trusted put trusted
...@@ -337,7 +368,6 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, ...@@ -337,7 +368,6 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
haddockHTMLs <- get haddockHTMLs <- get
exposedModules <- get exposedModules <- get
hiddenModules <- get hiddenModules <- get
reexportedModules <- get
exposed <- get exposed <- get
trusted <- get trusted <- get
return (InstalledPackageInfo return (InstalledPackageInfo
...@@ -352,9 +382,8 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, ...@@ -352,9 +382,8 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
ldOptions ccOptions ldOptions ccOptions
includes includeDirs includes includeDirs
haddockInterfaces haddockHTMLs haddockInterfaces haddockHTMLs
(map fromStringRep exposedModules) exposedModules
(map fromStringRep hiddenModules) (map fromStringRep hiddenModules)
reexportedModules
exposed trusted) exposed trusted)
instance Binary Version where instance Binary Version where
...@@ -367,15 +396,26 @@ instance Binary Version where ...@@ -367,15 +396,26 @@ instance Binary Version where
return (Version a b) return (Version a b)
instance (BinaryStringRep a, BinaryStringRep b) => instance (BinaryStringRep a, BinaryStringRep b) =>
Binary (ModuleExport a b) where Binary (OriginalModule a b) where
put (ModuleExport a b c) = do put (OriginalModule originalPackageId originalModuleName) = do
put (toStringRep a) put (toStringRep originalPackageId)
put (toStringRep b) put (toStringRep originalModuleName)
put (toStringRep c)
get = do get = do
a <- get originalPackageId <- get
b <- get originalModuleName <- get
c <- get return (OriginalModule (fromStringRep originalPackageId)
return (ModuleExport (fromStringRep a) (fromStringRep originalModuleName))
(fromStringRep b)
(fromStringRep c)) 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: ...@@ -244,9 +244,9 @@ ghcpkg07:
$(LOCAL_GHC_PKG07) init $(PKGCONF07) $(LOCAL_GHC_PKG07) init $(PKGCONF07)
$(LOCAL_GHC_PKG07) register --force test.pkg 2>/dev/null $(LOCAL_GHC_PKG07) register --force test.pkg 2>/dev/null
$(LOCAL_GHC_PKG07) register --force test7a.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) register --force test7b.pkg 2>/dev/null
$(LOCAL_GHC_PKG07) field testpkg7b reexported-modules $(LOCAL_GHC_PKG07) field testpkg7b exposed-modules
recache_reexport: recache_reexport:
@rm -rf recache_reexport_db/package.cache @rm -rf recache_reexport_db/package.cache
......
Reading package info from "test.pkg" ... done. Reading package info from "test.pkg" ... done.
Reading package info from "test7a.pkg" ... done. Reading package info from "test7a.pkg" ... done.
reexported-modules: testpkg-1.2.3.4-XXX:A as A exposed-modules:
testpkg-1.2.3.4-XXX:A as A1 testpkg7a-1.0-XXX:E as E2 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. Reading package info from "test7b.pkg" ... done.
reexported-modules: testpkg-1.2.3.4-XXX:A as F1 exposed-modules:
testpkg7a-1.0-XXX:A as F2 testpkg7a-1.0-XXX:A1 as F3 F1 from testpkg-1.2.3.4-XXX:A, F2 from testpkg7a-1.0-XXX:A,
testpkg7a-1.0-XXX:E as F4 testpkg7a-1.0-XXX:E as E F3 from testpkg7a-1.0-XXX:A1, F4 from testpkg7a-1.0-XXX:E,
testpkg7a-1.0-XXX:E2 as E3 E from testpkg7a-1.0-XXX:E, E3 from testpkg7a-1.0-XXX:E2
...@@ -12,8 +12,6 @@ description: A Test Package ...@@ -12,8 +12,6 @@ description: A Test Package
category: none category: none
author: simonmar@microsoft.com author: simonmar@microsoft.com
exposed: True exposed: True
exposed-modules: E 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
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 hs-libraries: testpkg7a-1.0
depends: testpkg-1.2.3.4-XXX depends: testpkg-1.2.3.4-XXX
...@@ -12,8 +12,6 @@ description: A Test Package ...@@ -12,8 +12,6 @@ description: A Test Package
category: none category: none
author: simonmar@microsoft.com author: simonmar@microsoft.com
exposed: True exposed: True
reexported-modules: testpkg-1.2.3.4-XXX:A as F1, testpkg7a-1.0-XXX:A as F2, 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
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 hs-libraries: testpkg7b-1.0
depends: testpkg-1.2.3.4-XXX, testpkg7a-1.0-XXX depends: testpkg-1.2.3.4-XXX, testpkg7a-1.0-XXX
...@@ -1020,27 +1020,16 @@ convertPackageInfoToCacheFormat pkg = ...@@ -1020,27 +1020,16 @@ convertPackageInfoToCacheFormat pkg =
GhcPkg.includeDirs = includeDirs pkg, GhcPkg.includeDirs = includeDirs pkg,
GhcPkg.haddockInterfaces = haddockInterfaces pkg, GhcPkg.haddockInterfaces = haddockInterfaces pkg,
GhcPkg.haddockHTMLs = haddockHTMLs pkg, GhcPkg.haddockHTMLs = haddockHTMLs pkg,
GhcPkg.exposedModules = exposedModules pkg, GhcPkg.exposedModules = map convertExposed (exposedModules pkg),
GhcPkg.hiddenModules = hiddenModules pkg, GhcPkg.hiddenModules = hiddenModules pkg,
GhcPkg.reexportedModules = map convertModuleReexport
(reexportedModules pkg),
GhcPkg.exposed = exposed pkg, GhcPkg.exposed = exposed pkg,
GhcPkg.trusted = trusted pkg GhcPkg.trusted = trusted pkg
} }
where where convertExposed (ExposedModule n reexport sig) =
convertModuleReexport :: ModuleReexport GhcPkg.ExposedModule n (fmap convertOriginal reexport)
-> GhcPkg.ModuleExport String ModuleName (fmap convertOriginal sig)
convertModuleReexport convertOriginal (OriginalModule ipid m) =
ModuleReexport { GhcPkg.OriginalModule (display ipid) m
moduleReexportName = m,
moduleReexportDefiningPackage = ipid',
moduleReexportDefiningName = m'
}
= GhcPkg.ModuleExport {
exportModuleName = m,
exportOriginalPackageId = display ipid',
exportOriginalModuleName = m'
}
instance GhcPkg.BinaryStringRep ModuleName where instance GhcPkg.BinaryStringRep ModuleName where
fromStringRep = ModuleName.fromString . fromUTF8 . BS.unpack fromStringRep = ModuleName.fromString . fromUTF8 . BS.unpack
...@@ -1521,8 +1510,8 @@ checkPackageConfig pkg verbosity db_stack auto_ghci_libs ...@@ -1521,8 +1510,8 @@ checkPackageConfig pkg verbosity db_stack auto_ghci_libs
mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg) mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg) mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
checkDuplicateModules pkg checkDuplicateModules pkg
checkModuleFiles pkg checkExposedModules db_stack pkg
checkModuleReexports db_stack pkg checkOtherModules pkg
mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
-- ToDo: check these somehow? -- ToDo: check these somehow?
-- extra_libraries :: [String], -- extra_libraries :: [String],
...@@ -1656,11 +1645,27 @@ doesFileExistOnPath filenames paths = go fullFilenames ...@@ -1656,11 +1645,27 @@ doesFileExistOnPath filenames paths = go fullFilenames
go ((p, fp) : xs) = do b <- doesFileExist fp go ((p, fp) : xs) = do b <- doesFileExist fp
if b then return (Just p) else go xs if b then return (Just p) else go xs
checkModuleFiles :: InstalledPackageInfo -> Validate () -- | Perform validation checks (module file existence checks) on the
checkModuleFiles pkg = do -- @hidden-modules@ field.
mapM_ findModule (exposedModules pkg ++ hiddenModules pkg) 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 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 -- there's no interface file for GHC.Prim
unless (modl == ModuleName.fromString "GHC.Prim") $ do unless (modl == ModuleName.fromString "GHC.Prim") $ do
let files = [ ModuleName.toFilePath modl <.> extension let files = [ ModuleName.toFilePath modl <.> extension
...@@ -1669,6 +1674,11 @@ checkModuleFiles pkg = do ...@@ -1669,6 +1674,11 @@ checkModuleFiles pkg = do
when (isNothing m) $ when (isNothing m) $
verror ForceFiles ("cannot find any of " ++ show files) 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 :: InstalledPackageInfo -> Validate ()
checkDuplicateModules pkg checkDuplicateModules pkg
| null dups = return () | null dups = return ()
...@@ -1676,42 +1686,57 @@ checkDuplicateModules pkg ...@@ -1676,42 +1686,57 @@ checkDuplicateModules pkg
unwords (map display dups)) unwords (map display dups))
where where
dups = [ m | (m:_:_) <- group (sort mods) ] dups = [ m | (m:_:_) <- group (sort mods) ]
mods = exposedModules pkg ++ hiddenModules pkg mods = map exposedName (exposedModules pkg) ++ hiddenModules pkg
++ map moduleReexportName (reexportedModules pkg)
-- | Validates an original module entry, either the origin of a module reexport
checkModuleReexports :: PackageDBStack -> InstalledPackageInfo -> Validate () -- or the backing implementation of a signature, by checking that it exists,
checkModuleReexports db_stack pkg = -- really is an original definition, and is accessible from the dependencies of
mapM_ checkReexport (reexportedModules pkg) -- the package.
where -- ToDo: If the original module in question is a backing signature
all_pkgs = allPackagesInStack db_stack -- implementation, then we should also check that the original module in
ipix = PackageIndex.fromList all_pkgs -- question is NOT a signature (however, if it is a reexport, then it's fine
-- for the original module to be a signature.)
checkReexport ModuleReexport { checkOriginalModule :: String
moduleReexportDefiningPackage = definingPkgId, -> PackageDBStack
moduleReexportDefiningName = definingModule -> InstalledPackageInfo
} = case if definingPkgId == installedPackageId pkg -> OriginalModule
then Just pkg -> Validate ()
else PackageIndex.lookupInstalledPackageId ipix definingPkgId of checkOriginalModule fieldName db_stack pkg
Nothing (OriginalModule definingPkgId definingModule) =
-> verror ForceAll ("module re-export refers to a non-existent " ++ 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: " ++ "defining package: " ++
display definingPkgId) display definingPkgId)
Just definingPkg Just definingPkg
| not (isIndirectDependency definingPkgId) | 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) " ++ "package that is not a direct (or indirect) " ++
"dependency of this package: " ++ "dependency of this package: " ++
display definingPkgId) display definingPkgId)
| definingModule `notElem` exposedModules definingPkg | otherwise
-> verror ForceAll ("module (self) re-export refers to a module " ++ -> 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 ++ " " ++ display definingModule ++ " " ++
"that is not defined and exposed in the " ++ "that is reexported but not defined in the " ++
"defining package " ++ display definingPkgId) "defining package " ++ display definingPkgId)
_ -> return ()
| otherwise where
-> return () all_pkgs = allPackagesInStack db_stack
ipix = PackageIndex.fromList all_pkgs
isIndirectDependency pkgid = fromMaybe False $ do isIndirectDependency pkgid = fromMaybe False $ do
thispkg <- graphVertex (installedPackageId pkg) 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