X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FPackages.lhs;h=43cd04d983f70bf32cfde0aac14535d3faef61a0;hb=72a42bd77936ad0edd7426a33b323e60323e9684;hp=43b96ec1001e399fec09111f04081d03bb0a5cff;hpb=643a2f7089ce22012df23c161702f9e6b6da6792;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs
index 43b96ec..43cd04d 100644
--- a/ghc/compiler/main/Packages.lhs
+++ b/ghc/compiler/main/Packages.lhs
@@ -4,68 +4,119 @@
 \section{Package manipulation}
 
 \begin{code}
-module Packages ( PackageConfig(..), 
-		  defaultPackageConfig,
-		  mungePackagePaths,
-		  showPackages
-		)
+module Packages (
+	PackageConfig,
+	InstalledPackageInfo(..),
+	Version(..),
+	PackageIdentifier(..),
+	defaultPackageConfig,
+	packageDependents, 
+	showPackages,
+
+	PackageName,		-- Instance of Outputable
+	mkPackageName, packageIdName, packageConfigName, packageNameString,
+	basePackage, rtsPackage, haskell98Package, thPackage, -- :: PackageName
+
+	PackageConfigMap, emptyPkgMap, lookupPkg,
+	extendPackageConfigMap, getPackageDetails, getPackageConfigMap,
+    )
 where
 
 #include "HsVersions.h"
-import Pretty
 
+import Distribution.InstalledPackageInfo
+import Distribution.Package
+import Data.Version
 import CmdLineOpts	( dynFlag, verbosity )
-import DriverUtil	( my_prefix_match )
 import ErrUtils		( dumpIfSet )
 import Outputable	( docToSDoc )
-\end{code}
+import FastString
+import UniqFM
+import Util
+import Pretty
 
-\begin{code}
-#define WANT_PRETTY
--- Yes, do generate pretty-printing stuff for packages
+import DATA_IOREF
 
--- There's a blob of code shared with ghc-pkg, 
--- so we just include it from there 
-#include "../utils/ghc-pkg/Package.hs"
-\end{code}
+-- -----------------------------------------------------------------------------
+-- Our PackageConfig type is just InstalledPackageInfo from Cabal.  Later we
+-- might need to extend it with some GHC-specific stuff, but for now it's fine.
 
-%*********************************************************
-%*						 	 *
-\subsection{Load the config file}
-%*							 *
-%*********************************************************
+type PackageConfig = InstalledPackageInfo
+defaultPackageConfig = emptyInstalledPackageInfo
 
-\begin{code}
-mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
--- Replace the string "$libdir" at the beginning of a path
--- with the current libdir (obtained from the -B option).
-mungePackagePaths top_dir ps = map munge_pkg ps
- where 
-  munge_pkg p = p{ import_dirs  = munge_paths (import_dirs p),
-		   include_dirs = munge_paths (include_dirs p),
-    		   library_dirs = munge_paths (library_dirs p),
-		   framework_dirs = munge_paths (framework_dirs p) }
-
-  munge_paths = map munge_path
-
-  munge_path p 
-	  | Just p' <- my_prefix_match "$libdir" p = top_dir ++ p'
-	  | otherwise				   = p
-\end{code}
+-- -----------------------------------------------------------------------------
+-- Package names
 
+type PackageName = FastString	-- No encoding at all
 
-%*********************************************************
-%*						 	 *
-\subsection{Display results}
-%*							 *
-%*********************************************************
+mkPackageName :: String -> PackageName
+mkPackageName = mkFastString
 
-\begin{code}
-showPackages :: [PackageConfig] -> IO ()
+packageIdName :: PackageIdentifier -> PackageName
+packageIdName = mkPackageName . showPackageId
+
+packageConfigName :: PackageConfig -> PackageName
+packageConfigName = packageIdName . package
+
+packageNameString :: PackageName -> String
+packageNameString = unpackFS
+
+rtsPackage, basePackage, haskell98Package, thPackage :: PackageName
+basePackage      = FSLIT("base")
+rtsPackage 	 = FSLIT("rts")
+haskell98Package = FSLIT("haskell98")
+thPackage        = FSLIT("template-haskell")	-- Template Haskell libraries in here
+
+packageDependents :: PackageConfig -> [PackageName]
+-- Impedence matcher, because PackageConfig has Strings 
+-- not PackageNames at the moment.  Sigh.
+packageDependents pkg = map packageIdName (depends pkg)
+
+-- -----------------------------------------------------------------------------
+-- A PackageConfigMap maps a PackageName to a PackageConfig
+
+type PackageConfigMap = UniqFM PackageConfig
+
+lookupPkg    :: PackageConfigMap -> PackageName -> Maybe PackageConfig
+
+emptyPkgMap  :: PackageConfigMap
+
+emptyPkgMap  = emptyUFM
+lookupPkg    = lookupUFM
+
+extendPkgMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
+extendPkgMap pkg_map new_pkgs 
+  = foldl add pkg_map new_pkgs
+  where
+    add pkg_map p = addToUFM pkg_map (packageConfigName p) p
+
+GLOBAL_VAR(v_Package_details, emptyPkgMap, PackageConfigMap)
+
+getPackageConfigMap :: IO PackageConfigMap
+getPackageConfigMap = readIORef v_Package_details
+
+extendPackageConfigMap :: [PackageConfig] -> IO ()
+extendPackageConfigMap pkg_configs = do
+  old_pkg_map <- readIORef v_Package_details
+  writeIORef v_Package_details (extendPkgMap old_pkg_map pkg_configs)
+
+getPackageDetails :: [PackageName] -> IO [PackageConfig]
+getPackageDetails ps = do
+  pkg_details <- getPackageConfigMap
+  return [ pkg | Just pkg <- map (lookupPkg pkg_details) ps ]
+
+
+-- -----------------------------------------------------------------------------
+-- Displaying packages
+
+showPackages :: PackageConfigMap -> IO ()
 -- Show package info on console, if verbosity is >= 3
-showPackages ps
+showPackages pkg_map
   = do  { verb <- dynFlag verbosity
 	; dumpIfSet (verb >= 3) "Packages"
-	  	    (docToSDoc (vcat (map dumpPkgGuts ps)))
+	  	    (docToSDoc (vcat (map (text.showInstalledPackageInfo) ps)))
 	}
+  where
+    ps = eltsUFM pkg_map
+
 \end{code}