X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FPackages.lhs;h=44ad7d15b252539bab967a02bf37baa8b6b0e386;hb=6084fb5517da34f65034370a3695e2af3b85ce2b;hp=c98992ac24ff0b8e5051685f125e258f30cd4c0c;hpb=249bcf1f34e240a39abbcbb29bd6b97ddece421f;p=ghc-hetmet.git

diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index c98992a..44ad7d1 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -26,6 +26,8 @@ module Packages (
 	getPackageFrameworks,
 	getPreloadPackagesAnd,
 
+        collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
+
 	-- * Utils
 	isDllName
     )
@@ -53,13 +55,13 @@ import Distribution.Text
 import Distribution.Version
 import FastString
 import ErrUtils         ( debugTraceMsg, putMsg, Message )
+import Exception
 
 import System.Directory
 import System.FilePath
 import Data.Maybe
 import Control.Monad
 import Data.List
-import Control.Exception        ( throwDyn )
 
 -- ---------------------------------------------------------------------------
 -- The Package state
@@ -171,7 +173,7 @@ initPackages dflags = do
 
 readPackageConfigs :: DynFlags -> IO PackageConfigMap
 readPackageConfigs dflags = do
-   e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
+   e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH")
    system_pkgconfs <- getSystemPackageConfigs dflags
 
    let pkgconfs = case e_pkg_path of
@@ -214,7 +216,7 @@ getSystemPackageConfigs dflags = do
 	-- unless the -no-user-package-conf flag was given.
 	-- We only do this when getAppUserDataDirectory is available 
 	-- (GHC >= 6.3).
-   user_pkgconf <- handle (\_ -> return []) $ do
+   user_pkgconf <- do
       appdir <- getAppUserDataDirectory "ghc"
       let 
      	 pkgconf = appdir
@@ -224,6 +226,7 @@ getSystemPackageConfigs dflags = do
       if (flg && dopt Opt_ReadUserPackageConf dflags)
 	then return [pkgconf]
 	else return []
+    `catchIO` (\_ -> return [])
 
    return (user_pkgconf ++ system_pkgconfs ++ [system_pkgconf])
 
@@ -604,21 +607,29 @@ pprPkg p = text (display (package p))
 -- use.
 
 getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String]
-getPackageIncludePath dflags pkgs = do
-  ps <- getPreloadPackagesAnd dflags pkgs
-  return (nub (filter notNull (concatMap includeDirs ps)))
+getPackageIncludePath dflags pkgs =
+  collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
+
+collectIncludeDirs :: [PackageConfig] -> [FilePath] 
+collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
 
 getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String]
-getPackageLibraryPath dflags pkgs = do 
-  ps <- getPreloadPackagesAnd dflags pkgs
-  return (nub (filter notNull (concatMap libraryDirs ps)))
+getPackageLibraryPath dflags pkgs =
+  collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
+
+collectLibraryPaths :: [PackageConfig] -> [FilePath]
+collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
 
 getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String]
-getPackageLinkOpts dflags pkgs = do
-  ps <- getPreloadPackagesAnd dflags pkgs
-  let tag = buildTag dflags
-      rts_tag = rtsBuildTag dflags
-  let 
+getPackageLinkOpts dflags pkgs = 
+  collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
+
+collectLinkOpts :: DynFlags -> [PackageConfig] -> [String]
+collectLinkOpts dflags ps = concat (map all_opts ps)
+  where
+        tag = buildTag dflags
+        rts_tag = rtsBuildTag dflags
+
 	mkDynName | opt_Static = id
 		  | otherwise = (++ ("-ghc" ++ cProjectVersion))
       	libs p     = map (mkDynName . addSuffix) (hsLibraries p)
@@ -631,8 +642,6 @@ getPackageLinkOpts dflags pkgs = do
         expandTag t | null t = ""
 		    | otherwise = '_':t
 
-  return (concat (map all_opts ps))
-
 getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
 getPackageExtraCcOpts dflags pkgs = do
   ps <- getPreloadPackagesAnd dflags pkgs
@@ -679,7 +688,7 @@ 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))
+		Failed e    -> ghcError (CmdLineError (showSDoc e))
 		Succeeded r -> return r
 
 closeDepsErr :: PackageConfigMap -> [(PackageId,Maybe PackageId)]
@@ -702,7 +711,7 @@ add_package pkg_db ps (p, mb_parent)
     	   return (p : ps')
 
 missingPackageErr :: String -> IO [PackageConfig]
-missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p)))
+missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p)))
 
 missingPackageMsg :: String -> SDoc
 missingPackageMsg p = ptext (sLit "unknown package:") <+> text p