Use ghc-local types for packages, rather than Cabal types
authorDuncan Coutts <duncan@well-typed.com>
Fri, 22 Aug 2014 13:38:10 +0000 (14:38 +0100)
committerEdward Z. Yang <ezyang@cs.stanford.edu>
Fri, 29 Aug 2014 11:39:04 +0000 (12:39 +0100)
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.

compiler/ghci/Linker.lhs
compiler/main/Finder.lhs
compiler/main/PackageConfig.hs
compiler/main/Packages.lhs
libraries/bin-package-db/GHC/PackageDb.hs
utils/ghc-pkg/Main.hs

index 86d7b26..f581f9f 100644 (file)
@@ -65,8 +65,6 @@ import System.FilePath
 import System.IO
 import System.Directory hiding (findFile)
 
 import System.IO
 import System.Directory hiding (findFile)
 
-import Distribution.Package hiding (depends, mkPackageKey, PackageKey)
-
 import Exception
 \end{code}
 
 import Exception
 \end{code}
 
@@ -1119,7 +1117,7 @@ linkPackage dflags pkg
             objs       = [ obj  | Object obj     <- classifieds ]
             archs      = [ arch | Archive arch   <- classifieds ]
 
             objs       = [ obj  | Object obj     <- classifieds ]
             archs      = [ arch | Archive arch   <- classifieds ]
 
-        maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ")
+        maybePutStr dflags ("Loading package " ++ sourcePackageIdString pkg ++ " ... ")
 
         -- See comments with partOfGHCi
         when (packageName pkg `notElem` partOfGHCi) $ do
 
         -- See comments with partOfGHCi
         when (packageName pkg `notElem` partOfGHCi) $ do
@@ -1135,7 +1133,7 @@ linkPackage dflags pkg
         maybePutStr dflags "linking ... "
         ok <- resolveObjs
         if succeeded ok then maybePutStrLn dflags "done."
         maybePutStr dflags "linking ... "
         ok <- resolveObjs
         if succeeded ok then maybePutStrLn dflags "done."
-              else throwGhcExceptionIO (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'"))
+              else throwGhcExceptionIO (InstallationError ("unable to load package `" ++ sourcePackageIdString pkg ++ "'"))
 
 -- we have already searched the filesystem; the strings passed to load_dyn
 -- can be passed directly to loadDLL.  They are either fully-qualified
 
 -- we have already searched the filesystem; the strings passed to load_dyn
 -- can be passed directly to loadDLL.  They are either fully-qualified
@@ -1149,7 +1147,7 @@ load_dyn dll = do r <- loadDLL dll
                     Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "
                                                               ++ dll ++ " (" ++ err ++ ")" ))
 
                     Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "
                                                               ++ dll ++ " (" ++ err ++ ")" ))
 
-loadFrameworks :: Platform -> InstalledPackageInfo_ ModuleName -> IO ()
+loadFrameworks :: Platform -> PackageConfig -> IO ()
 loadFrameworks platform pkg
     = if platformUsesFrameworks platform
       then mapM_ load frameworks
 loadFrameworks platform pkg
     = if platformUsesFrameworks platform
       then mapM_ load frameworks
index f9c7e2e..8b9a5e9 100644 (file)
@@ -42,7 +42,6 @@ import UniqFM
 import Maybes           ( expectJust )
 import Exception        ( evaluate )
 
 import Maybes           ( expectJust )
 import Exception        ( evaluate )
 
-import Distribution.Text
 import Data.IORef       ( IORef, writeIORef, readIORef, atomicModifyIORef )
 import System.Directory
 import System.FilePath
 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)
 
         | 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
      | 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.")
               ptext (sLit "to the build-depends in your .cabal file.")
-          Nothing -> empty
      | otherwise = empty
 
     mod_hidden pkg =
      | otherwise = empty
 
     mod_hidden pkg =
index 864980b..09ff065 100644 (file)
@@ -10,39 +10,103 @@ module PackageConfig (
         -- $package_naming
 
         -- * PackageKey
         -- $package_naming
 
         -- * PackageKey
-        mkPackageKey, packageConfigId,
+        packageConfigId,
 
         -- * The PackageConfig type: information about a package
         PackageConfig,
 
         -- * The PackageConfig type: information about a package
         PackageConfig,
-        InstalledPackageInfo_(..), display,
+        InstalledPackageInfo(..),
+        InstalledPackageId(..),
+        SourcePackageId(..),
+        PackageName(..),
         Version(..),
         Version(..),
-        PackageIdentifier(..),
         defaultPackageConfig,
         defaultPackageConfig,
-        packageConfigToInstalledPackageInfo,
-        installedPackageInfoToPackageConfig
+        installedPackageIdString,
+        sourcePackageIdString,
+        packageNameString,
+        showInstalledPackageInfo,
     ) where
 
 #include "HsVersions.h"
 
     ) 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
 
 -- -----------------------------------------------------------------------------
 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
 
 
 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)
 
 -- -----------------------------------------------------------------------------
 -- 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#.
 
 -- 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
 -- | 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
 
 
index ae2669e..cf9ab09 100644 (file)
@@ -49,6 +49,7 @@ where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 
+import GHC.PackageDb
 import PackageConfig
 import DynFlags
 import Config           ( cProjectVersion )
 import PackageConfig
 import DynFlags
 import Config           ( cProjectVersion )
@@ -61,11 +62,6 @@ import Outputable
 import Maybes
 
 import System.Environment ( getEnv )
 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
 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\")
 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)
 
 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)
     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)
                -- TODO readPackageDbForGhc ^^ instead
                return (map installedPackageInfoToPackageConfig conf)
-
+-}
        else do
             isfile <- doesFileExist conf_file
             if isfile
        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
 -- 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
           , 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
 -- 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 :: String -> PackageConfig -> Bool
-matchingId str p =  InstalledPackageId str == installedPackageId p
+matchingId str p =  str == installedPackageIdString p
 
 matchingKey :: String -> PackageConfig -> Bool
 
 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
 
 
 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
 
 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)
                       -- 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
 
 pprFlag :: PackageFlag -> SDoc
 pprFlag flag = case flag of
@@ -637,7 +634,7 @@ findWiredInPackages dflags pkgs = do
   --
   let
         matches :: PackageConfig -> String -> Bool
   --
   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
 
         -- 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
                                  <> 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 ")
                      -> 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))
 
 
                         return (Just (installedPackageId pkg))
 
 
@@ -693,12 +690,11 @@ findWiredInPackages dflags pkgs = do
         -}
 
         updateWiredInDependencies pkgs = map upd_pkg pkgs
         -}
 
         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
                   | otherwise
-                  = p
+                  = pkg
 
   return $ updateWiredInDependencies pkgs
 
 
   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:") $$
   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 ->
   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)
 
 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") <+>
        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
       | otherwise
       = (shadowed, pkgmap')
       where
-        pkgid = mkFastString (display (sourcePackageId pkg))
+        pkgid = mkFastString (sourcePackageIdString pkg)
         pkgmap' = addToUFM pkgmap pkgid 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' =
   -- 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
             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))
     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' ]
 
      , 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
 
           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
 
 -- -----------------------------------------------------------------------------
 -- 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)"
 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?
                       (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 :: DynFlags -> IO ()
 dumpPackages = dumpPackages' showInstalledPackageInfo
 
-dumpPackages' :: (InstalledPackageInfo -> String) -> DynFlags -> IO ()
+dumpPackages' :: (PackageConfig -> String) -> DynFlags -> IO ()
 dumpPackages' showIPI dflags
   = do putMsg dflags $
 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.
                        (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
         | 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}
 
 \end{code}
index 0ed5085..08dabd2 100644 (file)
@@ -1,8 +1,6 @@
-{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-#if __GLASGOW_HASKELL__ >= 701
-{-# LANGUAGE Trustworthy #-}
-#endif
+{-# LANGUAGE CPP #-}
+-- This module deliberately defines orphan instances for now (Binary Version).
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.PackageDb
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.PackageDb
 -- this library avoids depending on Cabal.
 -- 
 module GHC.PackageDb (
 -- this library avoids depending on Cabal.
 -- 
 module GHC.PackageDb (
-       GhcPackageInfo(..),
+       InstalledPackageInfo(..),
+       ModuleExport(..),
+       BinaryStringRep(..),
+       emptyInstalledPackageInfo,
        readPackageDbForGhc,
        readPackageDbForGhcPkg,
        writePackageDb
   ) where
 
        readPackageDbForGhc,
        readPackageDbForGhcPkg,
        writePackageDb
   ) where
 
+import Data.Version (Version(..))
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS.Char8
 import qualified Data.ByteString.Lazy as BS.Lazy
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS.Char8
 import qualified Data.ByteString.Lazy as BS.Lazy
@@ -63,22 +65,89 @@ import System.Directory
 -- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits
 -- that GHC is interested in.
 --
 -- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits
 -- that GHC is interested in.
 --
-data GhcPackageInfo = GhcPackageInfo {
-       --TODO
+data InstalledPackageInfo instpkgid srcpkgid srcpkgname pkgkey modulename
+   = InstalledPackageInfo {
+       installedPackageId :: instpkgid,
+       sourcePackageId    :: srcpkgid,
+       packageName        :: srcpkgname,
+       packageVersion     :: Version,
+       packageKey         :: pkgkey,
+       depends            :: [instpkgid],
+       importDirs         :: [FilePath],
+       hsLibraries        :: [String],
+       extraLibraries     :: [String],
+       extraGHCiLibraries :: [String],
+       libraryDirs        :: [FilePath],
+       frameworks         :: [String],
+       frameworkDirs      :: [FilePath],
+       ldOptions          :: [String],
+       ccOptions          :: [String],
+       includes           :: [String],
+       includeDirs        :: [FilePath],
+       haddockInterfaces  :: [FilePath],
+       haddockHTMLs       :: [FilePath],
+       exposedModules     :: [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
+
+data ModuleExport instpkgid modulename
+   = ModuleExport {
+       exportModuleName         :: modulename,
+       exportOriginalPackageId  :: instpkgid,
+       exportOriginalModuleName :: modulename
      }
   deriving (Eq, Show)
 
      }
   deriving (Eq, Show)
 
+emptyInstalledPackageInfo :: (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, BinaryStringRep d)
+                          => InstalledPackageInfo a b c d e
+emptyInstalledPackageInfo =
+  InstalledPackageInfo {
+       installedPackageId = fromStringRep BS.empty,
+       sourcePackageId    = fromStringRep BS.empty,
+       packageName        = fromStringRep BS.empty,
+       packageVersion     = Version [] [],
+       packageKey         = fromStringRep BS.empty,
+       depends            = [],
+       importDirs         = [],
+       hsLibraries        = [],
+       extraLibraries     = [],
+       extraGHCiLibraries = [],
+       libraryDirs        = [],
+       frameworks         = [],
+       frameworkDirs      = [],
+       ldOptions          = [],
+       ccOptions          = [],
+       includes           = [],
+       includeDirs        = [],
+       haddockInterfaces  = [],
+       haddockHTMLs       = [],
+       exposedModules     = [],
+       hiddenModules      = [],
+       reexportedModules  = [],
+       exposed            = False,
+       trusted            = False
+  }
 
 -- | Read the part of the package DB that GHC is interested in.
 --
 
 -- | Read the part of the package DB that GHC is interested in.
 --
-readPackageDbForGhc :: FilePath -> IO [GhcPackageInfo]
+readPackageDbForGhc :: (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
+                        BinaryStringRep d, BinaryStringRep e) =>
+                       FilePath -> IO [InstalledPackageInfo a b c d e]
 readPackageDbForGhc file =
     decodeFromFile file getDbForGhc
   where
     getDbForGhc = do
       _version    <- getHeader
       _ghcPartLen <- get :: Get Word32
 readPackageDbForGhc file =
     decodeFromFile file getDbForGhc
   where
     getDbForGhc = do
       _version    <- getHeader
       _ghcPartLen <- get :: Get Word32
-      ghcPart     <- get :: Get [GhcPackageInfo]
+      ghcPart     <- get
       -- the next part is for ghc-pkg, but we stop here.
       return ghcPart
 
       -- the next part is for ghc-pkg, but we stop here.
       return ghcPart
 
@@ -99,7 +168,9 @@ readPackageDbForGhcPkg file =
 
 -- | Write the whole of the package DB, both parts.
 --
 
 -- | Write the whole of the package DB, both parts.
 --
-writePackageDb :: Binary pkgs => FilePath -> [GhcPackageInfo] -> pkgs -> IO ()
+writePackageDb :: (Binary pkgs, BinaryStringRep a, BinaryStringRep b,
+                   BinaryStringRep c, BinaryStringRep d, BinaryStringRep e) =>
+                  FilePath -> [InstalledPackageInfo a b c d e] -> pkgs -> IO ()
 writePackageDb file ghcPkgs ghcPkgPart =
     writeFileAtomic file (runPut putDbForGhcPkg)
   where
 writePackageDb file ghcPkgs ghcPkgPart =
     writeFileAtomic file (runPut putDbForGhcPkg)
   where
@@ -197,10 +268,104 @@ writeFileAtomic targetPath content = do
         )
 
 
         )
 
 
-instance Binary GhcPackageInfo where
-  put (GhcPackageInfo {-TODO-}) = do
-    return ()
+instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
+          BinaryStringRep d, BinaryStringRep e) =>
+         Binary (InstalledPackageInfo a b c d e) where
+  put (InstalledPackageInfo
+         installedPackageId sourcePackageId packageName packageVersion packageKey
+         depends importDirs
+         hsLibraries extraLibraries extraGHCiLibraries libraryDirs
+         frameworks frameworkDirs
+         ldOptions ccOptions
+         includes includeDirs
+         haddockInterfaces haddockHTMLs
+         exposedModules hiddenModules reexportedModules
+         exposed trusted) = do
+    put (toStringRep installedPackageId)
+    put (toStringRep sourcePackageId)
+    put (toStringRep packageName)
+    put packageVersion
+    put (toStringRep packageKey)
+    put (map toStringRep depends)
+    put importDirs
+    put hsLibraries
+    put extraLibraries
+    put extraGHCiLibraries
+    put libraryDirs
+    put frameworks
+    put frameworkDirs
+    put ldOptions
+    put ccOptions
+    put includes
+    put includeDirs
+    put haddockInterfaces
+    put haddockHTMLs
+    put (map toStringRep exposedModules)
+    put (map toStringRep hiddenModules)
+    put reexportedModules
+    put exposed
+    put trusted
+
+  get = do
+    installedPackageId <- get
+    sourcePackageId    <- get
+    packageName        <- get
+    packageVersion     <- get
+    packageKey         <- get
+    depends            <- get
+    importDirs         <- get
+    hsLibraries        <- get
+    extraLibraries     <- get
+    extraGHCiLibraries <- get
+    libraryDirs        <- get
+    frameworks         <- get
+    frameworkDirs      <- get
+    ldOptions          <- get
+    ccOptions          <- get
+    includes           <- get
+    includeDirs        <- get
+    haddockInterfaces  <- get
+    haddockHTMLs       <- get
+    exposedModules     <- get
+    hiddenModules      <- get
+    reexportedModules  <- get
+    exposed            <- get
+    trusted            <- get
+    return (InstalledPackageInfo
+              (fromStringRep installedPackageId)
+              (fromStringRep sourcePackageId)
+              (fromStringRep packageName) packageVersion
+              (fromStringRep packageKey)
+              (map fromStringRep depends)
+              importDirs
+              hsLibraries extraLibraries extraGHCiLibraries libraryDirs
+              frameworks frameworkDirs
+              ldOptions ccOptions
+              includes includeDirs
+              haddockInterfaces haddockHTMLs
+              (map fromStringRep exposedModules)
+              (map fromStringRep hiddenModules)
+              reexportedModules
+              exposed trusted)
 
 
+instance Binary Version where
+  put (Version a b) = do
+    put a
+    put b
   get = do
   get = do
-    return (GhcPackageInfo {-TODO-})
+    a <- get
+    b <- get
+    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)
+  get = do
+    a <- get
+    b <- get
+    c <- get
+    return (ModuleExport (fromStringRep a)
+                         (fromStringRep b)
+                         (fromStringRep c))
index 06205e3..05d4488 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}
 -----------------------------------------------------------------------------
 --
 -- (c) The University of Glasgow 2004-2009.
 -----------------------------------------------------------------------------
 --
 -- (c) The University of Glasgow 2004-2009.
@@ -13,7 +13,9 @@ import Version ( version, targetOS, targetARCH )
 import qualified GHC.PackageDb as GhcPkg
 import Distribution.InstalledPackageInfo.Binary()
 import qualified Distribution.Simple.PackageIndex as PackageIndex
 import qualified GHC.PackageDb as GhcPkg
 import Distribution.InstalledPackageInfo.Binary()
 import qualified Distribution.Simple.PackageIndex as PackageIndex
-import Distribution.ModuleName hiding (main)
+import qualified Distribution.Package as Cabal
+import qualified Distribution.ModuleName as ModuleName
+import Distribution.ModuleName (ModuleName)
 import Distribution.InstalledPackageInfo as Cabal
 import Distribution.Compat.ReadP
 import Distribution.ParseUtils
 import Distribution.InstalledPackageInfo as Cabal
 import Distribution.Compat.ReadP
 import Distribution.ParseUtils
@@ -51,6 +53,7 @@ import GHC.IO.Exception (IOErrorType(InappropriateType))
 import Data.List
 import Control.Concurrent
 
 import Data.List
 import Control.Concurrent
 
+import qualified Data.ByteString.Char8 as BS
 import qualified Data.Binary as Bin
 import qualified Data.Binary.Get as Bin
 
 import qualified Data.Binary as Bin
 import qualified Data.Binary.Get as Bin
 
@@ -1008,8 +1011,8 @@ updateDBCache verbosity db = do
       pkgsCabalFormat :: [InstalledPackageInfo]
       pkgsCabalFormat = packages db
 
       pkgsCabalFormat :: [InstalledPackageInfo]
       pkgsCabalFormat = packages db
 
-      pkgsGhcCacheFormat :: [GhcPkg.GhcPackageInfo]
-      pkgsGhcCacheFormat = [] -- TODO: for the moment
+      pkgsGhcCacheFormat :: [PackageCacheFormat]
+      pkgsGhcCacheFormat = map convertPackageInfoToCacheFormat pkgsCabalFormat
 
   when (verbosity > Normal) $
       infoLn ("writing cache " ++ filename)
 
   when (verbosity > Normal) $
       infoLn ("writing cache " ++ filename)
@@ -1023,6 +1026,51 @@ updateDBCache verbosity db = do
   setFileTimes (location db) (accessTime status) (modificationTime status)
 #endif
 
   setFileTimes (location db) (accessTime status) (modificationTime status)
 #endif
 
+type PackageCacheFormat = GhcPkg.InstalledPackageInfo String String String String ModuleName
+
+convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat
+convertPackageInfoToCacheFormat pkg =
+    GhcPkg.InstalledPackageInfo {
+       GhcPkg.installedPackageId = display (installedPackageId pkg),
+       GhcPkg.sourcePackageId    = display (sourcePackageId pkg),
+       GhcPkg.packageName        = display (packageName pkg),
+       GhcPkg.packageVersion     = packageVersion pkg,
+       GhcPkg.packageKey         = display (packageKey pkg),
+       GhcPkg.depends            = map display (depends pkg),
+       GhcPkg.importDirs         = importDirs pkg,
+       GhcPkg.hsLibraries        = hsLibraries pkg,
+       GhcPkg.extraLibraries     = extraLibraries pkg,
+       GhcPkg.extraGHCiLibraries = extraGHCiLibraries pkg,
+       GhcPkg.libraryDirs        = libraryDirs pkg,
+       GhcPkg.frameworks         = frameworks pkg,
+       GhcPkg.frameworkDirs      = frameworkDirs pkg,
+       GhcPkg.ldOptions          = ldOptions pkg,
+       GhcPkg.ccOptions          = ccOptions pkg,
+       GhcPkg.includes           = includes pkg,
+       GhcPkg.includeDirs        = includeDirs pkg,
+       GhcPkg.haddockInterfaces  = haddockInterfaces pkg,
+       GhcPkg.haddockHTMLs       = haddockHTMLs pkg,
+       GhcPkg.exposedModules     = exposedModules pkg,
+       GhcPkg.hiddenModules      = hiddenModules pkg,
+       GhcPkg.reexportedModules  = [ GhcPkg.ModuleExport m ipid' m'
+                                   | ModuleExport {
+                                       exportName = m,
+                                       exportCachedTrueOrig = Just (InstalledPackageId ipid', m')
+                                     } <- reexportedModules pkg
+                                   ],
+       GhcPkg.exposed            = exposed pkg,
+       GhcPkg.trusted            = trusted pkg
+    }
+
+instance GhcPkg.BinaryStringRep ModuleName where
+  fromStringRep = ModuleName.fromString . BS.unpack
+  toStringRep   = BS.pack . display
+
+instance GhcPkg.BinaryStringRep String where
+  fromStringRep = BS.unpack
+  toStringRep   = BS.pack
+
+
 -- -----------------------------------------------------------------------------
 -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
 
 -- -----------------------------------------------------------------------------
 -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
 
@@ -1631,8 +1679,8 @@ checkModules pkg = do
   where
     findModule modl =
       -- there's no interface file for GHC.Prim
   where
     findModule modl =
       -- there's no interface file for GHC.Prim
-      unless (modl == fromString "GHC.Prim") $ do
-      let files = [ toFilePath modl <.> extension
+      unless (modl == ModuleName.fromString "GHC.Prim") $ do
+      let files = [ ModuleName.toFilePath modl <.> extension
                   | extension <- ["hi", "p_hi", "dyn_hi" ] ]
       m <- liftIO $ doesFileExistOnPath files (importDirs pkg)
       when (isNothing m) $
                   | extension <- ["hi", "p_hi", "dyn_hi" ] ]
       m <- liftIO $ doesFileExistOnPath files (importDirs pkg)
       when (isNothing m) $