Use ghc-local types for packages, rather than Cabal types

Also start using the new package db file format properly, by using the
ghc-specific section.

This is the main patch in the series for removing the compiler's dep
on the Cabal lib.

3 files changed, 123 insertions, 94 deletions

diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs
index f9c7e2eee0..8b9a5e9547 100644
--- a/compiler/main/Finder.lhs
+++ b/compiler/main/Finder.lhs
@@ -42,7 +42,6 @@ import UniqFM
 import Maybes           ( expectJust )
 import Exception        ( evaluate )
 
-import Distribution.Text
 import Data.IORef       ( IORef, writeIORef, readIORef, atomicModifyIORef )
 import System.Directory
 import System.FilePath
@@ -616,17 +615,17 @@ cantFindErr cannot_find _ dflags mod_name find_result
         | otherwise =
                hang (ptext (sLit "Locations searched:")) 2 $ vcat (map text files)
 
-    pkg_hidden pkg =
-        ptext (sLit "It is a member of the hidden package") <+> quotes (ppr pkg)
-        <> dot $$ cabal_pkg_hidden_hint pkg
-    cabal_pkg_hidden_hint pkg
+    pkg_hidden pkgid =
+        ptext (sLit "It is a member of the hidden package") <+> quotes (ppr pkgid)
+        --FIXME: we don't really want to show the package key here we should
+        -- show the source package id or installed package id if it's ambiguous
+        <> dot $$ cabal_pkg_hidden_hint pkgid
+    cabal_pkg_hidden_hint pkgid
      | gopt Opt_BuildingCabalPackage dflags
-        = case simpleParse (packageKeyString pkg) of
-          Just pid ->
-              ptext (sLit "Perhaps you need to add") <+>
-              quotes (text (display (pkgName pid))) <+>
+        = let pkg = expectJust "cabal_pkg_hidden_hint" (lookupPackage dflags pkgid)
+           in ptext (sLit "Perhaps you need to add") <+>
+              quotes (ppr (packageName pkg)) <+>
               ptext (sLit "to the build-depends in your .cabal file.")
-          Nothing -> empty
      | otherwise = empty
 
     mod_hidden pkg =
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index 864980be9d..09ff0659b3 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -10,39 +10,103 @@ module PackageConfig (
         -- $package_naming
 
         -- * PackageKey
-        mkPackageKey, packageConfigId,
+        packageConfigId,
 
         -- * The PackageConfig type: information about a package
         PackageConfig,
-        InstalledPackageInfo_(..), display,
+        InstalledPackageInfo(..),
+        InstalledPackageId(..),
+        SourcePackageId(..),
+        PackageName(..),
         Version(..),
-        PackageIdentifier(..),
         defaultPackageConfig,
-        packageConfigToInstalledPackageInfo,
-        installedPackageInfoToPackageConfig
+        installedPackageIdString,
+        sourcePackageIdString,
+        packageNameString,
+        showInstalledPackageInfo,
     ) where
 
 #include "HsVersions.h"
 
-import Distribution.InstalledPackageInfo
-import Distribution.ModuleName
-import Distribution.Package hiding (PackageKey, mkPackageKey)
-import qualified Distribution.Package as Cabal
-import Distribution.Text
-import Distribution.Version
+import GHC.PackageDb
+import qualified Data.ByteString.Char8 as BS
+import Data.Version
 
-import Maybes
+import Outputable
 import Module
 
 -- -----------------------------------------------------------------------------
--- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we
--- might need to extend it with some GHC-specific stuff, but for now it's fine.
+-- Our PackageConfig type is the InstalledPackageInfo from bin-package-db,
+-- which is similar to a subset of the InstalledPackageInfo type from Cabal.
 
-type PackageConfig = InstalledPackageInfo_ Module.ModuleName
+type PackageConfig = InstalledPackageInfo
+                       InstalledPackageId
+                       SourcePackageId
+                       PackageName
+                       Module.PackageKey
+                       Module.ModuleName
+
+newtype InstalledPackageId = InstalledPackageId String deriving (Eq, Ord, Show)
+newtype SourcePackageId    = SourcePackageId String    deriving (Eq, Ord, Show)
+newtype PackageName        = PackageName String        deriving (Eq, Ord, Show)
+
+instance BinaryStringRep InstalledPackageId where
+  fromStringRep = InstalledPackageId . BS.unpack
+  toStringRep   (InstalledPackageId s) = BS.pack s
+
+instance BinaryStringRep SourcePackageId where
+  fromStringRep = SourcePackageId . BS.unpack
+  toStringRep   (SourcePackageId s) = BS.pack s
+
+instance BinaryStringRep PackageName where
+  fromStringRep = PackageName . BS.unpack
+  toStringRep   (PackageName s) = BS.pack s
+
+instance BinaryStringRep PackageKey where
+  fromStringRep = Module.stringToPackageKey . BS.unpack
+  toStringRep   = BS.pack . Module.packageKeyString
+
+instance BinaryStringRep Module.ModuleName where
+  fromStringRep = Module.mkModuleName . BS.unpack
+  toStringRep   = BS.pack . Module.moduleNameString  
+
+instance Outputable InstalledPackageId where
+  ppr (InstalledPackageId str) = text str
+
+instance Outputable SourcePackageId where
+  ppr (SourcePackageId str) = text str
+
+instance Outputable PackageName where
+  ppr (PackageName str) = text str
 
 defaultPackageConfig :: PackageConfig
 defaultPackageConfig = emptyInstalledPackageInfo
 
+installedPackageIdString :: PackageConfig -> String
+installedPackageIdString pkg = str
+  where
+    InstalledPackageId str = installedPackageId pkg
+
+sourcePackageIdString :: PackageConfig -> String
+sourcePackageIdString pkg = str
+  where
+    SourcePackageId str = sourcePackageId pkg
+
+packageNameString :: PackageConfig -> String
+packageNameString pkg = str
+  where
+    PackageName str = packageName pkg
+
+showInstalledPackageInfo :: PackageConfig -> String
+showInstalledPackageInfo = show
+
+instance Show ModuleName where
+  show = moduleNameString
+
+instance Show PackageKey where
+  show = packageKeyString
+
+
 -- -----------------------------------------------------------------------------
 -- PackageKey (package names, versions and dep hash)
 
@@ -54,35 +118,7 @@ defaultPackageConfig = emptyInstalledPackageInfo
 -- wired-in packages like @base@ & @rts@, we don't necessarily know what the
 -- version is, so these are handled specially; see #wired_in_packages#.
 
--- | Turn a Cabal 'PackageIdentifier' into a GHC 'PackageKey'
-mkPackageKey :: Cabal.PackageKey -> PackageKey
-mkPackageKey = stringToPackageKey . display
-
 -- | Get the GHC 'PackageKey' right out of a Cabalish 'PackageConfig'
 packageConfigId :: PackageConfig -> PackageKey
-packageConfigId = mkPackageKey . packageKey
-
--- | Turn a 'PackageConfig', which contains GHC 'Module.ModuleName's into a Cabal specific
--- 'InstalledPackageInfo' which contains Cabal 'Distribution.ModuleName.ModuleName's
-packageConfigToInstalledPackageInfo :: PackageConfig -> InstalledPackageInfo
-packageConfigToInstalledPackageInfo
-    (pkgconf@(InstalledPackageInfo { exposedModules = e,
-                                     reexportedModules = r,
-                                     hiddenModules = h })) =
-        pkgconf{ exposedModules = map convert e,
-                 reexportedModules = map (fmap convert) r,
-                 hiddenModules  = map convert h }
-    where convert :: Module.ModuleName -> Distribution.ModuleName.ModuleName
-          convert = (expectJust "packageConfigToInstalledPackageInfo") . simpleParse . moduleNameString
-
--- | Turn an 'InstalledPackageInfo', which contains Cabal 'Distribution.ModuleName.ModuleName's
--- into a GHC specific 'PackageConfig' which contains GHC 'Module.ModuleName's
-installedPackageInfoToPackageConfig :: InstalledPackageInfo_ String -> PackageConfig
-installedPackageInfoToPackageConfig
-    (pkgconf@(InstalledPackageInfo { exposedModules = e,
-                                     reexportedModules = r,
-                                     hiddenModules = h })) =
-        pkgconf{ exposedModules = map mkModuleName e,
-                 reexportedModules = map (fmap mkModuleName) r,
-                 hiddenModules  = map mkModuleName h }
+packageConfigId = packageKey
 
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index ae2669edcd..cf9ab09f67 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -49,6 +49,7 @@ where
 
 #include "HsVersions.h"
 
+import GHC.PackageDb
 import PackageConfig
 import DynFlags
 import Config           ( cProjectVersion )
@@ -61,11 +62,6 @@ import Outputable
 import Maybes
 
 import System.Environment ( getEnv )
-import GHC.PackageDb (readPackageDbForGhcPkg)
-import Distribution.InstalledPackageInfo
-import Distribution.InstalledPackageInfo.Binary ()
-import Distribution.Package hiding (depends, PackageKey, mkPackageKey)
-import Distribution.ModuleExport
 import FastString
 import ErrUtils         ( debugTraceMsg, putMsg, MsgDoc )
 import Exception
@@ -285,7 +281,7 @@ lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig
 lookupPackage' = lookupUFM
 
 -- | Search for packages with a given package ID (e.g. \"foo-0.1\")
-searchPackageId :: DynFlags -> PackageId -> [PackageConfig]
+searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
 searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
                                (listPackageConfigMap dflags)
 
@@ -386,10 +382,11 @@ readPackageConfig dflags conf_file = do
     if isdir
        then do let filename = conf_file </> "package.cache"
                debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
-               conf <- readPackageDbForGhcPkg filename
+               readPackageDbForGhc filename
+{-
                -- TODO readPackageDbForGhc ^^ instead
                return (map installedPackageInfoToPackageConfig conf)
-
+-}
        else do
             isfile <- doesFileExist conf_file
             if isfile
@@ -478,7 +475,7 @@ mungePackagePaths top_dir pkgroot pkg =
 -- then we are no longer able to match against package keys e.g. from when
 -- a user passes in a package flag.
 calcKey :: PackageConfig -> PackageKey
-calcKey p | pk <- display (pkgName (sourcePackageId p))
+calcKey p | pk <- packageNameString p
           , pk `elem` wired_in_pkgids
                       = stringToPackageKey pk
           | otherwise = packageConfigId p
@@ -558,22 +555,22 @@ selectPackages matches pkgs unusable
 -- version, or just the name if it is unambiguous.
 matchingStr :: String -> PackageConfig -> Bool
 matchingStr str p
-        =  str == display (sourcePackageId p)
-        || str == display (pkgName (sourcePackageId p))
+        =  str == sourcePackageIdString p
+        || str == packageNameString p
 
 matchingId :: String -> PackageConfig -> Bool
-matchingId str p =  InstalledPackageId str == installedPackageId p
+matchingId str p =  str == installedPackageIdString p
 
 matchingKey :: String -> PackageConfig -> Bool
-matchingKey str p = str == display (packageKey p)
+matchingKey str p = str == packageKeyString (packageConfigId p)
 
 matching :: PackageArg -> PackageConfig -> Bool
 matching (PackageArg str) = matchingStr str
 matching (PackageIdArg str) = matchingId str
 matching (PackageKeyArg str) = matchingKey str
 
-sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m]
-sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId)))
+sortByVersion :: [PackageConfig] -> [PackageConfig]
+sortByVersion = sortBy (flip (comparing packageVersion))
 
 comparing :: Ord a => (t -> a) -> t -> t -> Ordering
 comparing f a b = f a `compare` f b
@@ -600,7 +597,7 @@ packageFlagErr dflags flag reasons
                       -- ToDo: this admonition seems a bit dodgy
                       text "(use -v for more information)")
         ppr_reasons = vcat (map ppr_reason reasons)
-        ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason
+        ppr_reason (p, reason) = pprReason (ppr (installedPackageId p) <+> text "is") reason
 
 pprFlag :: PackageFlag -> SDoc
 pprFlag flag = case flag of
@@ -637,7 +634,7 @@ findWiredInPackages dflags pkgs = do
   --
   let
         matches :: PackageConfig -> String -> Bool
-        pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid
+        pc `matches` pid = packageNameString pc == pid
 
         -- find which package corresponds to each wired-in package
         -- delete any other packages with the same name
@@ -664,14 +661,14 @@ findWiredInPackages dflags pkgs = do
                                  <> text wired_pkg
                                  <> ptext (sLit " not found.")
                           return Nothing
-                pick :: InstalledPackageInfo_ ModuleName
+                pick :: PackageConfig
                      -> IO (Maybe InstalledPackageId)
                 pick pkg = do
                         debugTraceMsg dflags 2 $
                             ptext (sLit "wired-in package ")
                                  <> text wired_pkg
                                  <> ptext (sLit " mapped to ")
-                                 <> pprIPkg pkg
+                                 <> ppr (installedPackageId pkg)
                         return (Just (installedPackageId pkg))
 
 
@@ -693,12 +690,11 @@ findWiredInPackages dflags pkgs = do
         -}
 
         updateWiredInDependencies pkgs = map upd_pkg pkgs
-          where upd_pkg p
-                  | installedPackageId p `elem` wired_in_ids
-                  = let pid = (sourcePackageId p) { pkgVersion = Version [] [] }
-                    in p { packageKey = OldPackageKey pid }
+          where upd_pkg pkg
+                  | installedPackageId pkg `elem` wired_in_ids
+                  = pkg { packageKey = stringToPackageKey (packageNameString pkg) }
                   | otherwise
-                  = p
+                  = pkg
 
   return $ updateWiredInDependencies pkgs
 
@@ -719,9 +715,9 @@ pprReason pref reason = case reason of
   MissingDependencies deps ->
       pref <+>
       ptext (sLit "unusable due to missing or recursive dependencies:") $$
-        nest 2 (hsep (map (text.display) deps))
+        nest 2 (hsep (map ppr deps))
   ShadowedBy ipid ->
-      pref <+> ptext (sLit "shadowed by package ") <> text (display ipid)
+      pref <+> ptext (sLit "shadowed by package ") <> ppr ipid
 
 reportUnusable :: DynFlags -> UnusablePackages -> IO ()
 reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
@@ -730,7 +726,7 @@ reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
        debugTraceMsg dflags 2 $
          pprReason
            (ptext (sLit "package") <+>
-            text (display ipid) <+> text "is") reason
+            ppr ipid <+> text "is") reason
 
 -- ----------------------------------------------------------------------------
 --
@@ -787,7 +783,7 @@ shadowPackages pkgs preferred
       | otherwise
       = (shadowed, pkgmap')
       where
-        pkgid = mkFastString (display (sourcePackageId pkg))
+        pkgid = mkFastString (sourcePackageIdString pkg)
         pkgmap' = addToUFM pkgmap pkgid pkg
 
 -- -----------------------------------------------------------------------------
@@ -920,7 +916,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do
   -- or is empty if we have -hide-all-packages
   --
   let preferLater pkg pkg' =
-        case comparing (pkgVersion.sourcePackageId) pkg pkg' of
+        case comparing packageVersion pkg pkg' of
             GT -> pkg
             _  -> pkg'
       calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg
@@ -1048,8 +1044,11 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
     es e =
      [(m, sing pk  m  pkg  (fromExposedModules e)) | m <- exposed_mods] ++
      [(m, sing pk' m' pkg' (fromReexportedModules e pkg))
-     | ModuleExport{ exportName = m
-                   , exportCachedTrueOrig = Just (ipid', m')} <- reexported_mods
+     | ModuleExport {
+         exportModuleName         = m,
+         exportOriginalPackageId  = ipid',
+         exportOriginalModuleName = m'
+       } <- reexported_mods
      , let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
            pkg' = pkg_lookup pk' ]
 
@@ -1105,9 +1104,6 @@ mkModuleToPkgConfAll =
           merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m
           setOrigins m os = fmap (const os) m
 
-pprIPkg :: PackageConfig -> SDoc
-pprIPkg p = text (display (installedPackageId p))
-
 -- -----------------------------------------------------------------------------
 -- Extracting information from the packages in scope
 
@@ -1387,7 +1383,7 @@ packageKeyPackageIdString :: DynFlags -> PackageKey -> String
 packageKeyPackageIdString dflags pkg_key
     | pkg_key == mainPackageKey = "main"
     | otherwise = maybe "(unknown)"
-                      (display . sourcePackageId)
+                      sourcePackageIdString
                       (lookupPackage dflags pkg_key)
 
 -- | Will the 'Name' come from a dynamically linked library?
@@ -1430,11 +1426,10 @@ isDllName dflags _this_pkg this_mod name
 dumpPackages :: DynFlags -> IO ()
 dumpPackages = dumpPackages' showInstalledPackageInfo
 
-dumpPackages' :: (InstalledPackageInfo -> String) -> DynFlags -> IO ()
+dumpPackages' :: (PackageConfig -> String) -> DynFlags -> IO ()
 dumpPackages' showIPI dflags
   = do putMsg dflags $
-             vcat (map (text . showIPI
-                             . packageConfigToInstalledPackageInfo)
+             vcat (map (text . showIPI)
                        (listPackageConfigMap dflags))
 
 -- | Show simplified package info on console, if verbosity == 4.
@@ -1458,7 +1453,6 @@ pprModuleMap dflags =
         | otherwise = ppr m' <+> parens (ppr o)
 
 fsPackageName :: PackageConfig -> FastString
-fsPackageName pkg = case packageName (sourcePackageId pkg) of
-    PackageName n -> mkFastString n
+fsPackageName = mkFastString . packageNameString
 
 \end{code}