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

3 files changed, 16 insertions, 27 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')