Commit 72547264 authored by Simon Marlow's avatar Simon Marlow

Add unique package identifiers (InstalledPackageId) in the package DB

See commentary at
http://hackage.haskell.org/trac/ghc/wiki/Commentary/Packages
parent 21c5c9c0
......@@ -464,6 +464,7 @@ $(eval $(call compiler-hs-dependency,PrimOp,$(PRIMOP_BITS)))
ifneq "$(ProjectPatchLevel)" "0"
compiler/stage1/inplace-pkg-config-munged: compiler/stage1/inplace-pkg-config
sed -e 's/^\(version: .*\)\.$(ProjectPatchLevel)$$/\1/' \
-e 's/^\(id: .*\)\.$(ProjectPatchLevel)$$/\1/' \
-e 's/^\(hs-libraries: HSghc-.*\)\.$(ProjectPatchLevel)$$/\1/' \
< $< > $@
"$(compiler_stage1_GHC_PKG)" update --force $(compiler_stage1_GHC_PKG_OPTS) $@
......
......@@ -51,6 +51,7 @@ import ErrUtils
import SrcLoc
import qualified Maybes
import UniqSet
import FiniteMap
import Constants
import FastString
import Config ( cProjectVersion )
......@@ -973,23 +974,25 @@ linkPackages dflags new_pkgs = do
linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState
-> IO PersistentLinkerState
linkPackages' dflags new_pks pls = do
let pkg_map = pkgIdMap (pkgState dflags)
pkgs' <- link pkg_map (pkgs_loaded pls) new_pks
pkgs' <- link (pkgs_loaded pls) new_pks
return $! pls { pkgs_loaded = pkgs' }
where
link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
link pkg_map pkgs new_pkgs =
foldM (link_one pkg_map) pkgs new_pkgs
pkg_map = pkgIdMap (pkgState dflags)
ipid_map = installedPackageIdMap (pkgState dflags)
link :: [PackageId] -> [PackageId] -> IO [PackageId]
link pkgs new_pkgs =
foldM link_one pkgs new_pkgs
link_one pkg_map pkgs new_pkg
link_one pkgs new_pkg
| new_pkg `elem` pkgs -- Already linked
= return pkgs
| Just pkg_cfg <- lookupPackage pkg_map new_pkg
= do { -- Link dependents first
pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
pkgs' <- link pkgs [ Maybes.expectJust "link_one" $
lookupFM ipid_map ipid
| ipid <- depends pkg_cfg ]
-- Now link the package itself
; linkPackage dflags pkg_cfg
; return (new_pkg : pkgs') }
......
......@@ -2058,13 +2058,7 @@ ignorePackage p =
upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s })
setPackageName :: String -> DynFlags -> DynFlags
setPackageName p
| Nothing <- unpackPackageId pid
= ghcError (CmdLineError ("cannot parse \'" ++ p ++ "\' as a package identifier"))
| otherwise
= \s -> s{ thisPackage = pid }
where
pid = stringToPackageId p
setPackageName p s = s{ thisPackage = stringToPackageId p }
-- If we're linking a binary, then only targets that produce object
-- code are allowed (requests for other target types are ignored).
......
......@@ -7,7 +7,7 @@ module PackageConfig (
-- $package_naming
-- * PackageId
mkPackageId, packageConfigId, unpackPackageId,
mkPackageId, packageConfigId,
-- * The PackageConfig type: information about a package
PackageConfig,
......@@ -28,7 +28,6 @@ import Distribution.ModuleName
import Distribution.Package hiding (PackageId)
import Distribution.Text
import Distribution.Version
import Distribution.Compat.ReadP
-- -----------------------------------------------------------------------------
-- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we
......@@ -62,15 +61,6 @@ mkPackageId = stringToPackageId . display
packageConfigId :: PackageConfig -> PackageId
packageConfigId = mkPackageId . package
-- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if
-- we could not parse it as such an object.
unpackPackageId :: PackageId -> Maybe PackageIdentifier
unpackPackageId p
= case [ pid | (pid,"") <- readP_to_S parse str ] of
[] -> Nothing
(pid:_) -> Just pid
where str = packageIdString p
-- | Turn a 'PackageConfig', which contains GHC 'Module.ModuleName's into a Cabal specific
-- 'InstalledPackageInfo' which contains Cabal 'Distribution.ModuleName.ModuleName's
packageConfigToInstalledPackageInfo :: PackageConfig -> InstalledPackageInfo
......
This diff is collapsed.
......@@ -81,8 +81,12 @@ field :: { PackageConfig -> PackageConfig }
_ -> happyError }
}
| VARID '=' CONID STRING { id }
-- another case of license
| VARID '=' CONID STRING
{ \p -> case unpackFS $1 of
"installedPackageId" ->
p{installedPackageId = InstalledPackageId (unpackFS $4)}
_ -> p -- another case of license
}
| VARID '=' strlist
{\p -> case unpackFS $1 of
......@@ -107,7 +111,7 @@ field :: { PackageConfig -> PackageConfig }
_ -> p
}
| VARID '=' pkgidlist
| VARID '=' ipidlist
{% case unpackFS $1 of
"depends" -> return (\p -> p{depends = $3})
_ -> happyError
......@@ -129,13 +133,20 @@ version :: { Version }
{ Version{ versionBranch=$5,
versionTags=map unpackFS $9 } }
pkgidlist :: { [PackageIdentifier] }
: '[' pkgids ']' { $2 }
ipid :: { InstalledPackageId }
: CONID STRING
{% case unpackFS $1 of
"InstalledPackageId" -> return (InstalledPackageId (unpackFS $2))
_ -> happyError
}
ipidlist :: { [InstalledPackageId] }
: '[' ipids ']' { $2 }
-- empty list case is covered by strlist, to avoid conflicts
pkgids :: { [PackageIdentifier] }
: pkgid { [ $1 ] }
| pkgid ',' pkgids { $1 : $3 }
ipids :: { [InstalledPackageId] }
: ipid { [ $1 ] }
| ipid ',' ipids { $1 : $3 }
intlist :: { [Int] }
: '[' ']' { [] }
......
name: ffi
version: 1.0
id: builtin:ffi
license: BSD3
maintainer: glasgow-haskell-users@haskell.org
exposed: True
......
......@@ -5,6 +5,7 @@
name: rts
version: 1.0
id: builtin:rts
license: BSD3
maintainer: glasgow-haskell-users@haskell.org
exposed: True
......@@ -55,7 +56,7 @@ include-dirs: TOP"/includes"
#endif
includes: Stg.h
depends: ffi-1.0
depends: builtin:ffi
hugs-options:
cc-options:
......
......@@ -25,6 +25,7 @@ import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import Data.Char
main :: IO ()
main = do args <- getArgs
......@@ -208,9 +209,11 @@ generate config_args distdir directory
(Nothing, Nothing) -> return ()
(Just lib, Just clbi) -> do
cwd <- getCurrentDirectory
let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
pd lib lbi clbi
content = Installed.showInstalledPackageInfo installedPkgInfo ++ "\n"
final_ipi = installedPkgInfo{ Installed.installedPackageId = ipid }
content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
writeFileAtomic (distdir </> "inplace-pkg-config") content
_ -> error "Inconsistent lib components; can't happen?"
......@@ -242,16 +245,19 @@ generate config_args distdir directory
-- stricter than gnu ld). Thus we remove the ldOptions for
-- GHC's rts package:
hackRtsPackage index =
case PackageIndex.lookupPackageName index (PackageName "rts") of
[rts] -> PackageIndex.insert rts { Installed.ldOptions = [] } index
case PackageIndex.lookupInstalledPackageByName index (PackageName "rts") of
[rts] -> PackageIndex.addToInstalledPackageIndex rts { Installed.ldOptions = [] } index
_ -> error "No (or multiple) ghc rts package is registered!!"
dep_ids = map (packageId.getLocalPackageInfo lbi) $
externalPackageDeps lbi
let variablePrefix = directory ++ '_':distdir
let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
variablePrefix ++ "_DEPS = " ++ unwords (map display (externalPackageDeps lbi)),
variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) (externalPackageDeps lbi)),
variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
......
This diff is collapsed.
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