+mkPackageState :: DynFlags -> PackageConfigMap -> IO PackageState
+mkPackageState dflags pkg_db = do
+ --
+ -- Modify the package database according to the command-line flags
+ -- (-package, -hide-package, -ignore-package).
+ --
+ -- Also, here we build up a set of the packages mentioned in -package
+ -- flags on the command line; these are called the "explicit" packages.
+ -- we link these packages in eagerly. The explicit set should contain
+ -- at least rts & base, which is why we pretend that the command line
+ -- contains -package rts & -package base.
+ --
+ let
+ flags = reverse (packageFlags dflags)
+
+ procflags pkgs expl [] = return (pkgs,expl)
+ procflags pkgs expl (ExposePackage str : flags) = do
+ case partition (matches str) pkgs of
+ ([],_) -> missingPackageErr str
+ ([p],ps) -> procflags (p':ps) (addOneToUniqSet expl pkgid) flags
+ where pkgid = packageConfigId p
+ p' = p {exposed=True}
+ (ps,_) -> multiplePackagesErr str ps
+ procflags pkgs expl (HidePackage str : flags) = do
+ case partition (matches str) pkgs of
+ ([],_) -> missingPackageErr str
+ ([p],ps) -> procflags (p':ps) expl flags
+ where p' = p {exposed=False}
+ (ps,_) -> multiplePackagesErr str ps
+ procflags pkgs expl (IgnorePackage str : flags) = do
+ case partition (matches str) pkgs of
+ (ps,qs) -> procflags qs expl flags
+ -- 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.
+
+ -- A package named on the command line can either include the
+ -- version, or just the name if it is unambiguous.
+ matches str p
+ = str == showPackageId (package p)
+ || str == pkgName (package p)
+ --
+ (pkgs1,explicit) <- procflags (eltsUFM pkg_db) emptyUniqSet flags
+ --
+ let
+ elimDanglingDeps pkgs =
+ case partition (hasDanglingDeps pkgs) pkgs of
+ ([],ps) -> ps
+ (ps,qs) -> elimDanglingDeps qs
+
+ hasDanglingDeps pkgs p = any dangling (depends p)
+ where dangling pid = pid `notElem` all_pids
+ all_pids = map package pkgs
+ --
+ -- Eliminate any packages which have dangling dependencies (perhaps
+ -- because the package was removed by -ignore-package).
+ --
+ let pkgs = elimDanglingDeps pkgs1
+ pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs
+ --
+ -- Find the transitive closure of dependencies of exposed
+ --
+ let exposed_pkgids = [ packageConfigId p | p <- pkgs, exposed p ]
+ dep_exposed <- closeDeps pkg_db exposed_pkgids
+ --
+ -- Look up some known PackageIds
+ --
+ let
+ 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
+ --
+ dep_explicit <- closeDeps pkg_db (uniqSetToList explicit')
+ --
+ -- Build up a mapping from Module -> PackageConfig for all modules.
+ -- Discover any conflicts at the same time, and factor in the new exposed
+ -- status of each package.
+ --
+ let
+ extend_modmap modmap pkgname = do
+ let
+ pkg = fromJust (lookupPackage pkg_db pkgname)
+ exposed_mods = map mkModule (exposedModules pkg)
+ hidden_mods = map mkModule (hiddenModules pkg)
+ all_mods = exposed_mods ++ hidden_mods
+ --
+ -- check for overlaps
+ --
+ let
+ overlaps = [ (m,pkg) | m <- all_mods,
+ Just (pkg,_) <- [lookupUFM modmap m] ]
+ --
+ when (not (null overlaps)) $ overlappingError pkg overlaps
+ --
+ let
+ return (addListToUFM modmap
+ [(m, (pkg, m `elem` exposed_mods))
+ | m <- all_mods])
+ --
+ mod_map <- foldM extend_modmap emptyUFM dep_exposed
+
+ return PackageState{ explicitPackages = dep_explicit,
+ pkgIdMap = pkg_db,
+ moduleToPkgConf = mod_map,
+ basePackageId = basePackageId,
+ rtsPackageId = rtsPackageId,
+ haskell98PackageId = haskell98PackageId,
+ thPackageId = thPackageId
+ }
+ -- done!
+
+basePackageName = FSLIT("base")
+rtsPackageName = FSLIT("rts")
+haskell98PackageName = FSLIT("haskell98")
+thPackageName = FSLIT("template-haskell")
+ -- Template Haskell libraries in here
+
+overlappingError pkg overlaps
+ = throwDyn (CmdLineError (showSDoc (vcat (map msg overlaps))))
+ where
+ this_pkg = text (showPackageId (package pkg))
+ msg (mod,other_pkg) =
+ text "Error: module '" <> ppr mod
+ <> text "' is exposed by package "
+ <> this_pkg <> text " and package "
+ <> text (showPackageId (package other_pkg))
+
+multiplePackagesErr str ps =
+ throwDyn (CmdLineError (showSDoc (
+ text "Error; multiple packages match" <+>
+ text str <> colon <+>
+ sep (punctuate comma (map (text.showPackageId.package) ps))
+ )))
+
+-- -----------------------------------------------------------------------------
+-- Extracting information from the packages in scope
+
+-- Many of these functions take a list of packages: in those cases,
+-- the list is expected to contain the "dependent packages",
+-- i.e. those packages that were found to be depended on by the
+-- current module/program. These can be auto or non-auto packages, it
+-- doesn't really matter. The list is always combined with the list
+-- of explicit (command-line) packages to determine which packages to
+-- use.
+
+getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String]
+getPackageIncludePath dflags pkgs = do
+ ps <- getExplicitPackagesAnd dflags pkgs
+ return (nub (filter notNull (concatMap includeDirs ps)))
+
+ -- includes are in reverse dependency order (i.e. rts first)
+getPackageCIncludes :: [PackageConfig] -> IO [String]
+getPackageCIncludes pkg_configs = do
+ return (reverse (nub (filter notNull (concatMap includes pkg_configs))))
+
+getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String]
+getPackageLibraryPath dflags pkgs = do
+ ps <- getExplicitPackagesAnd dflags pkgs
+ return (nub (filter notNull (concatMap libraryDirs ps)))
+
+getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String]
+getPackageLinkOpts dflags pkgs = do
+ ps <- getExplicitPackagesAnd dflags pkgs
+ tag <- readIORef v_Build_tag
+ rts_tag <- readIORef v_RTS_Build_tag
+ static <- readIORef v_Static
+ let
+ imp = if static then "" else "_dyn"
+ libs p = map ((++imp) . addSuffix) (hACK (hsLibraries p)) ++ extraLibraries p
+ all_opts p = map ("-l" ++) (libs p) ++ extraLdOpts p
+
+ suffix = if null tag then "" else '_':tag
+ rts_suffix = if null rts_tag then "" else '_':rts_tag
+
+ addSuffix rts@"HSrts" = rts ++ rts_suffix
+ addSuffix other_lib = other_lib ++ suffix
+
+ return (concat (map all_opts ps))