refactoring only: use the parameterised InstalledPackageInfo

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

diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index bbaf846..1402db1 100644 (file)
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -4,6 +4,13 @@
 % 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,
 
@@ -42,15 +49,12 @@ import Config               ( cProjectVersion )
 import Name            ( Name, nameModule_maybe )
 import UniqFM
 import Module
-import UniqSet
 import Util
 import Maybes          ( expectJust, MaybeErr(..) )
 import Panic
 import Outputable
 
-#if __GLASGOW_HASKELL__ >= 603
-import System.Directory        ( getAppUserDataDirectory )
-#else
+#if __GLASGOW_HASKELL__ < 603
 import Compat.Directory        ( getAppUserDataDirectory )
 #endif
 
@@ -58,15 +62,15 @@ import System.Environment ( getEnv )
 import Distribution.InstalledPackageInfo
 import Distribution.Package
 import Distribution.Version
-import System.Directory        ( doesFileExist, doesDirectoryExist,
-                         getDirectoryContents )
-import Data.Maybe      ( catMaybes )
-import Control.Monad   ( foldM )
-import Data.List       ( nub, partition, sortBy, isSuffixOf )
 import FastString
-import EXCEPTION       ( throwDyn )
 import ErrUtils         ( debugTraceMsg, putMsg, Message )
 
+import System.Directory
+import Data.Maybe
+import Control.Monad
+import Data.List
+import Control.Exception        ( throwDyn )
+
 -- ---------------------------------------------------------------------------
 -- The Package state
 
@@ -110,9 +114,6 @@ import ErrUtils         ( debugTraceMsg, putMsg, Message )
 -- in a different DLL, by setting the DLL flag.
 
 data PackageState = PackageState {
-  origPkgIdMap         :: PackageConfigMap, -- PackageId   -> PackageConfig
-        -- The on-disk package database
-
   pkgIdMap             :: PackageConfigMap, -- PackageId   -> PackageConfig
        -- The exposed flags are adjusted according to -package and
        -- -hide-package flags, and -ignore-package removes packages.
@@ -170,7 +171,8 @@ initPackages dflags = do
                 Just db -> return db
   (pkg_state, preload, this_pkg)       
         <- mkPackageState dflags pkg_db [] (thisPackage dflags)
-  return (dflags{ pkgState = pkg_state,
+  return (dflags{ pkgDatabase = Just pkg_db,
+                 pkgState = pkg_state,
                   thisPackage = this_pkg },
           preload)
 
@@ -378,7 +380,8 @@ findWiredInPackages dflags pkgs preload this_package = do
        wired_in_pkgids = [ basePackageId,
                            rtsPackageId,
                            haskell98PackageId,
-                           thPackageId ]
+                           thPackageId,
+                            ndpPackageId ]
 
        wired_in_names = map packageIdString wired_in_pkgids
 
@@ -524,14 +527,17 @@ 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))
   let new_dep_preload = filter (`notElem` preload0) dep_preload
 
   let pstate = PackageState{ preloadPackages     = dep_preload,
-                             origPkgIdMap        = orig_pkg_db,
                             pkgIdMap            = pkg_db,
                             moduleToPkgConfAll  = mkModuleMap pkg_db
                           }
@@ -551,12 +557,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))
@@ -593,26 +599,17 @@ getPackageLinkOpts dflags pkgs = do
   let tag = buildTag dflags
       rts_tag = rtsBuildTag dflags
   let 
-       imp        = if opt_Static then "" else "_dyn"
-       libs p     = map ((++imp) . addSuffix) (hsLibraries p)
-                        ++ hACK_dyn (extraLibraries p)
+       mkDynName | opt_Static = id
+                 | otherwise = (++ ("-ghc" ++ cProjectVersion))
+       libs p     = map (mkDynName . addSuffix) (hsLibraries p)
+                        ++ extraLibraries p
        all_opts p = map ("-l" ++) (libs p) ++ ldOptions p
 
-       suffix     = if null tag then "" else  '_':tag
-       rts_suffix = if null rts_tag then "" else  '_':rts_tag
+        addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)
+        addSuffix other_lib      = other_lib ++ (expandTag tag)
 
-        addSuffix rts@"HSrts"    = rts       ++ rts_suffix
-        addSuffix other_lib      = other_lib ++ suffix
-
-        -- This is a hack that's even more horrible (and hopefully more temporary)
-        -- than the one below [referring to previous splittage of HSbase into chunks
-       -- to work around GNU ld bug]. HSbase_cbits and friends require the _dyn suffix
-        -- for dynamic linking, but not _p or other 'way' suffix. So we just add
-        -- _dyn to extraLibraries if they already have a _cbits suffix.
-        
-        hACK_dyn = map hack
-          where hack lib | not opt_Static && "_cbits" `isSuffixOf` lib = lib ++ "_dyn"
-                         | otherwise = lib
+        expandTag t | null t = ""
+                   | otherwise = '_':t
 
   return (concat (map all_opts ps))
 
@@ -707,5 +704,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}