X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FPackages.lhs;h=bd421bd799cc726ff1fa868b5cfc332135691e48;hp=0b7798333e787986f044d35a3af1d321e13da676;hb=fcf6b22d0478be20e27c2245f3e34dd272e12522;hpb=b4890aa689ec0bc44f78f883a89939ad6d62ece9

diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 0b77983..bd421bd 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -54,10 +54,6 @@ import Maybes		( expectJust, MaybeErr(..) )
 import Panic
 import Outputable
 
-#if __GLASGOW_HASKELL__ < 603
-import Compat.Directory	( getAppUserDataDirectory )
-#endif
-
 import System.Environment ( getEnv )
 import Distribution.InstalledPackageInfo
 import Distribution.Package
@@ -66,6 +62,7 @@ import FastString
 import ErrUtils         ( debugTraceMsg, putMsg, Message )
 
 import System.Directory
+import System.FilePath
 import Data.Maybe
 import Control.Monad
 import Data.List
@@ -210,14 +207,14 @@ getSystemPackageConfigs dflags = do
 	-- to maintain the package database on systems with a package
 	-- management system, or systems that don't want to run ghc-pkg
 	-- to register or unregister packages.  Undocumented feature for now.
-   let system_pkgconf_dir = system_pkgconf ++ ".d"
+   let system_pkgconf_dir = system_pkgconf <.> "d"
    system_pkgconf_dir_exists <- doesDirectoryExist system_pkgconf_dir
    system_pkgconfs <-
      if system_pkgconf_dir_exists
        then do files <- getDirectoryContents system_pkgconf_dir
-               return [ system_pkgconf_dir ++ '/' : file
+               return [ system_pkgconf_dir </> file
                       | file <- files
-                      , isSuffixOf ".conf" file]
+                      , takeExtension file == ".conf" ]
        else return []
 
 	-- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
@@ -228,8 +225,8 @@ getSystemPackageConfigs dflags = do
       appdir <- getAppUserDataDirectory "ghc"
       let 
      	 pkgconf = appdir
-		   `joinFileName` (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
-		   `joinFileName` "package.conf"
+		   </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
+		   </> "package.conf"
       flg <- doesFileExist pkgconf
       if (flg && dopt Opt_ReadUserPackageConf dflags)
 	then return [pkgconf]
@@ -263,7 +260,10 @@ mungePackagePaths top_dir ps = map munge_pkg ps
   munge_pkg p = p{ importDirs  = munge_paths (importDirs p),
 		   includeDirs = munge_paths (includeDirs p),
     		   libraryDirs = munge_paths (libraryDirs p),
-		   frameworkDirs = munge_paths (frameworkDirs p) }
+		   frameworkDirs = munge_paths (frameworkDirs p),
+                   haddockInterfaces = munge_paths (haddockInterfaces p),
+	           haddockHTMLs = munge_paths (haddockHTMLs p)
+                    }
 
   munge_paths = map munge_path
 
@@ -380,10 +380,12 @@ findWiredInPackages dflags pkgs preload this_package = do
   -- their canonical names (eg. base-1.0 ==> base).
   --
   let
-	wired_in_pkgids = [ basePackageId,
-			    rtsPackageId,
-			    haskell98PackageId,
-			    thPackageId,
+        wired_in_pkgids = [ primPackageId,
+                            integerPackageId,
+                            basePackageId,
+                            rtsPackageId,
+                            haskell98PackageId,
+                            thPackageId,
                             ndpPackageId ]
 
 	wired_in_names = map packageIdString wired_in_pkgids
@@ -452,10 +454,13 @@ findWiredInPackages dflags pkgs preload this_package = do
 
   return (pkgs2, preload1, new_this_pkg)
 
--- -----------------------------------------------------------------------------
+-- ----------------------------------------------------------------------------
 --
--- Eliminate any packages which have dangling dependencies (
--- because the dependency was removed by -ignore-package).
+-- Detect any packages that have missing dependencies, and also any
+-- mutually-recursive groups of packages (loops in the package graph
+-- are not allowed).  We do this by taking the least fixpoint of the
+-- dependency graph, repeatedly adding packages whose dependencies are
+-- satisfied until no more can be added.
 --
 elimDanglingDeps
    :: DynFlags
@@ -463,23 +468,29 @@ elimDanglingDeps
    -> [PackageId]       -- ignored packages
    -> IO [PackageConfig]
 
-elimDanglingDeps dflags pkgs ignored = 
-   case partition (not.null.snd) (map (getDanglingDeps pkgs ignored) pkgs) of
-        ([],ps) -> return (map fst ps)
-        (ps,qs) -> do
-            mapM_ reportElim ps
-            elimDanglingDeps dflags (map fst qs)
-                (ignored ++ map packageConfigId (map fst ps))
+elimDanglingDeps dflags pkgs ignored = go [] pkgs'
  where
+   pkgs' = filter (\p -> packageConfigId p `notElem` ignored) pkgs
+
+   go avail not_avail =
+     case partitionWith (depsAvailable avail) not_avail of
+        ([],        not_avail) -> do mapM_ reportElim not_avail; return avail
+        (new_avail, not_avail) -> go (new_avail ++ avail) (map fst not_avail)
+
+   depsAvailable :: [PackageConfig] -> PackageConfig
+                 -> Either PackageConfig (PackageConfig, [PackageIdentifier])
+   depsAvailable pkgs_ok pkg 
+        | null dangling = Left pkg
+        | otherwise     = Right (pkg, dangling)
+        where dangling = filter (`notElem` pids) (depends pkg)
+              pids = map package pkgs_ok
+
    reportElim (p, deps) = 
         debugTraceMsg dflags 2 $
              (ptext SLIT("package") <+> pprPkg p <+> 
-                  ptext SLIT("will be ignored due to missing dependencies:") $$ 
+                  ptext SLIT("will be ignored due to missing or recursive dependencies:") $$ 
 	      nest 2 (hsep (map (text.showPackageId) deps)))
 
-   getDanglingDeps pkgs ignored p = (p, filter dangling (depends p))
-        where dangling pid = mkPackageId pid `elem` ignored
-
 -- -----------------------------------------------------------------------------
 -- When all the command-line options are in, we can process our package
 -- settings and populate the package state.