- lookupPackageByName :: FastString -> PackageIdH
- lookupPackageByName nm =
- case [ conf | p <- dep_exposed,
- Just conf <- [lookupPackage pkg_db p],
- nm == mkFastString (pkgName (package conf)) ] of
- [] -> HomePackage
- (p:ps) -> ExtPackage (mkPackageId (package p))
-
- -- Get the PackageIds for some known packages (we know the names,
- -- but we don't know the versions). Some of these packages might
- -- not exist in the database, so they are Maybes.
- basePackageId = lookupPackageByName basePackageName
- rtsPackageId = lookupPackageByName rtsPackageName
- haskell98PackageId = lookupPackageByName haskell98PackageName
- thPackageId = lookupPackageByName thPackageName
-
- -- add base & rts to the explicit packages
- basicLinkedPackages = [basePackageId,rtsPackageId]
- explicit' = addListToUniqSet explicit
- [ p | ExtPackage p <- basicLinkedPackages ]
- --
- -- Close the explicit packages with their dependencies
+ wired_in_pkgids :: [(PackageId, [String])]
+ wired_in_pkgids = [ (primPackageId, [""]),
+ (integerPackageId, [""]),
+ (basePackageId, [""]),
+ (rtsPackageId, [""]),
+ (haskell98PackageId, [""]),
+ (sybPackageId, [""]),
+ (thPackageId, [""]),
+ (dphSeqPackageId, [""]),
+ (dphParPackageId, [""])]
+
+ matches :: PackageConfig -> (PackageId, [String]) -> Bool
+ pc `matches` (pid, suffixes)
+ = display (pkgName (package pc)) `elem`
+ (map (packageIdString pid ++) suffixes)
+
+ -- find which package corresponds to each wired-in package
+ -- delete any other packages with the same name
+ -- update the package and any dependencies to point to the new
+ -- one.
+ --
+ -- When choosing which package to map to a wired-in package
+ -- name, we prefer exposed packages, and pick the latest
+ -- version. To override the default choice, -hide-package
+ -- could be used to hide newer versions.
+ --
+ findWiredInPackage :: [PackageConfig] -> (PackageId, [String])
+ -> IO (Maybe (PackageIdentifier, PackageId))
+ findWiredInPackage pkgs wired_pkg =
+ let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
+ case all_ps of
+ [] -> notfound
+ many -> pick (head (sortByVersion many))
+ where
+ suffixes = snd wired_pkg
+ notfound = do
+ debugTraceMsg dflags 2 $
+ ptext (sLit "wired-in package ")
+ <> ppr (fst wired_pkg)
+ <> (if null suffixes
+ then empty
+ else text (show suffixes))
+ <> ptext (sLit " not found.")
+ return Nothing
+ pick :: InstalledPackageInfo_ ModuleName
+ -> IO (Maybe (PackageIdentifier, PackageId))
+ pick pkg = do
+ debugTraceMsg dflags 2 $
+ ptext (sLit "wired-in package ")
+ <> ppr (fst wired_pkg)
+ <> ptext (sLit " mapped to ")
+ <> text (display (package pkg))
+ return (Just (package pkg, fst wired_pkg))
+
+
+ mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids
+ let
+ wired_in_ids = catMaybes mb_wired_in_ids
+
+ -- this is old: we used to assume that if there were
+ -- multiple versions of wired-in packages installed that
+ -- they were mutually exclusive. Now we're assuming that
+ -- you have one "main" version of each wired-in package
+ -- (the latest version), and the others are backward-compat
+ -- wrappers that depend on this one. e.g. base-4.0 is the
+ -- latest, base-3.0 is a compat wrapper depending on base-4.0.
+ {-
+ deleteOtherWiredInPackages pkgs = filterOut bad pkgs
+ where bad p = any (p `matches`) wired_in_pkgids
+ && package p `notElem` map fst wired_in_ids
+ -}
+
+ updateWiredInDependencies pkgs = map upd_pkg pkgs
+ where upd_pkg p = p{ package = upd_pid (package p),
+ depends = map upd_pid (depends p) }
+
+ upd_pid pid = case filter ((== pid) . fst) wired_in_ids of
+ [] -> pid
+ ((x, y):_) -> x{ pkgName = PackageName (packageIdString y),
+ pkgVersion = Version [] [] }
+
+ -- pkgs1 = deleteOtherWiredInPackages pkgs
+
+ pkgs2 = updateWiredInDependencies pkgs
+
+ preload1 = map upd_pid preload
+
+ -- we must return an updated thisPackage, just in case we
+ -- are actually compiling one of the wired-in packages
+ Just old_this_pkg = unpackPackageId this_package
+ new_this_pkg = mkPackageId (upd_pid old_this_pkg)
+
+ return (pkgs2, preload1, new_this_pkg)
+
+-- ----------------------------------------------------------------------------
+--
+-- Detect any packages that have missing dependencies, and also any
+-- mutually-recursive groups of packages (loops in the package graph
+-- are not allowed). We do this by taking the least fixpoint of the
+-- dependency graph, repeatedly adding packages whose dependencies are
+-- satisfied until no more can be added.
+--
+elimDanglingDeps
+ :: DynFlags
+ -> [PackageConfig]
+ -> [PackageId] -- ignored packages
+ -> IO [PackageConfig]
+
+elimDanglingDeps dflags pkgs ignored = go [] pkgs'
+ where
+ pkgs' = filter (\p -> packageConfigId p `notElem` ignored) pkgs
+
+ go avail not_avail =
+ case partitionWith (depsAvailable avail) not_avail of
+ ([], not_avail) -> do mapM_ reportElim not_avail; return avail
+ (new_avail, not_avail) -> go (new_avail ++ avail) (map fst not_avail)
+
+ depsAvailable :: [PackageConfig] -> PackageConfig
+ -> Either PackageConfig (PackageConfig, [PackageIdentifier])
+ depsAvailable pkgs_ok pkg
+ | null dangling = Left pkg
+ | otherwise = Right (pkg, dangling)
+ where dangling = filter (`notElem` pids) (depends pkg)
+ pids = map package pkgs_ok
+
+ reportElim (p, deps) =
+ debugTraceMsg dflags 2 $
+ (ptext (sLit "package") <+> pprPkg p <+>
+ ptext (sLit "will be ignored due to missing or recursive dependencies:") $$
+ nest 2 (hsep (map (text.display) deps)))
+
+-- -----------------------------------------------------------------------------
+-- When all the command-line options are in, we can process our package
+-- settings and populate the package state.
+
+mkPackageState
+ :: DynFlags
+ -> PackageConfigMap -- initial database
+ -> [PackageId] -- preloaded packages
+ -> PackageId -- this package
+ -> IO (PackageState,
+ [PackageId], -- new packages to preload
+ PackageId) -- this package, might be modified if the current
+
+ -- package is a wired-in package.
+
+mkPackageState dflags orig_pkg_db preload0 this_package = do