Commit 0d601657 authored by Edward Z. Yang's avatar Edward Z. Yang Committed by Ben Gamari

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: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1811
parent e5a0a890
......@@ -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)
{-
************************************************************************
* *
......
{-# 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
-- -----------------------------------------------------------------------------
......
......@@ -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')
......
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-----------------------------------------------------------------------------
-- |
......@@ -36,9 +38,9 @@
--
module GHC.PackageDb (
InstalledPackageInfo(..),
ExposedModule(..),
OriginalModule(..),
DbModule(..),
BinaryStringRep(..),
DbModuleRep(..),
emptyInstalledPackageInfo,
readPackageDbForGhc,
readPackageDbForGhcPkg,
......@@ -65,7 +67,7 @@ import System.Directory
-- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits
-- that GHC is interested in.
--
data InstalledPackageInfo srcpkgid srcpkgname unitid modulename
data InstalledPackageInfo srcpkgid srcpkgname unitid modulename mod
= InstalledPackageInfo {
unitId :: unitid,
sourcePackageId :: srcpkgid,
......@@ -86,7 +88,7 @@ data InstalledPackageInfo srcpkgid srcpkgname unitid modulename
includeDirs :: [FilePath],
haddockInterfaces :: [FilePath],
haddockHTMLs :: [FilePath],
exposedModules :: [ExposedModule unitid modulename],
exposedModules :: [(modulename, Maybe mod)],
hiddenModules :: [modulename],
exposed :: Bool,
trusted :: Bool
......@@ -95,38 +97,25 @@ data InstalledPackageInfo srcpkgid srcpkgname unitid modulename
-- | A convenience constraint synonym for common constraints over parameters
-- to 'InstalledPackageInfo'.
type RepInstalledPackageInfo srcpkgid srcpkgname unitid modulename =
type RepInstalledPackageInfo srcpkgid srcpkgname unitid modulename mod =
(BinaryStringRep srcpkgid, BinaryStringRep srcpkgname,
BinaryStringRep unitid, BinaryStringRep modulename)
BinaryStringRep unitid, BinaryStringRep modulename,
DbModuleRep unitid modulename mod)
-- | An original module is a fully-qualified module name (installed package ID
-- plus module name) representing where a module was *originally* defined
-- (i.e., the 'exposedReexport' field of the original ExposedModule entry should
-- be 'Nothing'). Invariant: an OriginalModule never points to a reexport.
data OriginalModule unitid modulename
= OriginalModule {
originalPackageId :: unitid,
originalModuleName :: modulename
}
deriving (Eq, Show)
-- | A type-class for the types which can be converted into 'DbModule'.
-- NB: The functional dependency helps out type inference in cases
-- where types would be ambiguous.
class DbModuleRep unitid modulename mod
| mod -> unitid, unitid -> mod, mod -> modulename where
fromDbModule :: DbModule unitid modulename -> mod
toDbModule :: mod -> DbModule unitid modulename
-- | Represents a module name which is exported by a package, stored in the
-- 'exposedModules' field. A module export may be a reexport (in which case
-- 'exposedReexport' is filled in with the original source of the module).
-- Thus:
--
-- * @ExposedModule n Nothing@ represents an exposed module @n@ which
-- was defined in this package.
--
-- * @ExposedModule n (Just o)@ represents a reexported module @n@
-- which was originally defined in @o@.
--
-- We use a 'Maybe' data types instead of an ADT with two branches because this
-- representation allows us to treat reexports uniformly.
data ExposedModule unitid modulename
= ExposedModule {
exposedName :: modulename,
exposedReexport :: Maybe (OriginalModule unitid modulename)
-- | @ghc-boot@'s copy of 'Module', i.e. what is serialized to the database.
-- Use 'DbModuleRep' to convert it into an actual 'Module'.
data DbModule unitid modulename
= DbModule {
dbModuleUnitId :: unitid,
dbModuleName :: modulename
}
deriving (Eq, Show)
......@@ -134,8 +123,8 @@ class BinaryStringRep a where
fromStringRep :: BS.ByteString -> a
toStringRep :: a -> BS.ByteString
emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d
=> InstalledPackageInfo a b c d
emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e
=> InstalledPackageInfo a b c d e
emptyInstalledPackageInfo =
InstalledPackageInfo {
unitId = fromStringRep BS.empty,
......@@ -165,8 +154,8 @@ emptyInstalledPackageInfo =
-- | Read the part of the package DB that GHC is interested in.
--
readPackageDbForGhc :: RepInstalledPackageInfo a b c d =>
FilePath -> IO [InstalledPackageInfo a b c d]
readPackageDbForGhc :: RepInstalledPackageInfo a b c d e =>
FilePath -> IO [InstalledPackageInfo a b c d e]
readPackageDbForGhc file =
decodeFromFile file getDbForGhc
where
......@@ -198,8 +187,8 @@ readPackageDbForGhcPkg file =
-- | Write the whole of the package DB, both parts.
--
writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d) =>
FilePath -> [InstalledPackageInfo a b c d] -> pkgs -> IO ()
writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d e) =>
FilePath -> [InstalledPackageInfo a b c d e] -> pkgs -> IO ()
writePackageDb file ghcPkgs ghcPkgPart =
writeFileAtomic file (runPut putDbForGhcPkg)
where
......@@ -285,8 +274,8 @@ writeFileAtomic targetPath content = do
hClose handle
renameFile tmpPath targetPath)
instance (RepInstalledPackageInfo a b c d) =>
Binary (InstalledPackageInfo a b c d) where
instance (RepInstalledPackageInfo a b c d e) =>
Binary (InstalledPackageInfo a b c d e) where
put (InstalledPackageInfo
unitId sourcePackageId
packageName packageVersion
......@@ -317,7 +306,8 @@ instance (RepInstalledPackageInfo a b c d) =>
put includeDirs
put haddockInterfaces
put haddockHTMLs
put exposedModules
put (map (\(mod_name, mod) -> (toStringRep mod_name, fmap toDbModule mod))
exposedModules)
put (map toStringRep hiddenModules)
put exposed
put trusted
......@@ -326,7 +316,7 @@ instance (RepInstalledPackageInfo a b c d) =>
sourcePackageId <- get
packageName <- get
packageVersion <- get
unitId <- get
unitId <- get
abiHash <- get
depends <- get
importDirs <- get
......@@ -358,28 +348,19 @@ instance (RepInstalledPackageInfo a b c d) =>
ldOptions ccOptions
includes includeDirs
haddockInterfaces haddockHTMLs
exposedModules
(map (\(mod_name, mod) ->
(fromStringRep mod_name, fmap fromDbModule mod))
exposedModules)
(map fromStringRep hiddenModules)
exposed trusted)
instance (BinaryStringRep a, BinaryStringRep b) =>
Binary (OriginalModule a b) where
put (OriginalModule originalPackageId originalModuleName) = do
put (toStringRep originalPackageId)
put (toStringRep originalModuleName)
get = do
originalPackageId <- get
originalModuleName <- get
return (OriginalModule (fromStringRep originalPackageId)
(fromStringRep originalModuleName))
instance (BinaryStringRep a, BinaryStringRep b) =>
Binary (ExposedModule a b) where
put (ExposedModule exposedName exposedReexport) = do
put (toStringRep exposedName)
put exposedReexport
Binary (DbModule a b) where
put (DbModule dbModuleUnitId dbModuleName) = do
put (toStringRep dbModuleUnitId)
put (toStringRep dbModuleName)
get = do
exposedName <- get
exposedReexport <- get
return (ExposedModule (fromStringRep exposedName)
exposedReexport)
dbModuleUnitId <- get
dbModuleName <- get
return (DbModule (fromStringRep dbModuleUnitId)
(fromStringRep dbModuleName))
{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
--
......@@ -12,6 +15,7 @@ module Main (main) where
import Version ( version, targetOS, targetARCH )
import qualified GHC.PackageDb as GhcPkg
import GHC.PackageDb (BinaryStringRep(..))
import qualified Distribution.Simple.PackageIndex as PackageIndex
import qualified Data.Graph as Graph
import qualified Distribution.ModuleName as ModuleName
......@@ -1071,19 +1075,20 @@ updateDBCache verbosity db = do
hPutChar handle c
type PackageCacheFormat = GhcPkg.InstalledPackageInfo
String -- src package id
String -- package name
String -- unit id
ModuleName -- module name
PackageIdentifier
PackageName
UnitId
ModuleName
OriginalModule
convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat
convertPackageInfoToCacheFormat pkg =
GhcPkg.InstalledPackageInfo {
GhcPkg.unitId = display (installedUnitId pkg),
GhcPkg.sourcePackageId = display (sourcePackageId pkg),
GhcPkg.packageName = display (packageName pkg),
GhcPkg.unitId = installedUnitId pkg,
GhcPkg.sourcePackageId = sourcePackageId pkg,
GhcPkg.packageName = packageName pkg,
GhcPkg.packageVersion = packageVersion pkg,
GhcPkg.depends = map display (depends pkg),
GhcPkg.depends = depends pkg,
GhcPkg.abiHash = let AbiHash abi = abiHash pkg
in abi,
GhcPkg.importDirs = importDirs pkg,
......@@ -1104,19 +1109,32 @@ convertPackageInfoToCacheFormat pkg =
GhcPkg.exposed = exposed pkg,
GhcPkg.trusted = trusted pkg
}
where convertExposed (ExposedModule n reexport) =
GhcPkg.ExposedModule n (fmap convertOriginal reexport)
convertOriginal (OriginalModule ipid m) =
GhcPkg.OriginalModule (display ipid) m
where convertExposed (ExposedModule n reexport) = (n, reexport)
instance GhcPkg.BinaryStringRep PackageName where
fromStringRep = PackageName . fromStringRep
toStringRep = toStringRep . display
instance GhcPkg.BinaryStringRep PackageIdentifier where
fromStringRep = fromMaybe (error "BinaryStringRep PackageIdentifier")
. simpleParse . fromStringRep
toStringRep = toStringRep . display
instance GhcPkg.BinaryStringRep UnitId where
fromStringRep = mkUnitId . fromStringRep
toStringRep (SimpleUnitId (ComponentId cid_str)) = toStringRep cid_str
instance GhcPkg.BinaryStringRep ModuleName where
fromStringRep = ModuleName.fromString . fromUTF8 . BS.unpack
toStringRep = BS.pack . toUTF8 . display
fromStringRep = ModuleName.fromString . fromStringRep
toStringRep = toStringRep . display
instance GhcPkg.BinaryStringRep String where
fromStringRep = fromUTF8 . BS.unpack
toStringRep = BS.pack . toUTF8
instance GhcPkg.DbModuleRep UnitId ModuleName OriginalModule where
fromDbModule (GhcPkg.DbModule uid mod_name) = OriginalModule uid mod_name
toDbModule (OriginalModule uid mod_name) = GhcPkg.DbModule uid mod_name
-- -----------------------------------------------------------------------------
-- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment