Generalize exposed-modules field in installed package database
authorEdward Z. Yang <ezyang@cs.stanford.edu>
Sat, 15 Nov 2014 08:08:53 +0000 (00:08 -0800)
committerEdward Z. Yang <ezyang@cs.stanford.edu>
Sat, 15 Nov 2014 08:36:03 +0000 (00:36 -0800)
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: Edward Z. Yang <ezyang@cs.stanford.edu>
Test Plan: validate

Reviewers: simonpj, duncan, austin

Subscribers: thomie, carter, simonmar

Differential Revision: https://phabricator.haskell.org/D421

compiler/main/PackageConfig.hs
compiler/main/Packages.lhs
libraries/Cabal
libraries/bin-package-db/GHC/PackageDb.hs
testsuite/tests/cabal/Makefile
testsuite/tests/cabal/ghcpkg07.stdout
testsuite/tests/cabal/test7a.pkg
testsuite/tests/cabal/test7b.pkg
utils/ghc-pkg/Main.hs

index 3f2bf16..b94ea65 100644 (file)
@@ -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
 
 
 -- -----------------------------------------------------------------------------
index a308a99..d757461 100644 (file)
@@ -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
index bb7e8f8..1f8a0a2 160000 (submodule)
@@ -1 +1 @@
-Subproject commit bb7e8f8b0170deb9c0486b10f4a9898503427d9f
+Subproject commit 1f8a0a20c7a010b50fbafc0effde9bcd663d8716
index 76fa697..e1715e6 100644 (file)
@@ -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)
index 062850f..1e4cd69 100644 (file)
@@ -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
index b76e795..717a997 100644 (file)
@@ -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
index b94f766..7eaeea2 100644 (file)
@@ -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
index 8089bd4..f0bc687 100644 (file)
@@ -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
index dd00429..a67dbb2 100644 (file)
@@ -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)