X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FPackages.lhs;h=d1feff77f7eacc586079db2d89c37b0f3ac87d59;hp=80ab2446dc3f26dd380b2e0c5adfd588ece54b10;hb=1a3efdd6b616f3a101e182f715df5a0e306eb348;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 80ab244..d1feff7 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -4,11 +4,11 @@ % Package manipulation % \begin{code} -{-# OPTIONS_GHC -w #-} +{-# OPTIONS -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details module Packages ( @@ -54,10 +54,6 @@ import Maybes ( expectJust, MaybeErr(..) ) import Panic import Outputable -#if __GLASGOW_HASKELL__ < 603 -import Compat.Directory ( getAppUserDataDirectory ) -#endif - import System.Environment ( getEnv ) import Distribution.InstalledPackageInfo import Distribution.Package @@ -66,6 +62,7 @@ import FastString import ErrUtils ( debugTraceMsg, putMsg, Message ) import System.Directory +import System.FilePath import Data.Maybe import Control.Monad import Data.List @@ -210,14 +207,14 @@ getSystemPackageConfigs dflags = do -- to maintain the package database on systems with a package -- management system, or systems that don't want to run ghc-pkg -- to register or unregister packages. Undocumented feature for now. - let system_pkgconf_dir = system_pkgconf ++ ".d" + let system_pkgconf_dir = system_pkgconf <.> "d" system_pkgconf_dir_exists <- doesDirectoryExist system_pkgconf_dir system_pkgconfs <- if system_pkgconf_dir_exists then do files <- getDirectoryContents system_pkgconf_dir - return [ system_pkgconf_dir ++ '/' : file + return [ system_pkgconf_dir file | file <- files - , isSuffixOf ".conf" file] + , takeExtension file == ".conf" ] else return [] -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) @@ -228,8 +225,8 @@ getSystemPackageConfigs dflags = do appdir <- getAppUserDataDirectory "ghc" let pkgconf = appdir - `joinFileName` (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) - `joinFileName` "package.conf" + (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) + "package.conf" flg <- doesFileExist pkgconf if (flg && dopt Opt_ReadUserPackageConf dflags) then return [pkgconf] @@ -268,9 +265,12 @@ mungePackagePaths top_dir ps = map munge_pkg ps munge_paths = map munge_path munge_path p - | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p' + | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p' + | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p' | otherwise = p + toHttpPath p = "file:///" ++ p + -- ----------------------------------------------------------------------------- -- Modify our copy of the package database based on a package flag @@ -449,10 +449,13 @@ findWiredInPackages dflags pkgs preload this_package = do return (pkgs2, preload1, new_this_pkg) --- ----------------------------------------------------------------------------- +-- ---------------------------------------------------------------------------- -- --- Eliminate any packages which have dangling dependencies ( --- because the dependency was removed by -ignore-package). +-- 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 @@ -460,23 +463,29 @@ elimDanglingDeps -> [PackageId] -- ignored packages -> IO [PackageConfig] -elimDanglingDeps dflags pkgs ignored = - case partition (not.null.snd) (map (getDanglingDeps pkgs ignored) pkgs) of - ([],ps) -> return (map fst ps) - (ps,qs) -> do - mapM_ reportElim ps - elimDanglingDeps dflags (map fst qs) - (ignored ++ map packageConfigId (map fst ps)) +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 dependencies:") $$ + ptext SLIT("will be ignored due to missing or recursive dependencies:") $$ nest 2 (hsep (map (text.showPackageId) deps))) - getDanglingDeps pkgs ignored p = (p, filter dangling (depends p)) - where dangling pid = mkPackageId pid `elem` ignored - -- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our package -- settings and populate the package state. @@ -527,7 +536,11 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do -- add base & rts to the preload packages basicLinkedPackages = filter (flip elemUFM pkg_db) [basePackageId,rtsPackageId] - preload2 = nub (basicLinkedPackages ++ map mkPackageId preload1) + -- but in any case remove the current package from the set of + -- preloaded packages so that base/rts does not end up in the + -- set up preloaded package when we are just building it + preload2 = nub (filter (/= new_this_pkg) + (basicLinkedPackages ++ map mkPackageId preload1)) -- Close the preload packages with their dependencies dep_preload <- closeDeps pkg_db (zip preload2 (repeat Nothing)) @@ -553,12 +566,12 @@ mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids extend_modmap pkgid modmap = addListToUFM_C (++) modmap - [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods] + ([(m, [(pkg, True)]) | m <- exposed_mods] ++ + [(m, [(pkg, False)]) | m <- hidden_mods]) where pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) - exposed_mods = map mkModuleName (exposedModules pkg) - hidden_mods = map mkModuleName (hiddenModules pkg) - all_mods = exposed_mods ++ hidden_mods + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg pprPkg :: PackageConfig -> SDoc pprPkg p = text (showPackageId (package p)) @@ -700,5 +713,10 @@ dumpPackages :: DynFlags -> IO () dumpPackages dflags = do let pkg_map = pkgIdMap (pkgState dflags) putMsg dflags $ - vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map)) + vcat (map (text.showInstalledPackageInfo.to_ipi) (eltsUFM pkg_map)) + where + to_ipi pkgconf@InstalledPackageInfo_{ exposedModules = e, + hiddenModules = h } = + pkgconf{ exposedModules = map moduleNameString e, + hiddenModules = map moduleNameString h } \end{code}