Follow changes in Cabal
[ghc-hetmet.git] / compiler / main / Packages.lhs
index fb54a12..6a5b63c 100644 (file)
@@ -19,7 +19,6 @@ module Packages (
 
        -- * Inspecting the set of packages in scope
        getPackageIncludePath,
-       getPackageCIncludes,
        getPackageLibraryPath,
        getPackageLinkOpts,
        getPackageExtraCcOpts,
@@ -47,18 +46,15 @@ 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
+import Distribution.InstalledPackageInfo hiding (depends)
+import Distribution.Package hiding (depends)
 import Distribution.Version
 import FastString
 import ErrUtils         ( debugTraceMsg, putMsg, Message )
 
 import System.Directory
+import System.FilePath
 import Data.Maybe
 import Control.Monad
 import Data.List
@@ -107,9 +103,6 @@ import Control.Exception        ( throwDyn )
 -- 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.
@@ -167,7 +160,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)
 
@@ -205,14 +199,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)
@@ -223,8 +217,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]
@@ -258,14 +252,20 @@ 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
 
   munge_path p 
-         | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
+         | Just p' <- maybePrefixMatch "$topdir"     p =            top_dir ++ p'
+         | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
          | otherwise                               = p
 
+  toHttpPath p = "file:///" ++ p
+
 
 -- -----------------------------------------------------------------------------
 -- Modify our copy of the package database based on a package flag
@@ -281,6 +281,7 @@ applyPackageFlag pkgs flag =
         ExposePackage str ->
           case matchingPackages str pkgs of
                Nothing -> missingPackageErr str
+               Just ([], _) -> panic "applyPackageFlag"
                Just (p:ps,qs) -> return (p':ps')
                  where p' = p {exposed=True}
                        ps' = hideAll (pkgName (package p)) (ps++qs)
@@ -294,7 +295,7 @@ applyPackageFlag pkgs flag =
        IgnorePackage str ->
            case matchingPackages str pkgs of
                 Nothing -> return pkgs
-                Just (ps,qs) -> return qs
+                Just (_, qs) -> return qs
                -- missing package is not an error for -ignore-package,
                -- because a common usage is to -ignore-package P as
                -- a preventative measure just in case P exists.
@@ -316,14 +317,17 @@ matchingPackages str pkgs
         -- A package named on the command line can either include the
        -- version, or just the name if it is unambiguous.
        matches str p
-               =  str == showPackageId (package p)
+               =  str == display (package p)
                || str == pkgName (package p)
 
-
+pickPackages :: [PackageConfig] -> [String] -> [PackageConfig]
 pickPackages pkgs strs = 
-  [ p | p <- strs, Just (p:ps,_) <- [matchingPackages p pkgs] ]
+  [ p | p <- strs, Just (p:_, _) <- [matchingPackages p pkgs] ]
 
+sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m]
 sortByVersion = sortBy (flip (comparing (pkgVersion.package)))
+
+comparing :: Ord a => (t -> a) -> t -> t -> Ordering
 comparing f a b = f a `compare` f b
 
 -- -----------------------------------------------------------------------------
@@ -341,10 +345,10 @@ hideOldPackages dflags pkgs = mapM maybe_hide pkgs
           | not (exposed p) = return p
           | (p' : _) <- later_versions = do
                debugTraceMsg dflags 2 $
-                  (ptext SLIT("hiding package") <+> 
-                    text (showPackageId (package p)) <+>
-                   ptext SLIT("to avoid conflict with later version") <+>
-                   text (showPackageId (package p')))
+                  (ptext (sLit "hiding package") <+> 
+                    text (display (package p)) <+>
+                   ptext (sLit "to avoid conflict with later version") <+>
+                   text (display (package p')))
                return (p {exposed=False})
           | otherwise = return p
          where myname = pkgName (package p)
@@ -372,10 +376,13 @@ 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
 
@@ -401,16 +408,16 @@ findWiredInPackages dflags pkgs preload this_package = do
           where
                 notfound = do
                          debugTraceMsg dflags 2 $
-                           ptext SLIT("wired-in package ")
+                           ptext (sLit "wired-in package ")
                                 <> text wired_pkg
-                                <> ptext SLIT(" not found.")
+                                <> ptext (sLit " not found.")
                          return Nothing
                 pick pkg = do
                         debugTraceMsg dflags 2 $
-                           ptext SLIT("wired-in package ")
+                           ptext (sLit "wired-in package ")
                                 <> text wired_pkg
-                                <> ptext SLIT(" mapped to ")
-                                <> text (showPackageId (package pkg))
+                                <> ptext (sLit " mapped to ")
+                                <> text (display (package pkg))
                        return (Just (package pkg))
 
 
@@ -443,10 +450,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
@@ -454,22 +464,28 @@ 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:") $$ 
-             nest 2 (hsep (map (text.showPackageId) deps)))
-
-   getDanglingDeps pkgs ignored p = (p, filter dangling (depends p))
-        where dangling pid = mkPackageId pid `elem` ignored
+             (ptext (sLit "package") <+> pprPkg p <+> 
+                  ptext (sLit "will be ignored due to missing or recursive dependencies:") $$ 
+             nest 2 (hsep (map (text.display) deps)))
 
 -- -----------------------------------------------------------------------------
 -- When all the command-line options are in, we can process our package
@@ -516,19 +532,21 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do
   pkgs <- elimDanglingDeps dflags pkgs3 ignored
 
   let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs
-      pkgids = map packageConfigId pkgs
 
       -- 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
                           }
@@ -548,15 +566,15 @@ 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))
+pprPkg p = text (display (package p))
 
 -- -----------------------------------------------------------------------------
 -- Extracting information from the packages in scope
@@ -574,11 +592,6 @@ getPackageIncludePath dflags pkgs = do
   ps <- getPreloadPackagesAnd dflags pkgs
   return (nub (filter notNull (concatMap includeDirs ps)))
 
-       -- includes are in reverse dependency order (i.e. rts first)
-getPackageCIncludes :: [PackageConfig] -> IO [String]
-getPackageCIncludes pkg_configs = do
-  return (reverse (nub (filter notNull (concatMap includes pkg_configs))))
-
 getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String]
 getPackageLibraryPath dflags pkgs = do 
   ps <- getPreloadPackagesAnd dflags pkgs
@@ -590,26 +603,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))
 
@@ -681,12 +685,16 @@ add_package pkg_db ps (p, mb_parent)
           ps' <- foldM (add_package pkg_db) ps (zip deps (repeat (Just p)))
           return (p : ps')
 
+missingPackageErr :: String -> IO [PackageConfig]
 missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p)))
-missingPackageMsg p = ptext SLIT("unknown package:") <+> text p
 
+missingPackageMsg :: String -> SDoc
+missingPackageMsg p = ptext (sLit "unknown package:") <+> text p
+
+missingDependencyMsg :: Maybe PackageId -> SDoc
 missingDependencyMsg Nothing = empty
 missingDependencyMsg (Just parent)
-  = space <> parens (ptext SLIT("dependency of") <+> ftext (packageIdFS parent))
+  = space <> parens (ptext (sLit "dependency of") <+> ftext (packageIdFS parent))
 
 -- -----------------------------------------------------------------------------
 
@@ -704,5 +712,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}