summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Driver/Backpack.hs31
-rw-r--r--compiler/GHC/Driver/Finder.hs6
-rw-r--r--compiler/GHC/Driver/Main.hs2
-rw-r--r--compiler/GHC/Driver/Packages.hs111
-rw-r--r--compiler/GHC/Driver/Packages.hs-boot7
-rw-r--r--compiler/GHC/Driver/Pipeline.hs3
-rw-r--r--compiler/GHC/Driver/Session.hs11
-rw-r--r--compiler/GHC/Driver/Types.hs2
-rw-r--r--compiler/GHC/Runtime/Linker.hs3
-rw-r--r--compiler/GHC/Types/Module.hs53
-rw-r--r--compiler/GHC/Types/Module.hs-boot3
-rw-r--r--compiler/main/UnitInfo.hs5
-rw-r--r--compiler/typecheck/TcBackpack.hs22
13 files changed, 168 insertions, 91 deletions
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 61cac8bb40..a2e136be14 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -87,7 +87,8 @@ doBackpack [src_filename] = do
POk _ pkgname_bkp -> do
-- OK, so we have an LHsUnit PackageName, but we want an
-- LHsUnit HsComponentId. So let's rename it.
- let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp
+ let pkgstate = pkgState dflags
+ let bkp = renameHsUnits pkgstate (packageNameMap pkgstate pkgname_bkp) pkgname_bkp
initBkpM src_filename bkp $
forM_ (zip [1..] bkp) $ \(i, lunit) -> do
let comp_name = unLoc (hsunitName (unLoc lunit))
@@ -95,7 +96,7 @@ doBackpack [src_filename] = do
innerBkpM $ do
let (cid, insts) = computeUnitId lunit
if null insts
- then if cid == ComponentId (fsLit "main")
+ then if cid == ComponentId (fsLit "main") Nothing
then compileExe lunit
else compileUnit cid []
else typecheckUnit cid insts
@@ -136,7 +137,7 @@ withBkpSession :: ComponentId
-> BkpM a
withBkpSession cid insts deps session_type do_this = do
dflags <- getDynFlags
- let (ComponentId cid_fs) = cid
+ let (ComponentId cid_fs _) = cid
is_primary = False
uid_str = unpackFS (hashUnitId cid insts)
cid_str = unpackFS cid_fs
@@ -205,7 +206,7 @@ withBkpSession cid insts deps session_type do_this = do
withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
withBkpExeSession deps do_this = do
- withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this
+ withBkpSession (ComponentId (fsLit "main") Nothing) [] deps ExeSession do_this
getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
getSource cid = do
@@ -303,7 +304,7 @@ buildUnit session cid insts lunit = do
getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
obj_files = concatMap getOfiles linkables
- let compat_fs = (case cid of ComponentId fs -> fs)
+ let compat_fs = (case cid of ComponentId fs _ -> fs)
compat_pn = PackageName compat_fs
return InstalledPackageInfo {
@@ -560,22 +561,22 @@ type PackageNameMap a = Map PackageName a
-- For now, something really simple, since we're not actually going
-- to use this for anything
-unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
-unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
- = (pn, HsComponentId pn (ComponentId fs))
+unitDefines :: PackageState -> LHsUnit PackageName -> (PackageName, HsComponentId)
+unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
+ = (pn, HsComponentId pn (mkComponentId pkgstate fs))
-packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
-packageNameMap units = Map.fromList (map unitDefines units)
+packageNameMap :: PackageState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId
+packageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units)
-renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
-renameHsUnits dflags m units = map (fmap renameHsUnit) units
+renameHsUnits :: PackageState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
+renameHsUnits pkgstate m units = map (fmap renameHsUnit) units
where
renamePackageName :: PackageName -> HsComponentId
renamePackageName pn =
case Map.lookup pn m of
Nothing ->
- case lookupPackageName dflags pn of
+ case lookupPackageName pkgstate pn of
Nothing -> error "no package name"
Just cid -> HsComponentId pn cid
Just hscid -> hscid
@@ -824,7 +825,7 @@ hsModuleToModSummary pn hsc_src modname
-- | Create a new, externally provided hashed unit id from
-- a hash.
newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
-newInstalledUnitId (ComponentId cid_fs) (Just fs)
+newInstalledUnitId (ComponentId cid_fs _) (Just fs)
= InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
-newInstalledUnitId (ComponentId cid_fs) Nothing
+newInstalledUnitId (ComponentId cid_fs _) Nothing
= InstalledUnitId cid_fs
diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs
index a9f0fda13e..d2538d90e8 100644
--- a/compiler/GHC/Driver/Finder.hs
+++ b/compiler/GHC/Driver/Finder.hs
@@ -340,8 +340,9 @@ findPackageModule hsc_env mod = do
let
dflags = hsc_dflags hsc_env
pkg_id = installedModuleUnitId mod
+ pkgstate = pkgState dflags
--
- case lookupInstalledPackage dflags pkg_id of
+ case lookupInstalledPackage pkgstate pkg_id of
Nothing -> return (InstalledNoPackage pkg_id)
Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf
@@ -805,12 +806,13 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result
_ -> panic "cantFindInstalledErr"
build_tag = buildTag dflags
+ pkgstate = pkgState dflags
looks_like_srcpkgid :: InstalledUnitId -> SDoc
looks_like_srcpkgid pk
-- Unsafely coerce a unit id FastString into a source package ID
-- FastString and see if it means anything.
- | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk))
+ | (pkg:pkgs) <- searchPackageId pkgstate (SourcePackageId (installedUnitIdFS pk))
= parens (text "This unit ID looks like the source package ID;" $$
text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$
(if null pkgs then Outputable.empty
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 0c6ad34baf..3eb00cd03c 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1227,7 +1227,7 @@ checkPkgTrust pkgs = do
dflags <- getDynFlags
let errors = S.foldr go [] pkgs
go pkg acc
- | trusted $ getInstalledPackageDetails dflags pkg
+ | trusted $ getInstalledPackageDetails (pkgState dflags) pkg
= acc
| otherwise
= (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
diff --git a/compiler/GHC/Driver/Packages.hs b/compiler/GHC/Driver/Packages.hs
index 1f61d5df97..d7ecbeb39b 100644
--- a/compiler/GHC/Driver/Packages.hs
+++ b/compiler/GHC/Driver/Packages.hs
@@ -47,6 +47,7 @@ module GHC.Driver.Packages (
getPackageFrameworkPath,
getPackageFrameworks,
getUnitInfoMap,
+ getPackageState,
getPreloadPackagesAnd,
collectArchives,
@@ -54,6 +55,8 @@ module GHC.Driver.Packages (
packageHsLibs, getLibs,
-- * Utils
+ mkComponentId,
+ updateComponentId,
unwireUnitId,
pprFlag,
pprPackages,
@@ -408,21 +411,21 @@ lookupUnit' True m@(UnitInfoMap pkg_map _) uid =
-- | Find the indefinite package for a given 'ComponentId'.
-- The way this works is just by fiat'ing that every indefinite package's
-- unit key is precisely its component ID; and that they share uniques.
-lookupComponentId :: DynFlags -> ComponentId -> Maybe UnitInfo
-lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs
+lookupComponentId :: PackageState -> ComponentId -> Maybe UnitInfo
+lookupComponentId pkgstate (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs
where
- UnitInfoMap pkg_map = unitInfoMap (pkgState dflags)
+ UnitInfoMap pkg_map = unitInfoMap pkgstate
-}
-- | Find the package we know about with the given package name (e.g. @foo@), if any
-- (NB: there might be a locally defined unit name which overrides this)
-lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId
-lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags))
+lookupPackageName :: PackageState -> PackageName -> Maybe ComponentId
+lookupPackageName pkgstate n = Map.lookup n (packageNameMap pkgstate)
-- | Search for packages with a given package ID (e.g. \"foo-0.1\")
-searchPackageId :: DynFlags -> SourcePackageId -> [UnitInfo]
-searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
- (listUnitInfoMap dflags)
+searchPackageId :: PackageState -> SourcePackageId -> [UnitInfo]
+searchPackageId pkgstate pid = filter ((pid ==) . sourcePackageId)
+ (listUnitInfoMap pkgstate)
-- | Extends the package configuration map with a list of package configs.
extendUnitInfoMap
@@ -442,15 +445,15 @@ getPackageDetails dflags pid =
Just config -> config
Nothing -> pprPanic "getPackageDetails" (ppr pid)
-lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe UnitInfo
-lookupInstalledPackage dflags uid = lookupInstalledPackage' (unitInfoMap (pkgState dflags)) uid
+lookupInstalledPackage :: PackageState -> InstalledUnitId -> Maybe UnitInfo
+lookupInstalledPackage pkgstate uid = lookupInstalledPackage' (unitInfoMap pkgstate) uid
lookupInstalledPackage' :: UnitInfoMap -> InstalledUnitId -> Maybe UnitInfo
lookupInstalledPackage' (UnitInfoMap db _) uid = lookupUDFM db uid
-getInstalledPackageDetails :: HasDebugCallStack => DynFlags -> InstalledUnitId -> UnitInfo
-getInstalledPackageDetails dflags uid =
- case lookupInstalledPackage dflags uid of
+getInstalledPackageDetails :: HasDebugCallStack => PackageState -> InstalledUnitId -> UnitInfo
+getInstalledPackageDetails pkgstate uid =
+ case lookupInstalledPackage pkgstate uid of
Just config -> config
Nothing -> pprPanic "getInstalledPackageDetails" (ppr uid)
@@ -458,10 +461,10 @@ getInstalledPackageDetails dflags uid =
-- this function, although all packages in this map are "visible", this
-- does not imply that the exposed-modules of the package are available
-- (they may have been thinned or renamed).
-listUnitInfoMap :: DynFlags -> [UnitInfo]
-listUnitInfoMap dflags = eltsUDFM pkg_map
+listUnitInfoMap :: PackageState -> [UnitInfo]
+listUnitInfoMap pkgstate = eltsUDFM pkg_map
where
- UnitInfoMap pkg_map _ = unitInfoMap (pkgState dflags)
+ UnitInfoMap pkg_map _ = unitInfoMap pkgstate
-- ----------------------------------------------------------------------------
-- Loading the package db files and building up the package state
@@ -1074,6 +1077,7 @@ findWiredInPackages dflags prec_map pkgs vis_map = do
mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_unitids
let
wired_in_pkgs = catMaybes mb_wired_in_pkgs
+ pkgstate = pkgState dflags
-- this is old: we used to assume that if there were
-- multiple versions of wired-in packages installed that
@@ -1102,7 +1106,7 @@ findWiredInPackages dflags prec_map pkgs vis_map = do
= let fs = installedUnitIdFS (unDefUnitId wiredInUnitId)
in pkg {
unitId = fsToInstalledUnitId fs,
- componentId = ComponentId fs
+ componentId = mkComponentId pkgstate fs
}
| otherwise
= pkg
@@ -2054,7 +2058,7 @@ getPreloadPackagesAnd dflags pkgids0 =
pairs = zip pkgids (repeat Nothing)
in do
all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs)
- return (map (getInstalledPackageDetails dflags) all_pkgs)
+ return (map (getInstalledPackageDetails state) all_pkgs)
-- Takes a list of packages, and returns the list with dependencies included,
-- in reverse dependency order (a package appears before those it depends on).
@@ -2107,20 +2111,48 @@ missingDependencyMsg (Just parent)
-- -----------------------------------------------------------------------------
-componentIdString :: DynFlags -> ComponentId -> Maybe String
-componentIdString dflags cid = do
- conf <- lookupInstalledPackage dflags (componentIdToInstalledUnitId cid)
- return $
- case sourceLibName conf of
- Nothing -> sourcePackageIdString conf
- Just (PackageName libname) ->
- packageNameString conf
- ++ "-" ++ showVersion (packageVersion conf)
- ++ ":" ++ unpackFS libname
-
-displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
-displayInstalledUnitId dflags uid =
- fmap sourcePackageIdString (lookupInstalledPackage dflags uid)
+componentIdString :: ComponentId -> String
+componentIdString (ComponentId raw Nothing) = unpackFS raw
+componentIdString (ComponentId _raw (Just details)) =
+ case componentName details of
+ Nothing -> componentSourcePkdId details
+ Just cname -> componentPackageName details
+ ++ "-" ++ showVersion (componentPackageVersion details)
+ ++ ":" ++ cname
+
+-- Cabal packages may contain several components (programs, libraries, etc.).
+-- As far as GHC is concerned, installed package components ("units") are
+-- identified by an opaque ComponentId string provided by Cabal. As the string
+-- contains a hash, we don't want to display it to users so GHC queries the
+-- database to retrieve some infos about the original source package (name,
+-- version, component name).
+--
+-- Instead we want to display: packagename-version[:componentname]
+--
+-- Component name is only displayed if it isn't the default library
+--
+-- To do this we need to query the database (cached in DynFlags). We cache
+-- these details in the ComponentId itself because we don't want to query
+-- DynFlags each time we pretty-print the ComponentId
+--
+mkComponentId :: PackageState -> FastString -> ComponentId
+mkComponentId pkgstate raw =
+ case lookupInstalledPackage pkgstate (InstalledUnitId raw) of
+ Nothing -> ComponentId raw Nothing -- we didn't find the unit at all
+ Just c -> ComponentId raw $ Just $ ComponentDetails
+ (packageNameString c)
+ (packageVersion c)
+ ((unpackFS . unPackageName) <$> sourceLibName c)
+ (sourcePackageIdString c)
+
+-- | Update component ID details from the database
+updateComponentId :: PackageState -> ComponentId -> ComponentId
+updateComponentId pkgstate (ComponentId raw _) = mkComponentId pkgstate raw
+
+
+displayInstalledUnitId :: PackageState -> InstalledUnitId -> Maybe String
+displayInstalledUnitId pkgstate uid =
+ fmap sourcePackageIdString (lookupInstalledPackage pkgstate uid)
-- | Will the 'Name' come from a dynamically linked package?
isDynLinkName :: DynFlags -> Module -> Name -> Bool
@@ -2159,18 +2191,18 @@ isDynLinkName dflags this_mod name
-- Displaying packages
-- | Show (very verbose) package info
-pprPackages :: DynFlags -> SDoc
+pprPackages :: PackageState -> SDoc
pprPackages = pprPackagesWith pprUnitInfo
-pprPackagesWith :: (UnitInfo -> SDoc) -> DynFlags -> SDoc
-pprPackagesWith pprIPI dflags =
- vcat (intersperse (text "---") (map pprIPI (listUnitInfoMap dflags)))
+pprPackagesWith :: (UnitInfo -> SDoc) -> PackageState -> SDoc
+pprPackagesWith pprIPI pkgstate =
+ vcat (intersperse (text "---") (map pprIPI (listUnitInfoMap pkgstate)))
-- | Show simplified package info.
--
-- The idea is to only print package id, and any information that might
-- be different from the package databases (exposure, trust)
-pprPackagesSimple :: DynFlags -> SDoc
+pprPackagesSimple :: PackageState -> SDoc
pprPackagesSimple = pprPackagesWith pprIPI
where pprIPI ipi = let i = installedUnitIdFS (unitId ipi)
e = if exposed ipi then text "E" else text " "
@@ -2211,3 +2243,8 @@ improveUnitId pkg_map uid =
-- in the @hs-boot@ loop-breaker.
getUnitInfoMap :: DynFlags -> UnitInfoMap
getUnitInfoMap = unitInfoMap . pkgState
+
+-- | Retrieve the 'PackageState' from 'DynFlags'; used
+-- in the @hs-boot@ loop-breaker.
+getPackageState :: DynFlags -> PackageState
+getPackageState = pkgState
diff --git a/compiler/GHC/Driver/Packages.hs-boot b/compiler/GHC/Driver/Packages.hs-boot
index 73823c0d3b..96bb95deec 100644
--- a/compiler/GHC/Driver/Packages.hs-boot
+++ b/compiler/GHC/Driver/Packages.hs-boot
@@ -1,12 +1,15 @@
module GHC.Driver.Packages where
import GhcPrelude
+import FastString
import {-# SOURCE #-} GHC.Driver.Session (DynFlags)
import {-# SOURCE #-} GHC.Types.Module(ComponentId, UnitId, InstalledUnitId)
data PackageState
data UnitInfoMap
data PackageDatabase
emptyPackageState :: PackageState
-componentIdString :: DynFlags -> ComponentId -> Maybe String
-displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String
+componentIdString :: ComponentId -> String
+mkComponentId :: PackageState -> FastString -> ComponentId
+displayInstalledUnitId :: PackageState -> InstalledUnitId -> Maybe String
improveUnitId :: UnitInfoMap -> UnitId -> UnitId
getUnitInfoMap :: DynFlags -> UnitInfoMap
+getPackageState :: DynFlags -> PackageState
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 01e89b5fbe..a03eb6c9da 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -511,8 +511,9 @@ linkingNeeded dflags staticLink linkables pkg_deps = do
-- next, check libraries. XXX this only checks Haskell libraries,
-- not extra_libraries or -l things from the command line.
+ let pkgstate = pkgState dflags
let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib)
- | Just c <- map (lookupInstalledPackage dflags) pkg_deps,
+ | Just c <- map (lookupInstalledPackage pkgstate) pkg_deps,
lib <- packageHsLibs dflags c ]
pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 56d53838f6..8e66fef327 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -247,7 +247,7 @@ import GHC.Types.Module
import {-# SOURCE #-} GHC.Driver.Plugins
import {-# SOURCE #-} GHC.Driver.Hooks
import {-# SOURCE #-} PrelNames ( mAIN )
-import {-# SOURCE #-} GHC.Driver.Packages (PackageState, emptyPackageState, PackageDatabase)
+import {-# SOURCE #-} GHC.Driver.Packages (PackageState, emptyPackageState, PackageDatabase, mkComponentId)
import GHC.Driver.Phases ( Phase(..), phaseInputExt )
import GHC.Driver.Flags
import GHC.Driver.Ways
@@ -1959,13 +1959,14 @@ setJsonLogAction d = d { log_action = jsonLogAction }
thisComponentId :: DynFlags -> ComponentId
thisComponentId dflags =
- case thisComponentId_ dflags of
- Just cid -> cid
+ let pkgstate = pkgState dflags
+ in case thisComponentId_ dflags of
+ Just (ComponentId raw _) -> mkComponentId pkgstate raw
Nothing ->
case thisUnitIdInsts_ dflags of
Just _ ->
throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")
- Nothing -> ComponentId (unitIdFS (thisPackage dflags))
+ Nothing -> mkComponentId pkgstate (unitIdFS (thisPackage dflags))
thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)]
thisUnitIdInsts dflags =
@@ -2002,7 +2003,7 @@ setUnitIdInsts s d =
setComponentId :: String -> DynFlags -> DynFlags
setComponentId s d =
- d { thisComponentId_ = Just (ComponentId (fsLit s)) }
+ d { thisComponentId_ = Just (ComponentId (fsLit s) Nothing) }
addPluginModuleName :: String -> DynFlags -> DynFlags
addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }
diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs
index 64e031e0f5..e19a854d1c 100644
--- a/compiler/GHC/Driver/Types.hs
+++ b/compiler/GHC/Driver/Types.hs
@@ -2008,7 +2008,7 @@ mkQualPackage dflags uid
-- database!
= False
| Just pkgid <- mb_pkgid
- , searchPackageId dflags pkgid `lengthIs` 1
+ , searchPackageId (pkgState dflags) pkgid `lengthIs` 1
-- this says: we are given a package pkg-0.1@MMM, are there only one
-- exposed packages whose package ID is pkg-0.1?
= False
diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs
index 10f18a8525..48ce94a710 100644
--- a/compiler/GHC/Runtime/Linker.hs
+++ b/compiler/GHC/Runtime/Linker.hs
@@ -1248,6 +1248,7 @@ linkPackages' hsc_env new_pks pls = do
return $! pls { pkgs_loaded = pkgs' }
where
dflags = hsc_dflags hsc_env
+ pkgstate = pkgState dflags
link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId]
link pkgs new_pkgs =
@@ -1257,7 +1258,7 @@ linkPackages' hsc_env new_pks pls = do
| new_pkg `elem` pkgs -- Already linked
= return pkgs
- | Just pkg_cfg <- lookupInstalledPackage dflags new_pkg
+ | Just pkg_cfg <- lookupInstalledPackage pkgstate new_pkg
= do { -- Link dependents first
pkgs' <- link pkgs (depends pkg_cfg)
-- Now link the package itself
diff --git a/compiler/GHC/Types/Module.hs b/compiler/GHC/Types/Module.hs
index a73df28a9e..3d73d7b572 100644
--- a/compiler/GHC/Types/Module.hs
+++ b/compiler/GHC/Types/Module.hs
@@ -29,6 +29,7 @@ module GHC.Types.Module
-- * The UnitId type
ComponentId(..),
+ ComponentDetails(..),
UnitId(..),
unitIdFS,
unitIdKey,
@@ -148,7 +149,8 @@ import Binary
import Util
import Data.List (sortBy, sort)
import Data.Ord
-import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..))
+import Data.Version
+import GHC.PackageDb
import Fingerprint
import qualified Data.ByteString as BS
@@ -170,7 +172,7 @@ import qualified FiniteMap as Map
import System.FilePath
import {-# SOURCE #-} GHC.Driver.Session (DynFlags)
-import {-# SOURCE #-} GHC.Driver.Packages (componentIdString, improveUnitId, UnitInfoMap, getUnitInfoMap, displayInstalledUnitId)
+import {-# SOURCE #-} GHC.Driver.Packages (improveUnitId, componentIdString, UnitInfoMap, getUnitInfoMap, displayInstalledUnitId, getPackageState)
-- Note [The identifier lexicon]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -515,22 +517,39 @@ instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module
-- multiple components and a 'ComponentId' uniquely identifies a component
-- within a package. When a package only has one component, the 'ComponentId'
-- coincides with the 'InstalledPackageId'
-newtype ComponentId = ComponentId FastString deriving (Eq, Ord)
+data ComponentId = ComponentId
+ { componentIdRaw :: FastString -- ^ Raw
+ , componentIdDetails :: Maybe ComponentDetails -- ^ Cache of component details retrieved from the DB
+ }
+
+instance Eq ComponentId where
+ a == b = componentIdRaw a == componentIdRaw b
+
+instance Ord ComponentId where
+ compare a b = compare (componentIdRaw a) (componentIdRaw b)
+
+data ComponentDetails = ComponentDetails
+ { componentPackageName :: String
+ , componentPackageVersion :: Version
+ , componentName :: Maybe String
+ , componentSourcePkdId :: String
+ }
instance BinaryStringRep ComponentId where
- fromStringRep = ComponentId . mkFastStringByteString
- toStringRep (ComponentId s) = bytesFS s
+ fromStringRep bs = ComponentId (mkFastStringByteString bs) Nothing
+ toStringRep (ComponentId s _) = bytesFS s
instance Uniquable ComponentId where
- getUnique (ComponentId n) = getUnique n
+ getUnique (ComponentId n _) = getUnique n
instance Outputable ComponentId where
- ppr cid@(ComponentId fs) =
+ ppr cid@(ComponentId fs _) =
getPprStyle $ \sty ->
- sdocWithDynFlags $ \dflags ->
- case componentIdString dflags cid of
- Just str | not (debugStyle sty) -> text str
- _ -> ftext fs
+ if debugStyle sty
+ then ftext fs
+ else text (componentIdString cid)
+
+
{-
************************************************************************
@@ -699,7 +718,7 @@ instance Outputable InstalledUnitId where
ppr uid@(InstalledUnitId fs) =
getPprStyle $ \sty ->
sdocWithDynFlags $ \dflags ->
- case displayInstalledUnitId dflags uid of
+ case displayInstalledUnitId (getPackageState dflags) uid of
Just str | not (debugStyle sty) -> text str
_ -> ftext fs
@@ -745,7 +764,7 @@ fsToInstalledUnitId :: FastString -> InstalledUnitId
fsToInstalledUnitId fs = InstalledUnitId fs
componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId
-componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs
+componentIdToInstalledUnitId (ComponentId fs _) = fsToInstalledUnitId fs
stringToInstalledUnitId :: String -> InstalledUnitId
stringToInstalledUnitId = fsToInstalledUnitId . mkFastString
@@ -908,12 +927,12 @@ instance Binary UnitId where
_ -> fmap IndefiniteUnitId (get bh)
instance Binary ComponentId where
- put_ bh (ComponentId fs) = put_ bh fs
- get bh = do { fs <- get bh; return (ComponentId fs) }
+ put_ bh (ComponentId fs _) = put_ bh fs
+ get bh = do { fs <- get bh; return (ComponentId fs Nothing) }
-- | Create a new simple unit identifier (no holes) from a 'ComponentId'.
newSimpleUnitId :: ComponentId -> UnitId
-newSimpleUnitId (ComponentId fs) = fsToUnitId fs
+newSimpleUnitId (ComponentId fs _) = fsToUnitId fs
-- | Create a new simple unit identifier from a 'FastString'. Internally,
-- this is primarily used to specify wired-in unit identifiers.
@@ -1026,7 +1045,7 @@ parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId
return (newSimpleUnitId cid)
parseComponentId :: ReadP ComponentId
-parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char
+parseComponentId = (flip ComponentId Nothing . mkFastString) `fmap` Parse.munch1 abi_char
where abi_char c = isAlphaNum c || c `elem` "-_."
parseModuleId :: ReadP Module
diff --git a/compiler/GHC/Types/Module.hs-boot b/compiler/GHC/Types/Module.hs-boot
index 1f2fec56d7..77df64280f 100644
--- a/compiler/GHC/Types/Module.hs-boot
+++ b/compiler/GHC/Types/Module.hs-boot
@@ -1,13 +1,12 @@
module GHC.Types.Module where
import GhcPrelude
-import FastString
data Module
data ModuleName
data UnitId
data InstalledUnitId
-newtype ComponentId = ComponentId FastString
+data ComponentId
moduleName :: Module -> ModuleName
moduleUnitId :: Module -> UnitId
diff --git a/compiler/main/UnitInfo.hs b/compiler/main/UnitInfo.hs
index b1a307a7fe..3fda0b79e8 100644
--- a/compiler/main/UnitInfo.hs
+++ b/compiler/main/UnitInfo.hs
@@ -58,7 +58,10 @@ type UnitInfo = InstalledPackageInfo
-- other compact string types, e.g. plain ByteString or Text.
newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord)
-newtype PackageName = PackageName FastString deriving (Eq, Ord)
+newtype PackageName = PackageName
+ { unPackageName :: FastString
+ }
+ deriving (Eq, Ord)
instance BinaryStringRep SourcePackageId where
fromStringRep = SourcePackageId . mkFastStringByteString
diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs
index ab89e740b4..be35f02a6e 100644
--- a/compiler/typecheck/TcBackpack.hs
+++ b/compiler/typecheck/TcBackpack.hs
@@ -230,9 +230,17 @@ check_inst sig_inst = do
-- | Return this list of requirement interfaces that need to be merged
-- to form @mod_name@, or @[]@ if this is not a requirement.
-requirementMerges :: DynFlags -> ModuleName -> [IndefModule]
-requirementMerges dflags mod_name =
- fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags)))
+requirementMerges :: PackageState -> ModuleName -> [IndefModule]
+requirementMerges pkgstate mod_name =
+ fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))
+ where
+ -- update ComponentId cached details as they may have changed since the
+ -- time the ComponentId was created
+ fixupModule (IndefModule iud name) = IndefModule iud' name
+ where
+ iud' = iud { indefUnitIdComponentId = cid' }
+ cid = indefUnitIdComponentId iud
+ cid' = updateComponentId pkgstate cid
-- | For a module @modname@ of type 'HscSource', determine the list
-- of extra "imports" of other requirements which should be considered part of
@@ -265,7 +273,8 @@ findExtraSigImports' hsc_env HsigFile modname =
$ moduleFreeHolesPrecise (text "findExtraSigImports")
(mkModule (IndefiniteUnitId iuid) mod_name)))
where
- reqs = requirementMerges (hsc_dflags hsc_env) modname
+ pkgstate = pkgState (hsc_dflags hsc_env)
+ reqs = requirementMerges pkgstate modname
findExtraSigImports' _ _ _ = return emptyUniqDSet
@@ -528,10 +537,11 @@ mergeSignatures
let outer_mod = tcg_mod tcg_env
inner_mod = tcg_semantic_mod tcg_env
mod_name = moduleName (tcg_mod tcg_env)
+ pkgstate = pkgState dflags
-- STEP 1: Figure out all of the external signature interfaces
-- we are going to merge in.
- let reqs = requirementMerges dflags mod_name
+ let reqs = requirementMerges pkgstate mod_name
addErrCtxt (merge_msg mod_name reqs) $ do
@@ -560,7 +570,7 @@ mergeSignatures
let insts = indefUnitIdInsts iuid
isFromSignaturePackage =
let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid))
- pkg = getInstalledPackageDetails dflags inst_uid
+ pkg = getInstalledPackageDetails pkgstate inst_uid
in null (exposedModules pkg)
-- 3(a). Rename the exports according to how the dependency
-- was instantiated. The resulting export list will be accurate
View Lorry Controller Status