{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
module Module
(
import Binary
import Util
import {-# SOURCE #-} Packages
-import GHC.PackageDb (BinaryStringRep(..))
+import GHC.PackageDb (BinaryStringRep(..), DbModuleRep(..), DbModule(..))
import Data.Data
import Data.Map (Map)
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
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
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
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)),
]
where
field name body = text name <> colon <+> nest 4 body
- isExposedModule (ExposedModule _ Nothing) = True
- isExposedModule _ = False
-- -----------------------------------------------------------------------------
| 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
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 #-}
-----------------------------------------------------------------------------
-- |
--
module GHC.PackageDb (
InstalledPackageInfo(..),
- ExposedModule(..),
- OriginalModule(..),
+ DbModule(..),
BinaryStringRep(..),
+ DbModuleRep(..),
emptyInstalledPackageInfo,
readPackageDbForGhc,
readPackageDbForGhcPkg,
-- | 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,
includeDirs :: [FilePath],
haddockInterfaces :: [FilePath],
haddockHTMLs :: [FilePath],
- exposedModules :: [ExposedModule unitid modulename],
+ exposedModules :: [(modulename, Maybe mod)],
hiddenModules :: [modulename],
exposed :: Bool,
trusted :: Bool
-- | 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)
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,
-- | 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
-- | 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
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
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
sourcePackageId <- get
packageName <- get
packageVersion <- get
- unitId <- get
+ unitId <- get
abiHash <- get
depends <- get
importDirs <- get
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 #-}
-----------------------------------------------------------------------------
--
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
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,
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
git.haskell.org / ghc.git / commitdiff
