[Git][ghc/ghc][master] Store ComponentId details
Marge Bot
gitlab at gitlab.haskell.org
Sun Mar 29 21:30:59 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
e54500c1 by Sylvain Henry at 2020-03-29T17:30:47-04:00
Store ComponentId details
As far as GHC is concerned, installed package components ("units") are
identified by an opaque ComponentId string provided by Cabal. But we
don't want to display it to users (as it contains a hash) so GHC queries
the database to retrieve some infos about the original source package
(name, version, component name).
This patch caches these infos in the ComponentId itself so that we don't
need to provide DynFlags (which contains installed package informations)
to print a ComponentId.
In the future we want GHC to support several independent package states
(e.g. for plugins and for target code), hence we need to avoid
implicitly querying a single global package state.
- - - - -
15 changed files:
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Finder.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Packages.hs
- compiler/GHC/Driver/Packages.hs-boot
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Driver/Types.hs
- compiler/GHC/Runtime/Linker.hs
- compiler/GHC/Types/Module.hs
- compiler/GHC/Types/Module.hs-boot
- compiler/main/UnitInfo.hs
- compiler/typecheck/TcBackpack.hs
- ghc/GHCi/UI.hs
- ghc/Main.hs
Changes:
=====================================
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
=====================================
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
=====================================
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)
=====================================
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
=====================================
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
=====================================
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
=====================================
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) }
=====================================
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 at MMM, are there only one
-- exposed packages whose package ID is pkg-0.1?
= False
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -2345,7 +2345,8 @@ isSafeModule m = do
tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)
| otherwise = S.partition part deps
- where part pkg = trusted $ getInstalledPackageDetails dflags pkg
+ where part pkg = trusted $ getInstalledPackageDetails pkgstate pkg
+ pkgstate = pkgState dflags
-----------------------------------------------------------------------------
-- :browse
=====================================
ghc/Main.hs
=====================================
@@ -865,9 +865,9 @@ dumpFastStringStats dflags = do
x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'
showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()
-showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags))
-dumpPackages dflags = putMsg dflags (pprPackages dflags)
-dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)
+showPackages dflags = putStrLn (showSDoc dflags (pprPackages (pkgState dflags)))
+dumpPackages dflags = putMsg dflags (pprPackages (pkgState dflags))
+dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple (pkgState dflags))
-- -----------------------------------------------------------------------------
-- Frontend plugin support
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e54500c12de051cb9695728d27c812e5160593ee
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e54500c12de051cb9695728d27c812e5160593ee
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200329/0644fe7d/attachment-0001.html>
More information about the ghc-commits
mailing list