[project @ 2005-04-13 13:17:35 by simonmar]

[ghc-hetmet.git] / ghc / compiler / main / Packages.lhs

diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs
index 06180a1..65f8523 100644 (file)
--- a/ghc/compiler/main/Packages.lhs
+++ b/ghc/compiler/main/Packages.lhs
@@ -47,6 +47,7 @@ import Module         ( Module, mkModule )
 import UniqFM
 import UniqSet
 import Util
+import Maybes          ( expectJust )
 import Panic
 import Outputable
 
@@ -59,8 +60,7 @@ import Compat.Directory       ( getAppUserDataDirectory )
 import Distribution.InstalledPackageInfo
 import Distribution.Package
 import Distribution.Version
-import System.IO       ( hPutStrLn, stderr )
-import Data.Maybe      ( fromJust, isNothing )
+import Data.Maybe      ( isNothing )
 import System.Directory        ( doesFileExist )
 import Control.Monad   ( when, foldM )
 import Data.List       ( nub, partition )
@@ -72,6 +72,7 @@ import Data.List      ( isPrefixOf )
 import FastString
 import DATA_IOREF
 import EXCEPTION       ( throwDyn )
+import ErrUtils         ( debugTraceMsg, putMsg )
 
 -- ---------------------------------------------------------------------------
 -- The Package state
@@ -177,11 +178,15 @@ extendPackageConfigMap pkg_map new_pkgs
   where add pkg_map p = addToUFM pkg_map (packageConfigId p) p
 
 getPackageDetails :: PackageState -> PackageId -> PackageConfig
-getPackageDetails dflags ps = fromJust (lookupPackage (pkgIdMap dflags) ps)
+getPackageDetails dflags ps = expectJust "getPackageDetails" (lookupPackage (pkgIdMap dflags) ps)
 
 -- ----------------------------------------------------------------------------
 -- Loading the package config files and building up the package state
 
+-- | Call this after parsing the DynFlags.  It reads the package
+-- configuration files, and sets up various internal tables of package
+-- information, according to the package-related flags on the
+-- command-line (@-package@, @-hide-package@ etc.)
 initPackages :: DynFlags -> IO DynFlags
 initPackages dflags = do 
   pkg_map <- readPackageConfigs dflags; 
@@ -224,14 +229,19 @@ readPackageConfigs dflags = do
 readPackageConfig
    :: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap
 readPackageConfig dflags pkg_map conf_file = do
-  when (verbosity dflags >= 2) $
-       hPutStrLn stderr ("Using package config file: "
-                        ++ conf_file)
+  debugTraceMsg dflags 2 ("Using package config file: " ++ conf_file)
   proto_pkg_configs <- loadPackageConfig conf_file
   top_dir          <- getTopDir
-  let pkg_configs = mungePackagePaths top_dir proto_pkg_configs
-  return (extendPackageConfigMap pkg_map pkg_configs)
-
+  let pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs
+      pkg_configs2 = maybeHidePackages dflags pkg_configs1
+  return (extendPackageConfigMap pkg_map pkg_configs2)
+
+maybeHidePackages :: DynFlags -> [PackageConfig] -> [PackageConfig]
+maybeHidePackages dflags pkgs
+  | dopt Opt_HideAllPackages dflags = map hide pkgs
+  | otherwise                      = pkgs
+  where
+    hide pkg = pkg{ exposed = False }
 
 mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
 -- Replace the string "$topdir" at the beginning of a path
@@ -258,7 +268,7 @@ mkPackageState :: DynFlags -> PackageConfigMap -> IO PackageState
 mkPackageState dflags pkg_db = do
   --
   -- Modify the package database according to the command-line flags
-  -- (-package, -hide-package, -ignore-package).
+  -- (-package, -hide-package, -ignore-package, -hide-all-packages).
   --
   -- Also, here we build up a set of the packages mentioned in -package
   -- flags on the command line; these are called the "explicit" packages.
@@ -354,7 +364,7 @@ mkPackageState dflags pkg_db = do
   let
        extend_modmap modmap pkgname = do
          let 
-               pkg = fromJust (lookupPackage pkg_db pkgname)
+               pkg = expectJust "mkPackageState" (lookupPackage pkg_db pkgname)
                exposed_mods = map mkModule (exposedModules pkg)
                hidden_mods  = map mkModule (hiddenModules pkg)
                all_mods = exposed_mods ++ hidden_mods
@@ -367,7 +377,6 @@ mkPackageState dflags pkg_db = do
          --
          when (not (null overlaps)) $ overlappingError pkg overlaps
          --
-         let
          return (addListToUFM modmap 
                    [(m, (pkg, m `elem` exposed_mods)) 
                    | m <- all_mods])
@@ -466,6 +475,9 @@ getPackageLinkOpts dflags pkgs = do
      -- THIS IS A STRICTLY TEMPORARY HACK (famous last words ...)
      -- JRS 04 Sept 01: Same appalling hack for HSwin32[1,2]
      -- KAA 29 Mar  02: Same appalling hack for HSobjectio[1,2,3,4]
+     --
+     -- [sof 03/05: Renamed the (moribund) HSwin32 to HSwin_32 so as to
+     --  avoid filename conflicts with the 'Win32' package on a case-insensitive filesystem]
      hACK libs
 #      if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS)
        = libs
@@ -473,8 +485,8 @@ getPackageLinkOpts dflags pkgs = do
        = if   "HSbase1" `elem` libs && "HSbase2" `elem` libs && "HSbase3" `elem` libs
          then "HSbase" : filter (not.(isPrefixOf "HSbase")) libs
          else
-         if   "HSwin321" `elem` libs && "HSwin322" `elem` libs
-         then "HSwin32" : filter (not.(isPrefixOf "HSwin32")) libs
+         if   "HSwin_321" `elem` libs && "HSwin_322" `elem` libs
+         then "HSwin_32" : filter (not.(isPrefixOf "HSwin_32")) libs
          else 
          if   "HSobjectio1" `elem` libs && "HSobjectio2" `elem` libs && "HSobjectio3" `elem` libs && "HSobjectio4" `elem` libs
         then "HSobjectio" : filter (not.(isPrefixOf "HSobjectio")) libs
@@ -563,6 +575,6 @@ dumpPackages :: DynFlags -> IO ()
 -- Show package info on console, if verbosity is >= 3
 dumpPackages dflags
   = do  let pkg_map = pkgIdMap (pkgState dflags)
-       hPutStrLn stderr $ showSDoc $
+       putMsg $ showSDoc $
              vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map))
 \end{code}