update the comments about how we find $topdir
[ghc-hetmet.git] / compiler / main / Packages.lhs
index c8b7d69..b6c320f 100644 (file)
@@ -26,6 +26,8 @@ module Packages (
        getPackageFrameworks,
        getPreloadPackagesAnd,
 
+        collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
+
        -- * Utils
        isDllName
     )
@@ -49,6 +51,7 @@ import Outputable
 import System.Environment ( getEnv )
 import Distribution.InstalledPackageInfo hiding (depends)
 import Distribution.Package hiding (depends)
+import Distribution.Text
 import Distribution.Version
 import FastString
 import ErrUtils         ( debugTraceMsg, putMsg, Message )
@@ -135,7 +138,7 @@ extendPackageConfigMap pkg_map new_pkgs
   where add pkg_map p = addToUFM pkg_map (packageConfigId p) p
 
 getPackageDetails :: PackageState -> PackageId -> PackageConfig
-getPackageDetails dflags ps = expectJust "getPackageDetails" (lookupPackage (pkgIdMap dflags) ps)
+getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid)
 
 -- ----------------------------------------------------------------------------
 -- Loading the package config files and building up the package state
@@ -318,7 +321,7 @@ matchingPackages str pkgs
        -- version, or just the name if it is unambiguous.
        matches str p
                =  str == display (package p)
-               || str == pkgName (package p)
+               || str == display (pkgName (package p))
 
 pickPackages :: [PackageConfig] -> [String] -> [PackageConfig]
 pickPackages pkgs strs = 
@@ -376,15 +379,21 @@ findWiredInPackages dflags pkgs preload this_package = do
   -- their canonical names (eg. base-1.0 ==> base).
   --
   let
-        wired_in_pkgids = [ primPackageId,
-                            integerPackageId,
-                            basePackageId,
-                            rtsPackageId,
-                            haskell98PackageId,
-                            thPackageId,
-                            ndpPackageId ]
-
-       wired_in_names = map packageIdString wired_in_pkgids
+        wired_in_pkgids :: [(PackageId, [String])]
+        wired_in_pkgids = [ (primPackageId, [""]),
+                            (integerPackageId, [""]),
+                            (basePackageId, [""]),
+                            (rtsPackageId, [""]),
+                            (haskell98PackageId, [""]),
+                            (thPackageId, [""]),
+                            (dphSeqPackageId, [""]),
+                            (dphParPackageId, [""]),
+                            (ndpPackageId, ["-seq", "-par"]) ]
+
+        matches :: PackageConfig -> (PackageId, [String]) -> Bool
+        pc `matches` (pid, suffixes)
+            = display (pkgName (package pc)) `elem`
+              (map (packageIdString pid ++) suffixes)
 
        -- find which package corresponds to each wired-in package
        -- delete any other packages with the same name
@@ -396,46 +405,53 @@ findWiredInPackages dflags pkgs preload this_package = do
         -- version.  To override the default choice, -hide-package
         -- could be used to hide newer versions.
         --
-       findWiredInPackage :: [PackageConfig] -> String
-                          -> IO (Maybe PackageIdentifier)
+       findWiredInPackage :: [PackageConfig] -> (PackageId, [String])
+                          -> IO (Maybe (PackageIdentifier, PackageId))
        findWiredInPackage pkgs wired_pkg =
-           let all_ps = [ p | p <- pkgs, pkgName (package p) == wired_pkg ] in
+           let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
           case filter exposed all_ps of
                [] -> case all_ps of
                         []   -> notfound
                         many -> pick (head (sortByVersion many))
                many  -> pick (head (sortByVersion many))
           where
+                suffixes = snd wired_pkg
                 notfound = do
                          debugTraceMsg dflags 2 $
                            ptext (sLit "wired-in package ")
-                                <> text wired_pkg
+                                <> ppr (fst wired_pkg)
+                                 <> (if null suffixes
+                                     then empty
+                                     else text (show suffixes))
                                 <> ptext (sLit " not found.")
                          return Nothing
+               pick :: InstalledPackageInfo_ ModuleName
+                     -> IO (Maybe (PackageIdentifier, PackageId))
                 pick pkg = do
                         debugTraceMsg dflags 2 $
                            ptext (sLit "wired-in package ")
-                                <> text wired_pkg
+                                <> ppr (fst wired_pkg)
                                 <> ptext (sLit " mapped to ")
                                 <> text (display (package pkg))
-                       return (Just (package pkg))
+                       return (Just (package pkg, fst wired_pkg))
 
 
-  mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_names
+  mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids
   let 
         wired_in_ids = catMaybes mb_wired_in_ids
 
-       deleteOtherWiredInPackages pkgs = filter ok pkgs
-         where ok p = pkgName (package p) `notElem` wired_in_names
-                     || package p `elem` wired_in_ids
+       deleteOtherWiredInPackages pkgs = filterOut bad pkgs
+         where bad p = any (p `matches`) wired_in_pkgids
+                     && package p `notElem` map fst wired_in_ids
 
        updateWiredInDependencies pkgs = map upd_pkg pkgs
          where upd_pkg p = p{ package = upd_pid (package p),
                               depends = map upd_pid (depends p) }
 
-       upd_pid pid = case filter (== pid) wired_in_ids of
+       upd_pid pid = case filter ((== pid) . fst) wired_in_ids of
                                [] -> pid
-                               (x:_) -> x{ pkgVersion = Version [] [] }
+                               ((x, y):_) -> x{ pkgName = PackageName (packageIdString y),
+                                                 pkgVersion = Version [] [] }
 
         pkgs1 = deleteOtherWiredInPackages pkgs
 
@@ -534,8 +550,10 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do
   let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs
 
       -- add base & rts to the preload packages
-      basicLinkedPackages = filter (flip elemUFM pkg_db)
-                                [basePackageId,rtsPackageId]
+      basicLinkedPackages
+       | dopt Opt_AutoLinkPackages dflags
+          = filter (flip elemUFM pkg_db) [basePackageId, rtsPackageId]
+       | otherwise = []
       -- 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
@@ -588,21 +606,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)
@@ -615,8 +641,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
@@ -712,10 +736,7 @@ dumpPackages :: DynFlags -> IO ()
 dumpPackages dflags
   = do  let pkg_map = pkgIdMap (pkgState dflags)
        putMsg dflags $
-             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 }
+              vcat (map (text . showInstalledPackageInfo
+                              . packageConfigToInstalledPackageInfo)
+                        (eltsUFM pkg_map))
 \end{code}