X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FPackages.lhs;h=6a5b63cedb6affe17fa4d6e07c6bcba78a84416d;hb=08652e67c4d5d9a40687f93c286021a867c1bca0;hp=d1feff77f7eacc586079db2d89c37b0f3ac87d59;hpb=1a3efdd6b616f3a101e182f715df5a0e306eb348;p=ghc-hetmet.git diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index d1feff7..6a5b63c 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, @@ -26,7 +19,6 @@ module Packages ( -- * Inspecting the set of packages in scope getPackageIncludePath, - getPackageCIncludes, getPackageLibraryPath, getPackageLinkOpts, getPackageExtraCcOpts, @@ -55,8 +47,8 @@ import Panic import Outputable import System.Environment ( getEnv ) -import Distribution.InstalledPackageInfo -import Distribution.Package +import Distribution.InstalledPackageInfo hiding (depends) +import Distribution.Package hiding (depends) import Distribution.Version import FastString import ErrUtils ( debugTraceMsg, putMsg, Message ) @@ -260,7 +252,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 @@ -286,6 +281,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) @@ -299,7 +295,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. @@ -321,14 +317,17 @@ matchingPackages str pkgs -- 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 == display (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 -- ----------------------------------------------------------------------------- @@ -346,10 +345,10 @@ hideOldPackages dflags pkgs = mapM maybe_hide pkgs | not (exposed p) = return p | (p' : _) <- later_versions = do debugTraceMsg dflags 2 $ - (ptext SLIT("hiding package") <+> - text (showPackageId (package p)) <+> - ptext SLIT("to avoid conflict with later version") <+> - text (showPackageId (package p'))) + (ptext (sLit "hiding package") <+> + text (display (package p)) <+> + ptext (sLit "to avoid conflict with later version") <+> + text (display (package p'))) return (p {exposed=False}) | otherwise = return p where myname = pkgName (package p) @@ -377,10 +376,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 @@ -407,16 +408,16 @@ findWiredInPackages dflags pkgs preload this_package = do where notfound = do debugTraceMsg dflags 2 $ - ptext SLIT("wired-in package ") + ptext (sLit "wired-in package ") <> text wired_pkg - <> ptext SLIT(" not found.") + <> ptext (sLit " not found.") return Nothing pick pkg = do debugTraceMsg dflags 2 $ - ptext SLIT("wired-in package ") + ptext (sLit "wired-in package ") <> text wired_pkg - <> ptext SLIT(" mapped to ") - <> text (showPackageId (package pkg)) + <> ptext (sLit " mapped to ") + <> text (display (package pkg)) return (Just (package pkg)) @@ -482,9 +483,9 @@ elimDanglingDeps dflags pkgs ignored = go [] pkgs' reportElim (p, deps) = debugTraceMsg dflags 2 $ - (ptext SLIT("package") <+> pprPkg p <+> - ptext SLIT("will be ignored due to missing or recursive dependencies:") $$ - nest 2 (hsep (map (text.showPackageId) deps))) + (ptext (sLit "package") <+> pprPkg p <+> + ptext (sLit "will be ignored due to missing or recursive dependencies:") $$ + nest 2 (hsep (map (text.display) deps))) -- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our package @@ -531,7 +532,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) @@ -574,7 +574,7 @@ mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids hidden_mods = hiddenModules pkg pprPkg :: PackageConfig -> SDoc -pprPkg p = text (showPackageId (package p)) +pprPkg p = text (display (package p)) -- ----------------------------------------------------------------------------- -- Extracting information from the packages in scope @@ -592,11 +592,6 @@ getPackageIncludePath dflags pkgs = do ps <- getPreloadPackagesAnd 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 <- getPreloadPackagesAnd dflags pkgs @@ -690,12 +685,16 @@ 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 p = ptext SLIT("unknown package:") <+> text p +missingPackageMsg :: String -> SDoc +missingPackageMsg p = ptext (sLit "unknown package:") <+> text p + +missingDependencyMsg :: Maybe PackageId -> SDoc missingDependencyMsg Nothing = empty missingDependencyMsg (Just parent) - = space <> parens (ptext SLIT("dependency of") <+> ftext (packageIdFS parent)) + = space <> parens (ptext (sLit "dependency of") <+> ftext (packageIdFS parent)) -- ----------------------------------------------------------------------------- @@ -715,8 +714,8 @@ dumpPackages dflags putMsg dflags $ vcat (map (text.showInstalledPackageInfo.to_ipi) (eltsUFM pkg_map)) where - to_ipi pkgconf@InstalledPackageInfo_{ exposedModules = e, - hiddenModules = h } = + to_ipi pkgconf@(InstalledPackageInfo { exposedModules = e, + hiddenModules = h }) = pkgconf{ exposedModules = map moduleNameString e, hiddenModules = map moduleNameString h } \end{code}