Refactor UnitInfo load/store from databases

Converting between UnitInfo stored in package databases and UnitInfo as
they are used in ghc-pkg and ghc was done in a very convoluted way (via
BinaryStringRep and DbUnitModuleRep type classes using fun deps, etc.).
It was difficult to understand and even more to modify (I wanted to
try to use a GADT for UnitId but fun deps got in the way).

The new code uses much more straightforward functions to convert between
the different representations. Much simpler.

5 files changed, 158 insertions, 201 deletions

diff --git a/compiler/GHC/Driver/Packages.hs b/compiler/GHC/Driver/Packages.hs
index 345f0dc1ed..3b0cf0525a 100644
--- a/compiler/GHC/Driver/Packages.hs
+++ b/compiler/GHC/Driver/Packages.hs
@@ -592,7 +592,7 @@ readPackageDatabase dflags conf_file = do
       conf_file' = dropTrailingPathSeparator conf_file
       top_dir = topDir dflags
       pkgroot = takeDirectory conf_file'
-      pkg_configs1 = map (mungeUnitInfo top_dir pkgroot)
+      pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . toUnitInfo)
                          proto_pkg_configs
   --
   return $ PackageDatabase conf_file' pkg_configs1
diff --git a/compiler/GHC/Types/Module.hs b/compiler/GHC/Types/Module.hs
index 76bc026ea3..eb27d6a153 100644
--- a/compiler/GHC/Types/Module.hs
+++ b/compiler/GHC/Types/Module.hs
@@ -150,7 +150,6 @@ import GHC.Utils.Misc
 import Data.List (sortBy, sort)
 import Data.Ord
 import Data.Version
-import GHC.PackageDb
 import GHC.Utils.Fingerprint
 
 import qualified Data.ByteString as BS
@@ -344,10 +343,6 @@ instance Binary ModuleName where
   put_ bh (ModuleName fs) = put_ bh fs
   get bh = do fs <- get bh; return (ModuleName fs)
 
-instance BinaryStringRep ModuleName where
-  fromStringRep = mkModuleNameFS . mkFastStringByteString
-  toStringRep   = bytesFS . moduleNameFS
-
 instance Data ModuleName where
   -- don't traverse?
   toConstr _   = abstractConstr "ModuleName"
@@ -492,15 +487,6 @@ class ContainsModule t where
 class HasModule m where
     getModule :: m Module
 
-instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where
-  fromDbModule (DbModule uid mod_name)  = mkModule uid mod_name
-  fromDbModule (DbModuleVar mod_name)   = mkHoleModule mod_name
-  fromDbUnitId (DbUnitId cid insts)     = newUnitId cid insts
-  fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid)
-  -- GHC never writes to the database, so it's not needed
-  toDbModule = error "toDbModule: not implemented"
-  toDbUnitId = error "toDbUnitId: not implemented"
-
 {-
 ************************************************************************
 *                                                                      *
@@ -535,10 +521,6 @@ data ComponentDetails = ComponentDetails
    , componentSourcePkdId    :: String
    }
 
-instance BinaryStringRep ComponentId where
-  fromStringRep bs = ComponentId (mkFastStringByteString bs) Nothing
-  toStringRep (ComponentId s _) = bytesFS s
-
 instance Uniquable ComponentId where
   getUnique (ComponentId n _) = getUnique n
 
@@ -700,11 +682,6 @@ instance Binary InstalledUnitId where
   put_ bh (InstalledUnitId fs) = put_ bh fs
   get bh = do fs <- get bh; return (InstalledUnitId fs)
 
-instance BinaryStringRep InstalledUnitId where
-  fromStringRep bs = InstalledUnitId (mkFastStringByteString bs)
-  -- GHC doesn't write to database
-  toStringRep   = error "BinaryStringRep InstalledUnitId: not implemented"
-
 instance Eq InstalledUnitId where
     uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2
 
@@ -858,7 +835,7 @@ unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles
 hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString
 hashUnitId cid sorted_holes =
     mkFastStringByteString
-  . fingerprintUnitId (toStringRep cid)
+  . fingerprintUnitId (bytesFS (componentIdRaw cid))
   $ rawHashUnitId sorted_holes
 
 -- | Generate a hash for a sorted module substitution.
@@ -867,9 +844,9 @@ rawHashUnitId sorted_holes =
     fingerprintByteString
   . BS.concat $ do
         (m, b) <- sorted_holes
-        [ toStringRep m,                BS.Char8.singleton ' ',
+        [ bytesFS (moduleNameFS m),                BS.Char8.singleton ' ',
           bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':',
-          toStringRep (moduleName b),   BS.Char8.singleton '\n']
+          bytesFS (moduleNameFS (moduleName b)),   BS.Char8.singleton '\n']
 
 fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString
 fingerprintUnitId prefix (Fingerprint a b)
diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs
index 010bb5ebf3..8a6558f94c 100644
--- a/compiler/GHC/Unit/Info.hs
+++ b/compiler/GHC/Unit/Info.hs
@@ -17,6 +17,7 @@ module GHC.Unit.Info (
 
         -- * The UnitInfo type: information about a unit
         UnitInfo,
+        toUnitInfo,
         GenericUnitInfo(..),
         ComponentId(..),
         PackageId(..),
@@ -33,6 +34,7 @@ import GHC.Prelude
 
 import GHC.PackageDb
 import Data.Version
+import Data.Bifunctor
 
 import GHC.Data.FastString
 import GHC.Utils.Outputable
@@ -48,10 +50,32 @@ type UnitInfo = GenericUnitInfo
                        PackageId
                        PackageName
                        Module.InstalledUnitId
-                       Module.UnitId
                        Module.ModuleName
                        Module.Module
 
+-- | Convert a DbUnitInfo (read from a package database) into `UnitInfo`
+toUnitInfo :: DbUnitInfo -> UnitInfo
+toUnitInfo = mapGenericUnitInfo
+   mkUnitId'
+   mkComponentId'
+   mkPackageIdentifier'
+   mkPackageName'
+   mkModuleName'
+   mkModule'
+   where
+     mkPackageIdentifier' = PackageId       . mkFastStringByteString
+     mkPackageName'       = PackageName     . mkFastStringByteString
+     mkUnitId'            = InstalledUnitId . mkFastStringByteString
+     mkModuleName'        = mkModuleNameFS  . mkFastStringByteString
+     mkComponentId' cid   = ComponentId (mkFastStringByteString cid) Nothing
+     mkInstUnitId' i = case i of
+      DbInstUnitId cid insts -> newUnitId (mkComponentId' cid) (fmap (bimap mkModuleName' mkModule') insts)
+      DbUnitId uid           -> DefiniteUnitId (DefUnitId (mkUnitId' uid))
+     mkModule' m = case m of
+       DbModule uid n -> mkModule (mkInstUnitId' uid) (mkModuleName' n)
+       DbModuleVar  n -> mkHoleModule (mkModuleName' n)
+
+
 -- 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
 --       other compact string types, e.g. plain ByteString or Text.
@@ -62,14 +86,6 @@ newtype PackageName = PackageName
    }
    deriving (Eq, Ord)
 
-instance BinaryStringRep PackageId where
-  fromStringRep = PackageId . mkFastStringByteString
-  toStringRep (PackageId s) = bytesFS s
-
-instance BinaryStringRep PackageName where
-  fromStringRep = PackageName . mkFastStringByteString
-  toStringRep (PackageName s) = bytesFS s
-
 instance Uniquable PackageId where
   getUnique (PackageId n) = getUnique n
 
diff --git a/libraries/ghc-boot/GHC/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs
index bc6cdbcc6d..e8daedda66 100644
--- a/libraries/ghc-boot/GHC/PackageDb.hs
+++ b/libraries/ghc-boot/GHC/PackageDb.hs
@@ -1,17 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TupleSections #-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE RecordWildCards #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.PackageDb
@@ -48,6 +49,10 @@
 --
 module GHC.PackageDb
    ( GenericUnitInfo(..)
+   , type DbUnitInfo
+   , DbModule (..)
+   , DbInstUnitId (..)
+   , mapGenericUnitInfo
    -- * Read and write
    , DbMode(..)
    , DbOpenMode(..)
@@ -59,11 +64,6 @@ module GHC.PackageDb
    , PackageDbLock
    , lockPackageDb
    , unlockPackageDb
-   -- * Misc
-   , DbModule(..)
-   , DbUnitId(..)
-   , BinaryStringRep(..)
-   , DbUnitIdModuleRep(..)
    )
 where
 
@@ -75,6 +75,7 @@ import qualified Data.ByteString.Lazy as BS.Lazy
 import qualified Data.ByteString.Lazy.Internal as BS.Lazy (defaultChunkSize)
 import qualified Data.Foldable as F
 import qualified Data.Traversable as F
+import Data.Bifunctor
 import Data.Binary as Bin
 import Data.Binary.Put as Bin
 import Data.Binary.Get as Bin
@@ -87,6 +88,8 @@ import GHC.IO.Exception (IOErrorType(InappropriateType))
 import GHC.IO.Handle.Lock
 import System.Directory
 
+-- | @ghc-boot@'s UnitInfo, serialized to the database.
+type DbUnitInfo      = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule
 
 -- | Information about an unit (a unit is an installed module library).
 --
@@ -96,8 +99,8 @@ import System.Directory
 -- Some types are left as parameters to be instantiated differently in ghc-pkg
 -- and in ghc itself.
 --
-data GenericUnitInfo compid srcpkgid srcpkgname instunitid unitid modulename mod = GenericUnitInfo
-   { unitId             :: instunitid
+data GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod = GenericUnitInfo
+   { unitId             :: uid
       -- ^ Unique unit identifier that is used during compilation (e.g. to
       -- generate symbols).
 
@@ -138,10 +141,10 @@ data GenericUnitInfo compid srcpkgid srcpkgname instunitid unitid modulename mod
       -- ^ ABI hash used to avoid mixing up units compiled with different
       -- dependencies, compiler, options, etc.
 
-   , unitDepends        :: [instunitid]
+   , unitDepends        :: [uid]
       -- ^ Identifiers of the units this one depends on
 
-   , unitAbiDepends     :: [(instunitid, String)]
+   , unitAbiDepends     :: [(uid, String)]
      -- ^ Like 'unitDepends', but each dependency is annotated with the ABI hash
      -- we expect the dependency to respect.
 
@@ -234,52 +237,52 @@ data GenericUnitInfo compid srcpkgid srcpkgname instunitid unitid modulename mod
    }
    deriving (Eq, Show)
 
--- | A convenience constraint synonym for common constraints over parameters
--- to 'GenericUnitInfo'.
-type RepGenericUnitInfo compid srcpkgid srcpkgname instunitid unitid modulename mod =
-    (BinaryStringRep srcpkgid, BinaryStringRep srcpkgname,
-     BinaryStringRep modulename, BinaryStringRep compid,
-     BinaryStringRep instunitid,
-     DbUnitIdModuleRep instunitid compid unitid modulename mod)
-
--- | A type-class for the types which can be converted into 'DbModule'/'DbUnitId'.
--- There is only one type class because these types are mutually recursive.
--- NB: The functional dependency helps out type inference in cases
--- where types would be ambiguous.
-class DbUnitIdModuleRep instunitid compid unitid modulename mod
-    | mod -> unitid, unitid -> mod, mod -> modulename, unitid -> compid, unitid -> instunitid
-    where
-  fromDbModule :: DbModule instunitid compid unitid modulename mod -> mod
-  toDbModule :: mod -> DbModule instunitid compid unitid modulename mod
-  fromDbUnitId :: DbUnitId instunitid compid unitid modulename mod -> unitid
-  toDbUnitId :: unitid -> DbUnitId instunitid compid unitid modulename mod
-
--- | @ghc-boot@'s copy of 'Module', i.e. what is serialized to the database.
--- Use 'DbUnitIdModuleRep' to convert it into an actual 'Module'.
--- It has phantom type parameters as this is the most convenient way
--- to avoid undecidable instances.
-data DbModule instunitid compid unitid modulename mod
-   = DbModule {
-       dbModuleUnitId :: unitid,
-       dbModuleName :: modulename
+-- | Convert between GenericUnitInfo instances
+mapGenericUnitInfo
+   :: (uid1 -> uid2)
+   -> (cid1 -> cid2)
+   -> (srcpkg1 -> srcpkg2)
+   -> (srcpkgname1 -> srcpkgname2)
+   -> (modname1 -> modname2)
+   -> (mod1 -> mod2)
+   -> (GenericUnitInfo cid1 srcpkg1 srcpkgname1 uid1 modname1 mod1
+       -> GenericUnitInfo cid2 srcpkg2 srcpkgname2 uid2 modname2 mod2)
+mapGenericUnitInfo fuid fcid fsrcpkg fsrcpkgname fmodname fmod g@(GenericUnitInfo {..}) =
+   g { unitId              = fuid unitId
+     , unitInstanceOf      = fcid unitInstanceOf
+     , unitInstantiations  = fmap (bimap fmodname fmod) unitInstantiations
+     , unitPackageId       = fsrcpkg unitPackageId
+     , unitPackageName     = fsrcpkgname unitPackageName
+     , unitComponentName   = fmap fsrcpkgname unitComponentName
+     , unitDepends         = fmap fuid unitDepends
+     , unitAbiDepends      = fmap (first fuid) unitAbiDepends
+     , unitExposedModules  = fmap (bimap fmodname (fmap fmod)) unitExposedModules
+     , unitHiddenModules   = fmap fmodname unitHiddenModules
      }
-   | DbModuleVar {
-       dbModuleVarName :: modulename
-     }
-  deriving (Eq, Show)
 
--- | @ghc-boot@'s copy of 'UnitId', i.e. what is serialized to the database.
--- Use 'DbUnitIdModuleRep' to convert it into an actual 'UnitId'.
--- It has phantom type parameters as this is the most convenient way
--- to avoid undecidable instances.
-data DbUnitId instunitid compid unitid modulename mod
-   = DbUnitId compid [(modulename, mod)]
-   | DbInstalledUnitId instunitid
-  deriving (Eq, Show)
+-- | @ghc-boot@'s 'Module', serialized to the database.
+data DbModule
+   = DbModule
+      { dbModuleUnitId  :: DbInstUnitId
+      , dbModuleName    :: BS.ByteString
+      }
+   | DbModuleVar
+      { dbModuleVarName :: BS.ByteString
+      }
+   deriving (Eq, Show)
+
+-- | @ghc-boot@'s instantiated unit id, serialized to the database.
+data DbInstUnitId
+
+   -- | Instantiated unit
+   = DbInstUnitId
+      BS.ByteString               -- component id
+      [(BS.ByteString, DbModule)] -- instantiations: [(modulename,module)]
 
-class BinaryStringRep a where
-  fromStringRep :: BS.ByteString -> a
-  toStringRep   :: a -> BS.ByteString
+   -- | Uninstantiated unit
+   | DbUnitId
+      BS.ByteString               -- unit id
+  deriving (Eq, Show)
 
 -- | Represents a lock of a package db.
 newtype PackageDbLock = PackageDbLock Handle
@@ -358,8 +361,7 @@ isDbOpenReadMode = \case
 
 -- | Read the part of the package DB that GHC is interested in.
 --
-readPackageDbForGhc :: RepGenericUnitInfo a b c d e f g =>
-                       FilePath -> IO [GenericUnitInfo a b c d e f g]
+readPackageDbForGhc :: FilePath -> IO [DbUnitInfo]
 readPackageDbForGhc file =
   decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case
     (pkgs, DbOpenReadOnly) -> return pkgs
@@ -397,9 +399,7 @@ readPackageDbForGhcPkg file mode =
 
 -- | Write the whole of the package DB, both parts.
 --
-writePackageDb :: (Binary pkgs, RepGenericUnitInfo a b c d e f g) =>
-                  FilePath -> [GenericUnitInfo a b c d e f g] ->
-                  pkgs -> IO ()
+writePackageDb :: Binary pkgs => FilePath -> [DbUnitInfo] -> pkgs -> IO ()
 writePackageDb file ghcPkgs ghcPkgPart =
   writeFileAtomic file (runPut putDbForGhcPkg)
   where
@@ -504,8 +504,7 @@ writeFileAtomic targetPath content = do
         hClose handle
         renameFile tmpPath targetPath)
 
-instance (RepGenericUnitInfo a b c d e f g) =>
-         Binary (GenericUnitInfo a b c d e f g) where
+instance Binary DbUnitInfo where
   put (GenericUnitInfo
          unitId unitInstanceOf unitInstantiations
          unitPackageId
@@ -520,17 +519,16 @@ instance (RepGenericUnitInfo a b c d e f g) =>
          unitHaddockInterfaces unitHaddockHTMLs
          unitExposedModules unitHiddenModules
          unitIsIndefinite unitIsExposed unitIsTrusted) = do
-    put (toStringRep unitPackageId)
-    put (toStringRep unitPackageName)
+    put unitPackageId
+    put unitPackageName
     put unitPackageVersion
-    put (fmap toStringRep unitComponentName)
-    put (toStringRep unitId)
-    put (toStringRep unitInstanceOf)
-    put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod))
-             unitInstantiations)
+    put unitComponentName
+    put unitId
+    put unitInstanceOf
+    put unitInstantiations
     put unitAbiHash
-    put (map toStringRep unitDepends)
-    put (map (\(k,v) -> (toStringRep k, v)) unitAbiDepends)
+    put unitDepends
+    put unitAbiDepends
     put unitImportDirs
     put unitLibraries
     put unitExtDepLibsSys
@@ -545,9 +543,8 @@ instance (RepGenericUnitInfo a b c d e f g) =>
     put unitIncludeDirs
     put unitHaddockInterfaces
     put unitHaddockHTMLs
-    put (map (\(mod_name, mb_mod) -> (toStringRep mod_name, fmap toDbModule mb_mod))
-             unitExposedModules)
-    put (map toStringRep unitHiddenModules)
+    put unitExposedModules
+    put unitHiddenModules
     put unitIsIndefinite
     put unitIsExposed
     put unitIsTrusted
@@ -583,16 +580,16 @@ instance (RepGenericUnitInfo a b c d e f g) =>
     unitIsExposed      <- get
     unitIsTrusted      <- get
     return (GenericUnitInfo
-              (fromStringRep unitId)
-              (fromStringRep unitInstanceOf)
-              (map (\(mod_name, mod) -> (fromStringRep mod_name, fromDbModule mod))
-                unitInstantiations)
-              (fromStringRep unitPackageId)
-              (fromStringRep unitPackageName) unitPackageVersion
-              (fmap fromStringRep unitComponentName)
+              unitId
+              unitInstanceOf
+              unitInstantiations
+              unitPackageId
+              unitPackageName
+              unitPackageVersion
+              unitComponentName
               unitAbiHash
-              (map fromStringRep unitDepends)
-              (map (\(k,v) -> (fromStringRep k, v)) unitAbiDepends)
+              unitDepends
+              unitAbiDepends
               unitImportDirs
               unitLibraries unitExtDepLibsSys unitExtDepLibsGhc
               libraryDirs libraryDynDirs
@@ -600,55 +597,35 @@ instance (RepGenericUnitInfo a b c d e f g) =>
               unitLinkerOptions unitCcOptions
               unitIncludes unitIncludeDirs
               unitHaddockInterfaces unitHaddockHTMLs
-              (map (\(mod_name, mb_mod) ->
-                        (fromStringRep mod_name, fmap fromDbModule mb_mod))
-                   unitExposedModules)
-              (map fromStringRep unitHiddenModules)
+              unitExposedModules
+              unitHiddenModules
               unitIsIndefinite unitIsExposed unitIsTrusted)
 
-instance (BinaryStringRep modulename, BinaryStringRep compid,
-          BinaryStringRep instunitid,
-          DbUnitIdModuleRep instunitid compid unitid modulename mod) =>
-         Binary (DbModule instunitid compid unitid modulename mod) where
+instance Binary DbModule where
   put (DbModule dbModuleUnitId dbModuleName) = do
     putWord8 0
-    put (toDbUnitId dbModuleUnitId)
-    put (toStringRep dbModuleName)
+    put dbModuleUnitId
+    put dbModuleName
   put (DbModuleVar dbModuleVarName) = do
     putWord8 1
-    put (toStringRep dbModuleVarName)
+    put dbModuleVarName
   get = do
     b <- getWord8
     case b of
-      0 -> do dbModuleUnitId <- get
-              dbModuleName <- get
-              return (DbModule (fromDbUnitId dbModuleUnitId)
-                               (fromStringRep dbModuleName))
-      _ -> do dbModuleVarName <- get
-              return (DbModuleVar (fromStringRep dbModuleVarName))
-
-instance (BinaryStringRep modulename, BinaryStringRep compid,
-          BinaryStringRep instunitid,
-          DbUnitIdModuleRep instunitid compid unitid modulename mod) =>
-         Binary (DbUnitId instunitid compid unitid modulename mod) where
-  put (DbInstalledUnitId instunitid) = do
+      0 -> DbModule <$> get <*> get
+      _ -> DbModuleVar <$> get
+
+instance Binary DbInstUnitId where
+  put (DbUnitId uid) = do
     putWord8 0
-    put (toStringRep instunitid)
-  put (DbUnitId dbUnitIdComponentId dbUnitIdInsts) = do
+    put uid
+  put (DbInstUnitId dbUnitIdComponentId dbUnitIdInsts) = do
     putWord8 1
-    put (toStringRep dbUnitIdComponentId)
-    put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) dbUnitIdInsts)
+    put dbUnitIdComponentId
+    put dbUnitIdInsts
+
   get = do
     b <- getWord8
     case b of
-      0 -> do
-        instunitid <- get
-        return (DbInstalledUnitId (fromStringRep instunitid))
-      _ -> do
-        dbUnitIdComponentId <- get
-        dbUnitIdInsts <- get
-        return (DbUnitId
-            (fromStringRep dbUnitIdComponentId)
-            (map (\(mod_name, mod) -> ( fromStringRep mod_name
-                                      , fromDbModule mod))
-                 dbUnitIdInsts))
+      0 -> DbUnitId <$> get
+      _ -> DbInstUnitId <$> get <*> get
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 23ddc5159b..2e2238ccb8 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -31,7 +31,7 @@
 module Main (main) where
 
 import qualified GHC.PackageDb as GhcPkg
-import GHC.PackageDb (BinaryStringRep(..))
+import GHC.PackageDb
 import GHC.HandleEncoding
 import GHC.BaseDir (getBaseDir)
 import GHC.Settings.Platform (getTargetPlatform)
@@ -50,11 +50,12 @@ import Distribution.Package hiding (installedUnitId)
 import Distribution.Text
 import Distribution.Version
 import Distribution.Backpack
+import Distribution.Pretty (Pretty (..))
 import Distribution.Types.UnqualComponentName
 import Distribution.Types.LibraryName
 import Distribution.Types.MungedPackageName
 import Distribution.Types.MungedPackageId
-import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS, writeUTF8File, readUTF8File)
+import Distribution.Simple.Utils (toUTF8BS, writeUTF8File, readUTF8File)
 import qualified Data.Version as Version
 import System.FilePath as FilePath
 import qualified System.FilePath.Posix as FilePath.Posix
@@ -67,6 +68,7 @@ import Prelude
 import System.Console.GetOpt
 import qualified Control.Exception as Exception
 import Data.Maybe
+import Data.Bifunctor
 
 import Data.Char ( toLower )
 import Control.Monad
@@ -1297,7 +1299,8 @@ updateDBCache verbosity db db_stack = do
   when (verbosity > Normal) $
       infoLn ("writing cache " ++ filename)
 
-  GhcPkg.writePackageDb filename (map fst pkgsGhcCacheFormat) pkgsCabalFormat
+  let d = fmap (fromPackageCacheFormat . fst) pkgsGhcCacheFormat
+  GhcPkg.writePackageDb filename d pkgsCabalFormat
     `catchIO` \e ->
       if isPermissionError e
       then die $ filename ++ ": you don't have permission to modify this file"
@@ -1311,7 +1314,6 @@ type PackageCacheFormat = GhcPkg.GenericUnitInfo
                             PackageIdentifier
                             PackageName
                             UnitId
-                            OpenUnitId
                             ModuleName
                             OpenModule
 
@@ -1363,6 +1365,28 @@ recomputeValidAbiDeps db pkg =
     abiDepsUpdated =
       GhcPkg.unitAbiDepends pkg /= newAbiDeps
 
+
+-- | Convert from PackageCacheFormat to DbUnitInfo (the format used in
+-- Ghc.PackageDb to store into the database)
+fromPackageCacheFormat :: PackageCacheFormat -> GhcPkg.DbUnitInfo
+fromPackageCacheFormat = GhcPkg.mapGenericUnitInfo
+     mkUnitId' mkComponentId' mkPackageIdentifier' mkPackageName' mkModuleName' mkModule'
+   where
+     displayBS :: Pretty a => a -> BS.ByteString
+     displayBS            = toUTF8BS . display
+     mkPackageIdentifier' = displayBS
+     mkPackageName'       = displayBS
+     mkComponentId'       = displayBS
+     mkUnitId'            = displayBS
+     mkModuleName'        = displayBS
+     mkInstUnitId' i      = case i of
+       IndefFullUnitId cid insts -> DbInstUnitId (mkComponentId' cid)
+                                                 (fmap (bimap mkModuleName' mkModule') (Map.toList insts))
+       DefiniteUnitId uid        -> DbUnitId (mkUnitId' (unDefUnitId uid))
+     mkModule' m = case m of
+       OpenModule uid n -> DbModule (mkInstUnitId' uid) (mkModuleName' n)
+       OpenModuleVar n  -> DbModuleVar  (mkModuleName' n)
+
 convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat
 convertPackageInfoToCacheFormat pkg =
     GhcPkg.GenericUnitInfo {
@@ -1400,43 +1424,6 @@ convertPackageInfoToCacheFormat pkg =
   where
     convertExposed (ExposedModule n reexport) = (n, reexport)
 
-instance GhcPkg.BinaryStringRep ComponentId where
-  fromStringRep = mkComponentId . fromStringRep
-  toStringRep   = toStringRep . display
-
-instance GhcPkg.BinaryStringRep PackageName where
-  fromStringRep = mkPackageName . fromStringRep
-  toStringRep   = toStringRep . display
-
-instance GhcPkg.BinaryStringRep PackageIdentifier where
-  fromStringRep = fromMaybe (error "BinaryStringRep PackageIdentifier")
-                . simpleParse . fromStringRep
-  toStringRep = toStringRep . display
-
-instance GhcPkg.BinaryStringRep ModuleName where
-  fromStringRep = ModuleName.fromString . fromStringRep
-  toStringRep   = toStringRep . display
-
-instance GhcPkg.BinaryStringRep String where
-  fromStringRep = fromUTF8BS
-  toStringRep   = toUTF8BS
-
-instance GhcPkg.BinaryStringRep UnitId where
-  fromStringRep = mkUnitId . fromStringRep
-  toStringRep   = toStringRep . display
-
-instance GhcPkg.DbUnitIdModuleRep UnitId ComponentId OpenUnitId ModuleName OpenModule where
-  fromDbModule (GhcPkg.DbModule uid mod_name) = OpenModule uid mod_name
-  fromDbModule (GhcPkg.DbModuleVar mod_name) = OpenModuleVar mod_name
-  toDbModule (OpenModule uid mod_name) = GhcPkg.DbModule uid mod_name
-  toDbModule (OpenModuleVar mod_name) = GhcPkg.DbModuleVar mod_name
-  fromDbUnitId (GhcPkg.DbUnitId cid insts) = IndefFullUnitId cid (Map.fromList insts)
-  fromDbUnitId (GhcPkg.DbInstalledUnitId uid)
-    = DefiniteUnitId (unsafeMkDefUnitId uid)
-  toDbUnitId (IndefFullUnitId cid insts) = GhcPkg.DbUnitId cid (Map.toList insts)
-  toDbUnitId (DefiniteUnitId def_uid)
-    = GhcPkg.DbInstalledUnitId (unDefUnitId def_uid)
-
 -- -----------------------------------------------------------------------------
 -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar