+ extend_modmap pkgname modmap =
+ addListToUFM_C (++) modmap
+ [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods]
+ where
+ pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgname)
+ exposed_mods = map mkModule (exposedModules pkg)
+ hidden_mods = map mkModule (hiddenModules pkg)
+ all_mods = exposed_mods ++ hidden_mods
+
+-- -----------------------------------------------------------------------------
+-- Check for conflicts in the program.
+
+-- | A conflict arises if the program contains two modules with the same
+-- name, which can arise if the program depends on multiple packages that
+-- expose the same module, or if the program depends on a package that
+-- contains a module also present in the program (the "home package").
+--
+checkForPackageConflicts
+ :: DynFlags
+ -> [Module] -- modules in the home package
+ -> [PackageId] -- packages on which the program depends
+ -> MaybeErr Message ()
+
+checkForPackageConflicts dflags mods pkgs = do
+ let
+ state = pkgState dflags
+ pkg_db = pkgIdMap state
+ --
+ dep_pkgs <- closeDepsErr pkg_db pkgs
+
+ let
+ extend_modmap pkgname modmap =
+ addListToFM_C (++) modmap
+ [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods]
+ where
+ pkg = expectJust "checkForPackageConflicts"
+ (lookupPackage pkg_db pkgname)
+ exposed_mods = map mkModule (exposedModules pkg)
+ hidden_mods = map mkModule (hiddenModules pkg)
+ all_mods = exposed_mods ++ hidden_mods
+
+ mod_map = foldr extend_modmap emptyFM pkgs
+ mod_map_list :: [(Module,[(PackageConfig,Bool)])]
+ mod_map_list = fmToList mod_map
+
+ overlaps = [ (m, map fst ps) | (m,ps@(_:_:_)) <- mod_map_list ]
+ --
+ if not (null overlaps)
+ then Failed (pkgOverlapError overlaps)
+ else do
+
+ let
+ overlap_mods = [ (mod,pkg)
+ | mod <- mods,
+ Just ((pkg,_):_) <- [lookupFM mod_map mod] ]
+ -- will be only one package here
+ if not (null overlap_mods)
+ then Failed (modOverlapError overlap_mods)
+ else do
+
+ return ()
+
+pkgOverlapError overlaps = vcat (map msg overlaps)
+ where
+ msg (mod,pkgs) =
+ text "conflict: module" <+> quotes (ppr mod)
+ <+> ptext SLIT("is present in multiple packages:")
+ <+> hsep (punctuate comma (map pprPkg pkgs))
+
+modOverlapError overlaps = vcat (map msg overlaps)
+ where
+ msg (mod,pkg) = fsep [
+ text "conflict: module",
+ quotes (ppr mod),
+ ptext SLIT("belongs to the current program/library"),
+ ptext SLIT("and also to package"),
+ pprPkg pkg ]
+
+pprPkg :: PackageConfig -> SDoc
+pprPkg p = text (showPackageId (package p))
+
+-- -----------------------------------------------------------------------------
+-- 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
+ let tag = buildTag dflags
+ rts_tag = rtsBuildTag dflags
+ let
+ imp = if opt_Static then "" else "_dyn"
+ libs p = map ((++imp) . addSuffix) (hsLibraries p)
+ ++ hACK_dyn (extraLibraries p)
+ all_opts p = map ("-l" ++) (libs p) ++ ldOptions 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
+
+ -- This is a hack that's even more horrible (and hopefully more temporary)
+ -- than the one below [referring to previous splittage of HSbase into chunks
+ -- to work around GNU ld bug]. HSbase_cbits and friends require the _dyn suffix
+ -- for dynamic linking, but not _p or other 'way' suffix. So we just add
+ -- _dyn to extraLibraries if they already have a _cbits suffix.
+
+ hACK_dyn = map hack
+ where hack lib | not opt_Static && "_cbits" `isSuffixOf` lib = lib ++ "_dyn"
+ | otherwise = lib
+
+ return (concat (map all_opts ps))
+
+getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
+getPackageExtraCcOpts dflags pkgs = do
+ ps <- getExplicitPackagesAnd dflags pkgs
+ return (concatMap ccOptions ps)
+
+getPackageFrameworkPath :: DynFlags -> [PackageId] -> IO [String]
+getPackageFrameworkPath dflags pkgs = do
+ ps <- getExplicitPackagesAnd dflags pkgs
+ return (nub (filter notNull (concatMap frameworkDirs ps)))
+
+getPackageFrameworks :: DynFlags -> [PackageId] -> IO [String]
+getPackageFrameworks dflags pkgs = do
+ ps <- getExplicitPackagesAnd dflags pkgs
+ return (concatMap frameworks ps)
+
+-- -----------------------------------------------------------------------------
+-- Package Utils
+
+-- | Takes a Module, and if the module is in a package returns
+-- @(pkgconf,exposed)@ where pkgconf is the PackageConfig for that package,
+-- and exposed is True if the package exposes the module.
+lookupModuleInAllPackages :: DynFlags -> Module -> [(PackageConfig,Bool)]
+lookupModuleInAllPackages dflags m =
+ case lookupModuleEnv (moduleToPkgConfAll (pkgState dflags)) m of
+ Nothing -> []
+ Just ps -> ps
+
+getExplicitPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig]
+getExplicitPackagesAnd dflags pkgids =
+ let
+ state = pkgState dflags
+ pkg_map = pkgIdMap state
+ expl = explicitPackages state
+ in do
+ all_pkgs <- throwErr (foldM (add_package pkg_map) expl pkgids)
+ return (map (getPackageDetails 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).
+closeDeps :: PackageConfigMap -> [PackageId] -> IO [PackageId]
+closeDeps pkg_map ps = throwErr (closeDepsErr pkg_map ps)
+
+throwErr :: MaybeErr Message a -> IO a
+throwErr m = case m of
+ Failed e -> throwDyn (CmdLineError (showSDoc e))
+ Succeeded r -> return r
+
+closeDepsErr :: PackageConfigMap -> [PackageId]
+ -> MaybeErr Message [PackageId]
+closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
+
+-- internal helper
+add_package :: PackageConfigMap -> [PackageId] -> PackageId
+ -> MaybeErr Message [PackageId]
+add_package pkg_db ps p
+ | p `elem` ps = return ps -- Check if we've already added this package
+ | otherwise =
+ case lookupPackage pkg_db p of
+ Nothing -> Failed (missingPackageMsg (packageIdString p))
+ Just pkg -> do
+ -- Add the package's dependents also
+ let deps = map mkPackageId (depends pkg)
+ ps' <- foldM (add_package pkg_db) ps deps
+ return (p : ps')
+
+missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p)))
+missingPackageMsg p = ptext SLIT("unknown package:") <+> text p
+
+-- -----------------------------------------------------------------------------
+-- The home module set
+
+newtype HomeModules = HomeModules ModuleSet
+
+mkHomeModules :: [Module] -> HomeModules
+mkHomeModules = HomeModules . mkModuleSet
+
+isHomeModule :: HomeModules -> Module -> Bool
+isHomeModule (HomeModules set) mod = elemModuleSet mod set
+
+-- Determining whether a Name refers to something in another package or not.
+-- Cross-package references need to be handled differently when dynamically-
+-- linked libraries are involved.
+
+isDllName :: HomeModules -> Name -> Bool
+isDllName pdeps name
+ | opt_Static = False
+ | Just mod <- nameModule_maybe name = not (isHomeModule pdeps mod)
+ | otherwise = False -- no, it is not even an external name
+
+-- -----------------------------------------------------------------------------
+-- Displaying packages
+
+dumpPackages :: DynFlags -> IO ()
+-- Show package info on console, if verbosity is >= 3
+dumpPackages dflags
+ = do let pkg_map = pkgIdMap (pkgState dflags)
+ putMsg dflags $
+ vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map))