Commit e54500c1 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

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.
parent ef9c608e
Pipeline #17256 failed with stages
in 392 minutes and 59 seconds
......@@ -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
......@@ -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
......
......@@ -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)
......
......@@ -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
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
......@@ -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
......
......@@ -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) }
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
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