Simplify ghc-boot database representation with new type class.

Previously, we had an 'OriginalModule' type in ghc-boot which
was basically identical to 'Module', and we had to do a bit of
gyrating to get it converted into the right form.  This commit
introduces a new typeclass, 'DbModuleRep' which represents types
which we know how to serialize to and from the (now renamed) 'DbModule'
type.

The upshot is that we can just store 'Module's DIRECTLY in
the 'InstalledPackageInfo', no conversion needed.

I took the opportunity to clean up ghc-pkg to make its use of
the 'BinaryStringRep' classes more type safe.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

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

5 files changed, 93 insertions, 105 deletions

diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs
index 00511474f4..27b4f5e0b1 100644
--- a/compiler/basicTypes/Module.hs
+++ b/compiler/basicTypes/Module.hs
@@ -11,6 +11,7 @@ the keys.
 
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 module Module
     (
@@ -87,7 +88,7 @@ import FastString
 import Binary
 import Util
 import {-# SOURCE #-} Packages
-import GHC.PackageDb (BinaryStringRep(..))
+import GHC.PackageDb (BinaryStringRep(..), DbModuleRep(..), DbModule(..))
 
 import Data.Data
 import Data.Map (Map)
@@ -371,6 +372,10 @@ class ContainsModule t where
 class HasModule m where
     getModule :: m Module
 
+instance DbModuleRep UnitId ModuleName Module where
+  fromDbModule (DbModule uid mod_name) = mkModule uid mod_name
+  toDbModule mod = DbModule (moduleUnitId mod) (moduleName mod)
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index b19257bcea..cda8f7f12c 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, RecordWildCards #-}
+{-# LANGUAGE CPP, RecordWildCards, MultiParamTypeClasses #-}
 
 -- |
 -- Package configuration information: essentially the interface to Cabal, with
@@ -44,6 +44,7 @@ type PackageConfig = InstalledPackageInfo
                        PackageName
                        Module.UnitId
                        Module.ModuleName
+                       Module.Module
 
 -- TODO: there's no need for these to be FastString, as we don't need the uniq
 --       feature, but ghc doesn't currently have convenient support for any
@@ -83,22 +84,6 @@ 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) =
-    sep [ ppr exposedName
-        , case exposedReexport of
-            Just m -> sep [text "from", 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
 
@@ -119,10 +104,7 @@ pprPackageConfig InstalledPackageInfo {..} =
       field "version"              (text (showVersion packageVersion)),
       field "id"                   (ppr unitId),
       field "exposed"              (ppr exposed),
-      field "exposed-modules"
-        (if all isExposedModule exposedModules
-           then fsep (map pprExposedModule exposedModules)
-           else pprWithCommas pprExposedModule exposedModules),
+      field "exposed-modules"      (ppr exposedModules),
       field "hidden-modules"       (fsep (map ppr hiddenModules)),
       field "trusted"              (ppr trusted),
       field "import-dirs"          (fsep (map text importDirs)),
@@ -142,8 +124,6 @@ pprPackageConfig InstalledPackageInfo {..} =
     ]
   where
     field name body = text name <> colon <+> nest 4 body
-    isExposedModule (ExposedModule _ Nothing) = True
-    isExposedModule _ = False
 
 
 -- -----------------------------------------------------------------------------
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 0a8b279374..3c646a5a5d 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -768,8 +768,12 @@ findWiredInPackages dflags pkgs vis_map = do
                   | otherwise
                   = pkg
                 upd_deps pkg = pkg {
-                      depends = map upd_wired_in (depends pkg)
+                      depends = map upd_wired_in (depends pkg),
+                      exposedModules
+                        = map (\(k,v) -> (k, fmap upd_wired_in_mod v))
+                              (exposedModules pkg)
                     }
+                upd_wired_in_mod (Module uid m) = Module (upd_wired_in uid) m
                 upd_wired_in key
                     | Just key' <- Map.lookup key wiredInMap = key'
                     | otherwise = key
@@ -1155,11 +1159,11 @@ mkModuleToPkgConfAll dflags pkg_db vis_map =
 
     es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
     es e = do
-     ExposedModule m exposedReexport <- exposed_mods
+     (m, exposedReexport) <- exposed_mods
      let (pk', m', pkg', origin') =
           case exposedReexport of
            Nothing -> (pk, m, pkg, fromExposedModules e)
-           Just (OriginalModule pk' m') ->
+           Just (Module pk' m') ->
             let pkg' = pkg_lookup pk'
             in (pk', m', pkg', fromReexportedModules e pkg')
      return (m, sing pk' m' pkg' origin')
diff --git a/libraries/ghc-boot/GHC/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs
index 7ca64970e6..26bf67f98d 100644
--- a/libraries/ghc-boot/GHC/PackageDb.hs
+++ b/libraries/ghc-boot/GHC/PackageDb.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 -----------------------------------------------------------------------------
 -- |
@@ -36,9 +38,9 @@
 --
 module GHC.PackageDb (
        InstalledPackageInfo(..),
-       ExposedModule(..),
-       OriginalModule(..),
+       DbModule(..),
        BinaryStringRep(..),
+       DbModuleRep(..),
        emptyInstalledPackageInfo,
        readPackageDbForGhc,
        readPackageDbForGhcPkg,
@@ -65,7 +67,7 @@ import System.Directory
 -- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits
 -- that GHC is interested in.
 --
-data InstalledPackageInfo srcpkgid srcpkgname unitid modulename
+data InstalledPackageInfo srcpkgid srcpkgname unitid modulename mod
    = InstalledPackageInfo {
        unitId             :: unitid,
        sourcePackageId    :: srcpkgid,
@@ -86,7 +88,7 @@ data InstalledPackageInfo srcpkgid srcpkgname unitid modulename
        includeDirs        :: [FilePath],
        haddockInterfaces  :: [FilePath],
        haddockHTMLs       :: [FilePath],
-       exposedModules     :: [ExposedModule unitid modulename],
+       exposedModules     :: [(modulename, Maybe mod)],
        hiddenModules      :: [modulename],
        exposed            :: Bool,
        trusted            :: Bool
@@ -95,38 +97,25 @@ data InstalledPackageInfo srcpkgid srcpkgname unitid modulename
 
 -- | A convenience constraint synonym for common constraints over parameters
 -- to 'InstalledPackageInfo'.
-type RepInstalledPackageInfo srcpkgid srcpkgname unitid modulename =
+type RepInstalledPackageInfo srcpkgid srcpkgname unitid modulename mod =
     (BinaryStringRep srcpkgid, BinaryStringRep srcpkgname,
-     BinaryStringRep unitid, BinaryStringRep modulename)
+     BinaryStringRep unitid, BinaryStringRep modulename,
+     DbModuleRep unitid modulename mod)
 
--- | 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 unitid modulename
-   = OriginalModule {
-       originalPackageId :: unitid,
-       originalModuleName :: modulename
-     }
-  deriving (Eq, Show)
+-- | A type-class for the types which can be converted into 'DbModule'.
+-- NB: The functional dependency helps out type inference in cases
+-- where types would be ambiguous.
+class DbModuleRep unitid modulename mod
+    | mod -> unitid, unitid -> mod, mod -> modulename where
+  fromDbModule :: DbModule unitid modulename -> mod
+  toDbModule :: mod -> DbModule unitid 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).
--- Thus:
---
---  * @ExposedModule n Nothing@ represents an exposed module @n@ which
---    was defined in this package.
---
---  * @ExposedModule n (Just o)@ represents a reexported module @n@
---    which was originally defined in @o@.
---
--- We use a 'Maybe' data types instead of an ADT with two branches because this
--- representation allows us to treat reexports uniformly.
-data ExposedModule unitid modulename
-   = ExposedModule {
-       exposedName      :: modulename,
-       exposedReexport  :: Maybe (OriginalModule unitid modulename)
+-- | @ghc-boot@'s copy of 'Module', i.e. what is serialized to the database.
+-- Use 'DbModuleRep' to convert it into an actual 'Module'.
+data DbModule unitid modulename
+   = DbModule {
+       dbModuleUnitId :: unitid,
+       dbModuleName :: modulename
      }
   deriving (Eq, Show)
 
@@ -134,8 +123,8 @@ class BinaryStringRep a where
   fromStringRep :: BS.ByteString -> a
   toStringRep   :: a -> BS.ByteString
 
-emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d
-                          => InstalledPackageInfo a b c d
+emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e
+                          => InstalledPackageInfo a b c d e
 emptyInstalledPackageInfo =
   InstalledPackageInfo {
        unitId             = fromStringRep BS.empty,
@@ -165,8 +154,8 @@ emptyInstalledPackageInfo =
 
 -- | Read the part of the package DB that GHC is interested in.
 --
-readPackageDbForGhc :: RepInstalledPackageInfo a b c d =>
-                       FilePath -> IO [InstalledPackageInfo a b c d]
+readPackageDbForGhc :: RepInstalledPackageInfo a b c d e =>
+                       FilePath -> IO [InstalledPackageInfo a b c d e]
 readPackageDbForGhc file =
     decodeFromFile file getDbForGhc
   where
@@ -198,8 +187,8 @@ readPackageDbForGhcPkg file =
 
 -- | Write the whole of the package DB, both parts.
 --
-writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d) =>
-                  FilePath -> [InstalledPackageInfo a b c d] -> pkgs -> IO ()
+writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d e) =>
+                  FilePath -> [InstalledPackageInfo a b c d e] -> pkgs -> IO ()
 writePackageDb file ghcPkgs ghcPkgPart =
     writeFileAtomic file (runPut putDbForGhcPkg)
   where
@@ -285,8 +274,8 @@ writeFileAtomic targetPath content = do
         hClose handle
         renameFile tmpPath targetPath)
 
-instance (RepInstalledPackageInfo a b c d) =>
-         Binary (InstalledPackageInfo a b c d) where
+instance (RepInstalledPackageInfo a b c d e) =>
+         Binary (InstalledPackageInfo a b c d e) where
   put (InstalledPackageInfo
          unitId sourcePackageId
          packageName packageVersion
@@ -317,7 +306,8 @@ instance (RepInstalledPackageInfo a b c d) =>
     put includeDirs
     put haddockInterfaces
     put haddockHTMLs
-    put exposedModules
+    put (map (\(mod_name, mod) -> (toStringRep mod_name, fmap toDbModule mod))
+             exposedModules)
     put (map toStringRep hiddenModules)
     put exposed
     put trusted
@@ -326,7 +316,7 @@ instance (RepInstalledPackageInfo a b c d) =>
     sourcePackageId    <- get
     packageName        <- get
     packageVersion     <- get
-    unitId         <- get
+    unitId             <- get
     abiHash            <- get
     depends            <- get
     importDirs         <- get
@@ -358,28 +348,19 @@ instance (RepInstalledPackageInfo a b c d) =>
               ldOptions ccOptions
               includes includeDirs
               haddockInterfaces haddockHTMLs
-              exposedModules
+              (map (\(mod_name, mod) ->
+                        (fromStringRep mod_name, fmap fromDbModule mod))
+                   exposedModules)
               (map fromStringRep hiddenModules)
               exposed trusted)
 
 instance (BinaryStringRep a, BinaryStringRep b) =>
-         Binary (OriginalModule a b) where
-  put (OriginalModule originalPackageId originalModuleName) = do
-    put (toStringRep originalPackageId)
-    put (toStringRep originalModuleName)
-  get = do
-    originalPackageId <- get
-    originalModuleName <- get
-    return (OriginalModule (fromStringRep originalPackageId)
-                           (fromStringRep originalModuleName))
-
-instance (BinaryStringRep a, BinaryStringRep b) =>
-         Binary (ExposedModule a b) where
-  put (ExposedModule exposedName exposedReexport) = do
-    put (toStringRep exposedName)
-    put exposedReexport
+         Binary (DbModule a b) where
+  put (DbModule dbModuleUnitId dbModuleName) = do
+    put (toStringRep dbModuleUnitId)
+    put (toStringRep dbModuleName)
   get = do
-    exposedName <- get
-    exposedReexport <- get
-    return (ExposedModule (fromStringRep exposedName)
-                          exposedReexport)
+    dbModuleUnitId <- get
+    dbModuleName <- get
+    return (DbModule (fromStringRep dbModuleUnitId)
+                     (fromStringRep dbModuleName))
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 0845792198..af65eeed62 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -1,4 +1,7 @@
-{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
 --
@@ -12,6 +15,7 @@ module Main (main) where
 
 import Version ( version, targetOS, targetARCH )
 import qualified GHC.PackageDb as GhcPkg
+import GHC.PackageDb (BinaryStringRep(..))
 import qualified Distribution.Simple.PackageIndex as PackageIndex
 import qualified Data.Graph as Graph
 import qualified Distribution.ModuleName as ModuleName
@@ -1071,19 +1075,20 @@ updateDBCache verbosity db = do
       hPutChar handle c
 
 type PackageCacheFormat = GhcPkg.InstalledPackageInfo
-                            String     -- src package id
-                            String     -- package name
-                            String     -- unit id
-                            ModuleName -- module name
+                            PackageIdentifier
+                            PackageName
+                            UnitId
+                            ModuleName
+                            OriginalModule
 
 convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat
 convertPackageInfoToCacheFormat pkg =
     GhcPkg.InstalledPackageInfo {
-       GhcPkg.unitId             = display (installedUnitId pkg),
-       GhcPkg.sourcePackageId    = display (sourcePackageId pkg),
-       GhcPkg.packageName        = display (packageName pkg),
+       GhcPkg.unitId             = installedUnitId pkg,
+       GhcPkg.sourcePackageId    = sourcePackageId pkg,
+       GhcPkg.packageName        = packageName pkg,
        GhcPkg.packageVersion     = packageVersion pkg,
-       GhcPkg.depends            = map display (depends pkg),
+       GhcPkg.depends            = depends pkg,
        GhcPkg.abiHash            = let AbiHash abi = abiHash pkg
                                    in abi,
        GhcPkg.importDirs         = importDirs pkg,
@@ -1104,19 +1109,32 @@ convertPackageInfoToCacheFormat pkg =
        GhcPkg.exposed            = exposed pkg,
        GhcPkg.trusted            = trusted pkg
     }
-  where convertExposed (ExposedModule n reexport) =
-            GhcPkg.ExposedModule n (fmap convertOriginal reexport)
-        convertOriginal (OriginalModule ipid m) =
-            GhcPkg.OriginalModule (display ipid) m
+  where convertExposed (ExposedModule n reexport) = (n, reexport)
+
+instance GhcPkg.BinaryStringRep PackageName where
+  fromStringRep = PackageName . fromStringRep
+  toStringRep   = toStringRep . display
+
+instance GhcPkg.BinaryStringRep PackageIdentifier where
+  fromStringRep = fromMaybe (error "BinaryStringRep PackageIdentifier")
+                . simpleParse . fromStringRep
+  toStringRep = toStringRep . display
+
+instance GhcPkg.BinaryStringRep UnitId where
+  fromStringRep = mkUnitId . fromStringRep
+  toStringRep (SimpleUnitId (ComponentId cid_str)) = toStringRep cid_str
 
 instance GhcPkg.BinaryStringRep ModuleName where
-  fromStringRep = ModuleName.fromString . fromUTF8 . BS.unpack
-  toStringRep   = BS.pack . toUTF8 . display
+  fromStringRep = ModuleName.fromString . fromStringRep
+  toStringRep   = toStringRep . display
 
 instance GhcPkg.BinaryStringRep String where
   fromStringRep = fromUTF8 . BS.unpack
   toStringRep   = BS.pack . toUTF8
 
+instance GhcPkg.DbModuleRep UnitId ModuleName OriginalModule where
+  fromDbModule (GhcPkg.DbModule uid mod_name) = OriginalModule uid mod_name
+  toDbModule (OriginalModule uid mod_name) = GhcPkg.DbModule uid mod_name
 
 -- -----------------------------------------------------------------------------
 -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar