+ wired_in_pkgids :: [String]
+ wired_in_pkgids = map packageIdString
+ [ primPackageId,
+ integerPackageId,
+ basePackageId,
+ rtsPackageId,
+ thPackageId,
+ dphSeqPackageId,
+ dphParPackageId ]
+
+ matches :: PackageConfig -> String -> Bool
+ pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid
+
+ -- 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] -> String
+ -> IO (Maybe InstalledPackageId)
+ 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
+ notfound = do
+ debugTraceMsg dflags 2 $
+ ptext (sLit "wired-in package ")
+ <> text wired_pkg
+ <> ptext (sLit " not found.")
+ return Nothing
+ pick :: InstalledPackageInfo_ ModuleName
+ -> IO (Maybe InstalledPackageId)
+ pick pkg = do
+ debugTraceMsg dflags 2 $
+ ptext (sLit "wired-in package ")
+ <> text wired_pkg
+ <> ptext (sLit " mapped to ")
+ <> pprIPkg pkg
+ return (Just (installedPackageId 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
+ | installedPackageId p `elem` wired_in_ids
+ = p { sourcePackageId = (sourcePackageId p){ pkgVersion = Version [] [] } }
+ | otherwise
+ = p
+
+ return $ updateWiredInDependencies pkgs
+
+-- ----------------------------------------------------------------------------
+
+data UnusablePackageReason
+ = IgnoredWithFlag
+ | MissingDependencies [InstalledPackageId]
+ | ShadowedBy InstalledPackageId
+
+type UnusablePackages = Map InstalledPackageId UnusablePackageReason
+
+pprReason :: SDoc -> UnusablePackageReason -> SDoc
+pprReason pref reason = case reason of
+ IgnoredWithFlag ->
+ pref <+> ptext (sLit "ignored due to an -ignore-package flag")
+ MissingDependencies deps ->
+ pref <+>
+ ptext (sLit "unusable due to missing or recursive dependencies:") $$
+ nest 2 (hsep (map (text.display) deps))
+ ShadowedBy ipid ->
+ pref <+> ptext (sLit "shadowed by package ") <> text (display ipid)
+
+reportUnusable :: DynFlags -> UnusablePackages -> IO ()
+reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
+ where
+ report (ipid, reason) =
+ debugTraceMsg dflags 2 $
+ pprReason
+ (ptext (sLit "package") <+>
+ text (display ipid) <+> text "is") reason
+
+-- ----------------------------------------------------------------------------
+--
+-- 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.
+--
+findBroken :: [PackageConfig] -> UnusablePackages
+findBroken pkgs = go [] Map.empty pkgs
+ where
+ go avail ipids not_avail =
+ case partitionWith (depsAvailable ipids) not_avail of
+ ([], not_avail) ->
+ Map.fromList [ (installedPackageId p, MissingDependencies deps)
+ | (p,deps) <- not_avail ]
+ (new_avail, not_avail) ->
+ go (new_avail ++ avail) new_ipids (map fst not_avail)
+ where new_ipids = Map.insertList
+ [ (installedPackageId p, p) | p <- new_avail ]
+ ipids
+
+ depsAvailable :: InstalledPackageIndex
+ -> PackageConfig
+ -> Either PackageConfig (PackageConfig, [InstalledPackageId])
+ depsAvailable ipids pkg
+ | null dangling = Left pkg
+ | otherwise = Right (pkg, dangling)
+ where dangling = filter (not . (`Map.member` ipids)) (depends pkg)
+
+-- -----------------------------------------------------------------------------
+-- Eliminate shadowed packages, giving the user some feedback
+
+-- later packages in the list should shadow earlier ones with the same
+-- package name/version. Additionally, a package may be preferred if
+-- it is in the transitive closure of packages selected using -package-id
+-- flags.
+shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
+shadowPackages pkgs preferred
+ = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
+ in Map.fromList shadowed
+ where
+ check (shadowed,pkgmap) pkg
+ | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)
+ , let
+ ipid_new = installedPackageId pkg
+ ipid_old = installedPackageId oldpkg
+ --
+ , ipid_old /= ipid_new
+ = if ipid_old `elem` preferred
+ then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap )
+ else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' )
+ | otherwise
+ = (shadowed, pkgmap')
+ where
+ pkgmap' = addToUFM pkgmap (packageConfigId pkg) pkg
+
+-- -----------------------------------------------------------------------------
+
+ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
+ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
+ where
+ doit (IgnorePackage str) =
+ case partition (matchingStr str) pkgs of
+ (ps, _) -> [ (installedPackageId p, IgnoredWithFlag)
+ | p <- ps ]
+ -- missing package is not an error for -ignore-package,
+ -- because a common usage is to -ignore-package P as
+ -- a preventative measure just in case P exists.
+ doit _ = panic "ignorePackages"
+
+-- -----------------------------------------------------------------------------
+
+depClosure :: InstalledPackageIndex
+ -> [InstalledPackageId]
+ -> [InstalledPackageId]
+depClosure index ipids = closure Map.empty ipids
+ where
+ closure set [] = Map.keys set
+ closure set (ipid : ipids)
+ | ipid `Map.member` set = closure set ipids
+ | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set)
+ (depends p ++ ipids)
+ | otherwise = closure set ipids
+
+-- -----------------------------------------------------------------------------
+-- When all the command-line options are in, we can process our package
+-- settings and populate the package state.
+
+mkPackageState
+ :: DynFlags
+ -> [PackageConfig] -- 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 pkgs0 preload0 this_package = do
+
+{-
+ Plan.
+
+ 1. P = transitive closure of packages selected by -package-id
+
+ 2. Apply shadowing. When there are multiple packages with the same
+ sourcePackageId,
+ * if one is in P, use that one
+ * otherwise, use the one highest in the package stack
+ [
+ rationale: we cannot use two packages with the same sourcePackageId
+ in the same program, because sourcePackageId is the symbol prefix.
+ Hence we must select a consistent set of packages to use. We have
+ a default algorithm for doing this: packages higher in the stack
+ shadow those lower down. This default algorithm can be overriden
+ by giving explicit -package-id flags; then we have to take these
+ preferences into account when selecting which other packages are
+ made available.
+
+ Our simple algorithm throws away some solutions: there may be other
+ consistent sets that would satisfy the -package flags, but it's
+ not GHC's job to be doing constraint solving.
+ ]
+
+ 3. remove packages selected by -ignore-package
+
+ 4. remove any packages with missing dependencies, or mutually recursive
+ dependencies.
+
+ 5. report (with -v) any packages that were removed by steps 2-4
+
+ 6. apply flags to set exposed/hidden on the resulting packages
+ - if any flag refers to a package which was removed by 2-4, then
+ we can give an error message explaining why
+
+ 7. hide any packages which are superseded by later exposed packages
+-}