X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FPackages.lhs;h=d10d873ed47893f6d5db7b203db28d5b5d98cc1c;hb=f5fbb8242af1b85b763d5be84364e9453e90d7c5;hp=d5cfbd10986ef08622eb346ecd4810a6c3f2ae68;hpb=7eb5e29b4a7b6fef55512bc7bf3308e712ca3eba;p=ghc-hetmet.git diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index d5cfbd1..d10d873 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -4,13 +4,6 @@ % Package manipulation % \begin{code} -{-# 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/Commentary/CodingStyle#Warnings --- for details - module Packages ( module PackageConfig, @@ -53,10 +46,7 @@ import Util import Maybes ( expectJust, MaybeErr(..) ) import Panic import Outputable - -#if __GLASGOW_HASKELL__ < 603 -import Compat.Directory ( getAppUserDataDirectory ) -#endif +import Pretty ( Doc ) import System.Environment ( getEnv ) import Distribution.InstalledPackageInfo @@ -264,7 +254,10 @@ mungePackagePaths top_dir ps = map munge_pkg ps munge_pkg p = p{ importDirs = munge_paths (importDirs p), includeDirs = munge_paths (includeDirs p), libraryDirs = munge_paths (libraryDirs p), - frameworkDirs = munge_paths (frameworkDirs p) } + frameworkDirs = munge_paths (frameworkDirs p), + haddockInterfaces = munge_paths (haddockInterfaces p), + haddockHTMLs = munge_paths (haddockHTMLs p) + } munge_paths = map munge_path @@ -290,6 +283,7 @@ applyPackageFlag pkgs flag = ExposePackage str -> case matchingPackages str pkgs of Nothing -> missingPackageErr str + Just ([], _) -> panic "applyPackageFlag" Just (p:ps,qs) -> return (p':ps') where p' = p {exposed=True} ps' = hideAll (pkgName (package p)) (ps++qs) @@ -303,7 +297,7 @@ applyPackageFlag pkgs flag = IgnorePackage str -> case matchingPackages str pkgs of Nothing -> return pkgs - Just (ps,qs) -> return qs + Just (_, qs) -> return qs -- 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. @@ -328,11 +322,14 @@ matchingPackages str pkgs = str == showPackageId (package p) || str == pkgName (package p) - +pickPackages :: [PackageConfig] -> [String] -> [PackageConfig] pickPackages pkgs strs = - [ p | p <- strs, Just (p:ps,_) <- [matchingPackages p pkgs] ] + [ p | p <- strs, Just (p:_, _) <- [matchingPackages p pkgs] ] +sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m] sortByVersion = sortBy (flip (comparing (pkgVersion.package))) + +comparing :: Ord a => (t -> a) -> t -> t -> Ordering comparing f a b = f a `compare` f b -- ----------------------------------------------------------------------------- @@ -381,10 +378,12 @@ findWiredInPackages dflags pkgs preload this_package = do -- their canonical names (eg. base-1.0 ==> base). -- let - wired_in_pkgids = [ basePackageId, - rtsPackageId, - haskell98PackageId, - thPackageId, + wired_in_pkgids = [ primPackageId, + integerPackageId, + basePackageId, + rtsPackageId, + haskell98PackageId, + thPackageId, ndpPackageId ] wired_in_names = map packageIdString wired_in_pkgids @@ -453,10 +452,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 @@ -464,23 +466,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. @@ -526,7 +534,6 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do pkgs <- elimDanglingDeps dflags pkgs3 ignored let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs - pkgids = map packageConfigId pkgs -- add base & rts to the preload packages basicLinkedPackages = filter (flip elemUFM pkg_db) @@ -685,9 +692,13 @@ add_package pkg_db ps (p, mb_parent) ps' <- foldM (add_package pkg_db) ps (zip deps (repeat (Just p))) return (p : ps') +missingPackageErr :: String -> IO [PackageConfig] missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p))) + +missingPackageMsg :: String -> PprStyle -> Doc missingPackageMsg p = ptext SLIT("unknown package:") <+> text p +missingDependencyMsg :: Maybe PackageId -> PprStyle -> Doc missingDependencyMsg Nothing = empty missingDependencyMsg (Just parent) = space <> parens (ptext SLIT("dependency of") <+> ftext (packageIdFS parent))