compiler/main/Packages.lhs

   1 %
   2 % (c) The University of Glasgow, 2006
   3 %
   4 \begin{code}
   5 -- | Package manipulation
   6 module Packages (
   7         module PackageConfig,
   8
   9         -- * The PackageConfigMap
  10         PackageConfigMap, emptyPackageConfigMap, lookupPackage,
  11         extendPackageConfigMap, dumpPackages,
  12
  13         -- * Reading the package config, and processing cmdline args
  14         PackageState(..),
  15         initPackages,
  16         getPackageDetails,
  17         lookupModuleInAllPackages, lookupModuleWithSuggestions,
  18
  19         -- * Inspecting the set of packages in scope
  20         getPackageIncludePath,
  21         getPackageLibraryPath,
  22         getPackageLinkOpts,
  23         getPackageExtraCcOpts,
  24         getPackageFrameworkPath,
  25         getPackageFrameworks,
  26         getPreloadPackagesAnd,
  27
  28         collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
  29         packageHsLibs,
  30
  31         -- * Utils
  32         isDllName
  33     )
  34 where
  35
  36 #include "HsVersions.h"
  37
  38 import PackageConfig
  39 import DynFlags
  40 import StaticFlags
  41 import Config           ( cProjectVersion )
  42 import Name             ( Name, nameModule_maybe )
  43 import UniqFM
  44 import Module
  45 import Util
  46 import Panic
  47 import Outputable
  48 import Maybes
  49
  50 import System.Environment ( getEnv )
  51 import Distribution.InstalledPackageInfo
  52 import Distribution.InstalledPackageInfo.Binary
  53 import Distribution.Package hiding (PackageId,depends)
  54 import FastString
  55 import ErrUtils         ( debugTraceMsg, putMsg, Message )
  56 import Exception
  57
  58 import System.Directory
  59 import System.FilePath as FilePath
  60 import qualified System.FilePath.Posix as FilePath.Posix
  61 import Control.Monad
  62 import Data.List as List
  63 import Data.Map (Map)
  64 import qualified Data.Map as Map
  65 import qualified FiniteMap as Map
  66 import qualified Data.Set as Set
  67
  68 -- ---------------------------------------------------------------------------
  69 -- The Package state
  70
  71 -- | Package state is all stored in 'DynFlag's, including the details of
  72 -- all packages, which packages are exposed, and which modules they
  73 -- provide.
  74 --
  75 -- The package state is computed by 'initPackages', and kept in DynFlags.
  76 --
  77 --   * @-package <pkg>@ causes @<pkg>@ to become exposed, and all other packages
  78 --      with the same name to become hidden.
  79 --
  80 --   * @-hide-package <pkg>@ causes @<pkg>@ to become hidden.
  81 --
  82 --   * Let @exposedPackages@ be the set of packages thus exposed.
  83 --     Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of
  84 --     their dependencies.
  85 --
  86 --   * When searching for a module from an preload import declaration,
  87 --     only the exposed modules in @exposedPackages@ are valid.
  88 --
  89 --   * When searching for a module from an implicit import, all modules
  90 --     from @depExposedPackages@ are valid.
  91 --
  92 --   * When linking in a compilation manager mode, we link in packages the
  93 --     program depends on (the compiler knows this list by the
  94 --     time it gets to the link step).  Also, we link in all packages
  95 --     which were mentioned with preload @-package@ flags on the command-line,
  96 --     or are a transitive dependency of same, or are \"base\"\/\"rts\".
  97 --     The reason for this is that we might need packages which don't
  98 --     contain any Haskell modules, and therefore won't be discovered
  99 --     by the normal mechanism of dependency tracking.
 100
 101 -- Notes on DLLs
 102 -- ~~~~~~~~~~~~~
 103 -- When compiling module A, which imports module B, we need to
 104 -- know whether B will be in the same DLL as A.
 105 --      If it's in the same DLL, we refer to B_f_closure
 106 --      If it isn't, we refer to _imp__B_f_closure
 107 -- When compiling A, we record in B's Module value whether it's
 108 -- in a different DLL, by setting the DLL flag.
 109
 110 data PackageState = PackageState {
 111   pkgIdMap              :: PackageConfigMap, -- PackageId   -> PackageConfig
 112         -- The exposed flags are adjusted according to -package and
 113         -- -hide-package flags, and -ignore-package removes packages.
 114
 115   preloadPackages      :: [PackageId],
 116         -- The packages we're going to link in eagerly.  This list
 117         -- should be in reverse dependency order; that is, a package
 118         -- is always mentioned before the packages it depends on.
 119
 120   moduleToPkgConfAll    :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping
 121         -- Derived from pkgIdMap.
 122         -- Maps Module to (pkgconf,exposed), where pkgconf is the
 123         -- PackageConfig for the package containing the module, and
 124         -- exposed is True if the package exposes that module.
 125
 126   installedPackageIdMap :: InstalledPackageIdMap
 127   }
 128
 129 -- | A PackageConfigMap maps a 'PackageId' to a 'PackageConfig'
 130 type PackageConfigMap = UniqFM PackageConfig
 131
 132 type InstalledPackageIdMap = Map InstalledPackageId PackageId
 133
 134 type InstalledPackageIndex = Map InstalledPackageId PackageConfig
 135
 136 emptyPackageConfigMap :: PackageConfigMap
 137 emptyPackageConfigMap = emptyUFM
 138
 139 -- | Find the package we know about with the given id (e.g. \"foo-1.0\"), if any
 140 lookupPackage :: PackageConfigMap -> PackageId -> Maybe PackageConfig
 141 lookupPackage = lookupUFM
 142
 143 extendPackageConfigMap
 144    :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
 145 extendPackageConfigMap pkg_map new_pkgs
 146   = foldl add pkg_map new_pkgs
 147   where add pkg_map p = addToUFM pkg_map (packageConfigId p) p
 148
 149 -- | Looks up the package with the given id in the package state, panicing if it is
 150 -- not found
 151 getPackageDetails :: PackageState -> PackageId -> PackageConfig
 152 getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid)
 153
 154 -- ----------------------------------------------------------------------------
 155 -- Loading the package config files and building up the package state
 156
 157 -- | Call this after 'DynFlags.parseDynFlags'.  It reads the package
 158 -- configuration files, and sets up various internal tables of package
 159 -- information, according to the package-related flags on the
 160 -- command-line (@-package@, @-hide-package@ etc.)
 161 --
 162 -- Returns a list of packages to link in if we're doing dynamic linking.
 163 -- This list contains the packages that the user explicitly mentioned with
 164 -- @-package@ flags.
 165 --
 166 -- 'initPackages' can be called again subsequently after updating the
 167 -- 'packageFlags' field of the 'DynFlags', and it will update the
 168 -- 'pkgState' in 'DynFlags' and return a list of packages to
 169 -- link in.
 170 initPackages :: DynFlags -> IO (DynFlags, [PackageId])
 171 initPackages dflags = do
 172   pkg_db <- case pkgDatabase dflags of
 173                 Nothing -> readPackageConfigs dflags
 174                 Just db -> return $ maybeHidePackages dflags db
 175   (pkg_state, preload, this_pkg)
 176         <- mkPackageState dflags pkg_db [] (thisPackage dflags)
 177   return (dflags{ pkgDatabase = Just pkg_db,
 178                   pkgState = pkg_state,
 179                   thisPackage = this_pkg },
 180           preload)
 181
 182 -- -----------------------------------------------------------------------------
 183 -- Reading the package database(s)
 184
 185 readPackageConfigs :: DynFlags -> IO [PackageConfig]
 186 readPackageConfigs dflags = do
 187    e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH")
 188    system_pkgconfs <- getSystemPackageConfigs dflags
 189
 190    let pkgconfs = case e_pkg_path of
 191                     Left _   -> system_pkgconfs
 192                     Right path
 193                      | last cs == "" -> init cs ++ system_pkgconfs
 194                      | otherwise     -> cs
 195                      where cs = parseSearchPath path
 196                      -- if the path ends in a separator (eg. "/foo/bar:")
 197                      -- the we tack on the system paths.
 198
 199    pkgs <- mapM (readPackageConfig dflags)
 200                 (pkgconfs ++ reverse (extraPkgConfs dflags))
 201                 -- later packages shadow earlier ones.  extraPkgConfs
 202                 -- is in the opposite order to the flags on the
 203                 -- command line.
 204
 205    return (concat pkgs)
 206
 207
 208 getSystemPackageConfigs :: DynFlags -> IO [FilePath]
 209 getSystemPackageConfigs dflags = do
 210         -- System one always comes first
 211    let system_pkgconf = systemPackageConfig dflags
 212
 213         -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
 214         -- unless the -no-user-package-conf flag was given.
 215    user_pkgconf <- do
 216       if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do
 217       appdir <- getAppUserDataDirectory "ghc"
 218       let
 219          dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
 220          pkgconf = dir </> "package.conf.d"
 221       --
 222       exist <- doesDirectoryExist pkgconf
 223       if exist then return [pkgconf] else return []
 224     `catchIO` (\_ -> return [])
 225
 226    return (system_pkgconf : user_pkgconf)
 227
 228 readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
 229 readPackageConfig dflags conf_file = do
 230   isdir <- doesDirectoryExist conf_file
 231
 232   proto_pkg_configs <-
 233     if isdir
 234        then do let filename = conf_file </> "package.cache"
 235                debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
 236                conf <- readBinPackageDB filename
 237                return (map installedPackageInfoToPackageConfig conf)
 238
 239        else do
 240             isfile <- doesFileExist conf_file
 241             when (not isfile) $
 242               ghcError $ InstallationError $
 243                 "can't find a package database at " ++ conf_file
 244             debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
 245             str <- readFile conf_file
 246             return (map installedPackageInfoToPackageConfig $ read str)
 247
 248   let
 249       top_dir = topDir dflags
 250       pkgroot = takeDirectory conf_file
 251       pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
 252       pkg_configs2 = maybeHidePackages dflags pkg_configs1
 253   --
 254   return pkg_configs2
 255
 256 maybeHidePackages :: DynFlags -> [PackageConfig] -> [PackageConfig]
 257 maybeHidePackages dflags pkgs
 258   | dopt Opt_HideAllPackages dflags = map hide pkgs
 259   | otherwise                       = pkgs
 260   where
 261     hide pkg = pkg{ exposed = False }
 262
 263 -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
 264 mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
 265 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
 266 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
 267 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
 268 -- The "pkgroot" is the directory containing the package database.
 269 --
 270 -- Also perform a similar substitution for the older GHC-specific
 271 -- "$topdir" variable. The "topdir" is the location of the ghc
 272 -- installation (obtained from the -B option).
 273 mungePackagePaths top_dir pkgroot pkg =
 274     pkg {
 275       importDirs  = munge_paths (importDirs pkg),
 276       includeDirs = munge_paths (includeDirs pkg),
 277       libraryDirs = munge_paths (libraryDirs pkg),
 278       frameworkDirs = munge_paths (frameworkDirs pkg),
 279       haddockInterfaces = munge_paths (haddockInterfaces pkg),
 280       haddockHTMLs = munge_urls (haddockHTMLs pkg)
 281     }
 282   where
 283     munge_paths = map munge_path
 284     munge_urls  = map munge_url
 285
 286     munge_path p
 287       | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
 288       | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
 289       | otherwise                                = p
 290
 291     munge_url p
 292       | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
 293       | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
 294       | otherwise                                   = p
 295
 296     toUrlPath r p = "file:///"
 297                  -- URLs always use posix style '/' separators:
 298                  ++ FilePath.Posix.joinPath
 299                         (r : -- We need to drop a leading "/" or "\\"
 300                              -- if there is one:
 301                              dropWhile (all isPathSeparator)
 302                                        (FilePath.splitDirectories p))
 303
 304     -- We could drop the separator here, and then use </> above. However,
 305     -- by leaving it in and using ++ we keep the same path separator
 306     -- rather than letting FilePath change it to use \ as the separator
 307     stripVarPrefix var path = case stripPrefix var path of
 308                               Just [] -> Just []
 309                               Just cs@(c : _) | isPathSeparator c -> Just cs
 310                               _ -> Nothing
 311
 312
 313 -- -----------------------------------------------------------------------------
 314 -- Modify our copy of the package database based on a package flag
 315 -- (-package, -hide-package, -ignore-package).
 316
 317 applyPackageFlag
 318    :: UnusablePackages
 319    -> [PackageConfig]           -- Initial database
 320    -> PackageFlag               -- flag to apply
 321    -> IO [PackageConfig]        -- new database
 322
 323 applyPackageFlag unusable pkgs flag =
 324   case flag of
 325     ExposePackage str ->
 326        case selectPackages (matchingStr str) pkgs unusable of
 327          Left ps         -> packageFlagErr flag ps
 328          Right (p:ps,qs) -> return (p':ps')
 329           where p' = p {exposed=True}
 330                 ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
 331          _ -> panic "applyPackageFlag"
 332
 333     ExposePackageId str ->
 334        case selectPackages (matchingId str) pkgs unusable of
 335          Left ps         -> packageFlagErr flag ps
 336          Right (p:ps,qs) -> return (p':ps')
 337           where p' = p {exposed=True}
 338                 ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
 339          _ -> panic "applyPackageFlag"
 340
 341     HidePackage str ->
 342        case selectPackages (matchingStr str) pkgs unusable of
 343          Left ps       -> packageFlagErr flag ps
 344          Right (ps,qs) -> return (map hide ps ++ qs)
 345           where hide p = p {exposed=False}
 346
 347     _ -> panic "applyPackageFlag"
 348
 349    where
 350         -- When a package is requested to be exposed, we hide all other
 351         -- packages with the same name.
 352         hideAll name ps = map maybe_hide ps
 353           where maybe_hide p
 354                    | pkgName (sourcePackageId p) == name = p {exposed=False}
 355                    | otherwise                           = p
 356
 357
 358 selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
 359                -> UnusablePackages
 360                -> Either [(PackageConfig, UnusablePackageReason)]
 361                   ([PackageConfig], [PackageConfig])
 362 selectPackages matches pkgs unusable
 363   = let
 364         (ps,rest) = partition matches pkgs
 365         reasons = [ (p, Map.lookup (installedPackageId p) unusable)
 366                   | p <- ps ]
 367     in
 368     if all (isJust.snd) reasons
 369        then Left  [ (p, reason) | (p,Just reason) <- reasons ]
 370        else Right (sortByVersion [ p | (p,Nothing) <- reasons ], rest)
 371
 372 -- A package named on the command line can either include the
 373 -- version, or just the name if it is unambiguous.
 374 matchingStr :: String -> PackageConfig -> Bool
 375 matchingStr str p
 376         =  str == display (sourcePackageId p)
 377         || str == display (pkgName (sourcePackageId p))
 378
 379 matchingId :: String -> PackageConfig -> Bool
 380 matchingId str p =  InstalledPackageId str == installedPackageId p
 381
 382 sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m]
 383 sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId)))
 384
 385 comparing :: Ord a => (t -> a) -> t -> t -> Ordering
 386 comparing f a b = f a `compare` f b
 387
 388 packageFlagErr :: PackageFlag
 389                -> [(PackageConfig, UnusablePackageReason)]
 390                -> IO a
 391
 392 -- for missing DPH package we emit a more helpful error message, because
 393 -- this may be the result of using -fdph-par or -fdph-seq.
 394 packageFlagErr (ExposePackage pkg) [] | is_dph_package pkg
 395   = ghcError (CmdLineError (showSDoc $ dph_err))
 396   where dph_err = text "the " <> text pkg <> text " package is not installed."
 397                   $$ text "To install it: \"cabal install dph\"."
 398         is_dph_package pkg = "dph" `isPrefixOf` pkg
 399
 400 packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err))
 401   where err = text "cannot satisfy " <> ppr_flag <>
 402                 (if null reasons then empty else text ": ") $$
 403               nest 4 (ppr_reasons $$
 404                       text "(use -v for more information)")
 405         ppr_flag = case flag of
 406                      IgnorePackage p -> text "-ignore-package " <> text p
 407                      HidePackage p   -> text "-hide-package " <> text p
 408                      ExposePackage p -> text "-package " <> text p
 409                      ExposePackageId p -> text "-package-id " <> text p
 410         ppr_reasons = vcat (map ppr_reason reasons)
 411         ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason
 412
 413 -- -----------------------------------------------------------------------------
 414 -- Hide old versions of packages
 415
 416 --
 417 -- hide all packages for which there is also a later version
 418 -- that is already exposed.  This just makes it non-fatal to have two
 419 -- versions of a package exposed, which can happen if you install a
 420 -- later version of a package in the user database, for example.
 421 --
 422 hideOldPackages :: DynFlags -> [PackageConfig] -> IO [PackageConfig]
 423 hideOldPackages dflags pkgs = mapM maybe_hide pkgs
 424   where maybe_hide p
 425            | not (exposed p) = return p
 426            | (p' : _) <- later_versions = do
 427                 debugTraceMsg dflags 2 $
 428                    (ptext (sLit "hiding package") <+> pprSPkg p <+>
 429                     ptext (sLit "to avoid conflict with later version") <+>
 430                     pprSPkg p')
 431                 return (p {exposed=False})
 432            | otherwise = return p
 433           where myname = pkgName (sourcePackageId p)
 434                 myversion = pkgVersion (sourcePackageId p)
 435                 later_versions = [ p | p <- pkgs, exposed p,
 436                                     let pkg = sourcePackageId p,
 437                                     pkgName pkg == myname,
 438                                     pkgVersion pkg > myversion ]
 439
 440 -- -----------------------------------------------------------------------------
 441 -- Wired-in packages
 442
 443 findWiredInPackages
 444    :: DynFlags
 445    -> [PackageConfig]           -- database
 446    -> IO [PackageConfig]
 447
 448 findWiredInPackages dflags pkgs = do
 449   --
 450   -- Now we must find our wired-in packages, and rename them to
 451   -- their canonical names (eg. base-1.0 ==> base).
 452   --
 453   let
 454         wired_in_pkgids :: [String]
 455         wired_in_pkgids = map packageIdString
 456                           [ primPackageId,
 457                             integerPackageId,
 458                             basePackageId,
 459                             rtsPackageId,
 460                             thPackageId,
 461                             dphSeqPackageId,
 462                             dphParPackageId ]
 463
 464         matches :: PackageConfig -> String -> Bool
 465         pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid
 466
 467         -- find which package corresponds to each wired-in package
 468         -- delete any other packages with the same name
 469         -- update the package and any dependencies to point to the new
 470         -- one.
 471         --
 472         -- When choosing which package to map to a wired-in package
 473         -- name, we prefer exposed packages, and pick the latest
 474         -- version.  To override the default choice, -hide-package
 475         -- could be used to hide newer versions.
 476         --
 477         findWiredInPackage :: [PackageConfig] -> String
 478                            -> IO (Maybe InstalledPackageId)
 479         findWiredInPackage pkgs wired_pkg =
 480            let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
 481            case all_ps of
 482                 []   -> notfound
 483                 many -> pick (head (sortByVersion many))
 484           where
 485                 notfound = do
 486                           debugTraceMsg dflags 2 $
 487                             ptext (sLit "wired-in package ")
 488                                  <> text wired_pkg
 489                                  <> ptext (sLit " not found.")
 490                           return Nothing
 491                 pick :: InstalledPackageInfo_ ModuleName
 492                      -> IO (Maybe InstalledPackageId)
 493                 pick pkg = do
 494                         debugTraceMsg dflags 2 $
 495                             ptext (sLit "wired-in package ")
 496                                  <> text wired_pkg
 497                                  <> ptext (sLit " mapped to ")
 498                                  <> pprIPkg pkg
 499                         return (Just (installedPackageId pkg))
 500
 501
 502   mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids
 503   let
 504         wired_in_ids = catMaybes mb_wired_in_ids
 505
 506         -- this is old: we used to assume that if there were
 507         -- multiple versions of wired-in packages installed that
 508         -- they were mutually exclusive.  Now we're assuming that
 509         -- you have one "main" version of each wired-in package
 510         -- (the latest version), and the others are backward-compat
 511         -- wrappers that depend on this one.  e.g. base-4.0 is the
 512         -- latest, base-3.0 is a compat wrapper depending on base-4.0.
 513         {-
 514         deleteOtherWiredInPackages pkgs = filterOut bad pkgs
 515           where bad p = any (p `matches`) wired_in_pkgids
 516                       && package p `notElem` map fst wired_in_ids
 517         -}
 518
 519         updateWiredInDependencies pkgs = map upd_pkg pkgs
 520           where upd_pkg p
 521                   | installedPackageId p `elem` wired_in_ids
 522                   = p { sourcePackageId = (sourcePackageId p){ pkgVersion = Version [] [] } }
 523                   | otherwise
 524                   = p
 525
 526   return $ updateWiredInDependencies pkgs
 527
 528 -- ----------------------------------------------------------------------------
 529
 530 data UnusablePackageReason
 531   = IgnoredWithFlag
 532   | MissingDependencies [InstalledPackageId]
 533   | ShadowedBy InstalledPackageId
 534
 535 type UnusablePackages = Map InstalledPackageId UnusablePackageReason
 536
 537 pprReason :: SDoc -> UnusablePackageReason -> SDoc
 538 pprReason pref reason = case reason of
 539   IgnoredWithFlag ->
 540       pref <+> ptext (sLit "ignored due to an -ignore-package flag")
 541   MissingDependencies deps ->
 542       pref <+>
 543       ptext (sLit "unusable due to missing or recursive dependencies:") $$
 544         nest 2 (hsep (map (text.display) deps))
 545   ShadowedBy ipid ->
 546       pref <+> ptext (sLit "shadowed by package ") <> text (display ipid)
 547
 548 reportUnusable :: DynFlags -> UnusablePackages -> IO ()
 549 reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
 550   where
 551     report (ipid, reason) =
 552        debugTraceMsg dflags 2 $
 553          pprReason
 554            (ptext (sLit "package") <+>
 555             text (display ipid) <+> text "is") reason
 556
 557 -- ----------------------------------------------------------------------------
 558 --
 559 -- Detect any packages that have missing dependencies, and also any
 560 -- mutually-recursive groups of packages (loops in the package graph
 561 -- are not allowed).  We do this by taking the least fixpoint of the
 562 -- dependency graph, repeatedly adding packages whose dependencies are
 563 -- satisfied until no more can be added.
 564 --
 565 findBroken :: [PackageConfig] -> UnusablePackages
 566 findBroken pkgs = go [] Map.empty pkgs
 567  where
 568    go avail ipids not_avail =
 569      case partitionWith (depsAvailable ipids) not_avail of
 570         ([], not_avail) ->
 571             Map.fromList [ (installedPackageId p, MissingDependencies deps)
 572                          | (p,deps) <- not_avail ]
 573         (new_avail, not_avail) ->
 574             go (new_avail ++ avail) new_ipids (map fst not_avail)
 575             where new_ipids = Map.insertList
 576                                 [ (installedPackageId p, p) | p <- new_avail ]
 577                                 ipids
 578
 579    depsAvailable :: InstalledPackageIndex
 580                  -> PackageConfig
 581                  -> Either PackageConfig (PackageConfig, [InstalledPackageId])
 582    depsAvailable ipids pkg
 583         | null dangling = Left pkg
 584         | otherwise     = Right (pkg, dangling)
 585         where dangling = filter (not . (`Map.member` ipids)) (depends pkg)
 586
 587 -- -----------------------------------------------------------------------------
 588 -- Eliminate shadowed packages, giving the user some feedback
 589
 590 -- later packages in the list should shadow earlier ones with the same
 591 -- package name/version.  Additionally, a package may be preferred if
 592 -- it is in the transitive closure of packages selected using -package-id
 593 -- flags.
 594 shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
 595 shadowPackages pkgs preferred
 596  = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
 597    in  Map.fromList shadowed
 598  where
 599  check (shadowed,pkgmap) pkg
 600       | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)
 601       , let
 602             ipid_new = installedPackageId pkg
 603             ipid_old = installedPackageId oldpkg
 604         --
 605       , ipid_old /= ipid_new
 606       = if ipid_old `elem` preferred
 607            then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap )
 608            else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' )
 609       | otherwise
 610       = (shadowed, pkgmap')
 611       where
 612         pkgmap' = addToUFM pkgmap (packageConfigId pkg) pkg
 613
 614 -- -----------------------------------------------------------------------------
 615
 616 ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
 617 ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
 618   where
 619   doit (IgnorePackage str) =
 620      case partition (matchingStr str) pkgs of
 621          (ps, _) -> [ (installedPackageId p, IgnoredWithFlag)
 622                     | p <- ps ]
 623         -- missing package is not an error for -ignore-package,
 624         -- because a common usage is to -ignore-package P as
 625         -- a preventative measure just in case P exists.
 626   doit _ = panic "ignorePackages"
 627
 628 -- -----------------------------------------------------------------------------
 629
 630 depClosure :: InstalledPackageIndex
 631            -> [InstalledPackageId]
 632            -> [InstalledPackageId]
 633 depClosure index ipids = closure Map.empty ipids
 634   where
 635    closure set [] = Map.keys set
 636    closure set (ipid : ipids)
 637      | ipid `Map.member` set = closure set ipids
 638      | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set)
 639                                                  (depends p ++ ipids)
 640      | otherwise = closure set ipids
 641
 642 -- -----------------------------------------------------------------------------
 643 -- When all the command-line options are in, we can process our package
 644 -- settings and populate the package state.
 645
 646 mkPackageState
 647     :: DynFlags
 648     -> [PackageConfig]          -- initial database
 649     -> [PackageId]              -- preloaded packages
 650     -> PackageId                -- this package
 651     -> IO (PackageState,
 652            [PackageId],         -- new packages to preload
 653            PackageId) -- this package, might be modified if the current
 654                       -- package is a wired-in package.
 655
 656 mkPackageState dflags pkgs0 preload0 this_package = do
 657
 658 {-
 659    Plan.
 660
 661    1. P = transitive closure of packages selected by -package-id
 662
 663    2. Apply shadowing.  When there are multiple packages with the same
 664       sourcePackageId,
 665         * if one is in P, use that one
 666         * otherwise, use the one highest in the package stack
 667       [
 668        rationale: we cannot use two packages with the same sourcePackageId
 669        in the same program, because sourcePackageId is the symbol prefix.
 670        Hence we must select a consistent set of packages to use.  We have
 671        a default algorithm for doing this: packages higher in the stack
 672        shadow those lower down.  This default algorithm can be overriden
 673        by giving explicit -package-id flags; then we have to take these
 674        preferences into account when selecting which other packages are
 675        made available.
 676
 677        Our simple algorithm throws away some solutions: there may be other
 678        consistent sets that would satisfy the -package flags, but it's
 679        not GHC's job to be doing constraint solving.
 680       ]
 681
 682    3. remove packages selected by -ignore-package
 683
 684    4. remove any packages with missing dependencies, or mutually recursive
 685       dependencies.
 686
 687    5. report (with -v) any packages that were removed by steps 2-4
 688
 689    6. apply flags to set exposed/hidden on the resulting packages
 690       - if any flag refers to a package which was removed by 2-4, then
 691         we can give an error message explaining why
 692
 693    7. hide any packages which are superseded by later exposed packages
 694 -}
 695
 696   let
 697       flags = reverse (packageFlags dflags) ++ dphPackage
 698       -- expose the appropriate DPH backend library
 699       dphPackage = case dphBackend dflags of
 700                      DPHPar  -> [ExposePackage "dph-prim-par", ExposePackage "dph-par"]
 701                      DPHSeq  -> [ExposePackage "dph-prim-seq", ExposePackage "dph-seq"]
 702                      DPHThis -> []
 703                      DPHNone -> []
 704
 705       -- pkgs0 with duplicate packages filtered out.  This is
 706       -- important: it is possible for a package in the global package
 707       -- DB to have the same IPID as a package in the user DB, and
 708       -- we want the latter to take precedence.  This is not the same
 709       -- as shadowing (below), since in this case the two packages
 710       -- have the same ABI and are interchangeable.
 711       --
 712       -- #4072: note that we must retain the ordering of the list here
 713       -- so that shadowing behaves as expected when we apply it later.
 714       pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0
 715           where del p (s,ps)
 716                   | pid `Set.member` s = (s,ps)
 717                   | otherwise          = (Set.insert pid s, p:ps)
 718                   where pid = installedPackageId p
 719           -- XXX this is just a variant of nub
 720
 721       ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]
 722
 723       ipid_selected = depClosure ipid_map [ InstalledPackageId i
 724                                           | ExposePackageId i <- flags ]
 725
 726       (ignore_flags, other_flags) = partition is_ignore flags
 727       is_ignore IgnorePackage{} = True
 728       is_ignore _ = False
 729
 730       shadowed = shadowPackages pkgs0_unique ipid_selected
 731
 732       ignored  = ignorePackages ignore_flags pkgs0_unique
 733
 734       pkgs0' = filter (not . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique
 735       broken   = findBroken pkgs0'
 736       unusable = shadowed `Map.union` ignored `Map.union` broken
 737
 738   reportUnusable dflags unusable
 739
 740   --
 741   -- Modify the package database according to the command-line flags
 742   -- (-package, -hide-package, -ignore-package, -hide-all-packages).
 743   --
 744   pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags
 745   let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1
 746
 747   -- Here we build up a set of the packages mentioned in -package
 748   -- flags on the command line; these are called the "preload"
 749   -- packages.  we link these packages in eagerly.  The preload set
 750   -- should contain at least rts & base, which is why we pretend that
 751   -- the command line contains -package rts & -package base.
 752   --
 753   let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]
 754
 755       get_exposed (ExposePackage   s) = filter (matchingStr s) pkgs2
 756       get_exposed (ExposePackageId s) = filter (matchingId  s) pkgs2
 757       get_exposed _                   = []
 758
 759   -- hide packages that are subsumed by later versions
 760   pkgs3 <- hideOldPackages dflags pkgs2
 761
 762   -- sort out which packages are wired in
 763   pkgs4 <- findWiredInPackages dflags pkgs3
 764
 765   let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4
 766
 767       ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
 768                               | p <- pkgs4 ]
 769
 770       lookupIPID ipid@(InstalledPackageId str)
 771          | Just pid <- Map.lookup ipid ipid_map = return pid
 772          | otherwise                            = missingPackageErr str
 773
 774   preload2 <- mapM lookupIPID preload1
 775
 776   let
 777       -- add base & rts to the preload packages
 778       basicLinkedPackages
 779        | dopt Opt_AutoLinkPackages dflags
 780           = filter (flip elemUFM pkg_db) [basePackageId, rtsPackageId]
 781        | otherwise = []
 782       -- but in any case remove the current package from the set of
 783       -- preloaded packages so that base/rts does not end up in the
 784       -- set up preloaded package when we are just building it
 785       preload3 = nub $ filter (/= this_package)
 786                      $ (basicLinkedPackages ++ preload2)
 787
 788   -- Close the preload packages with their dependencies
 789   dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing))
 790   let new_dep_preload = filter (`notElem` preload0) dep_preload
 791
 792   let pstate = PackageState{ preloadPackages     = dep_preload,
 793                              pkgIdMap            = pkg_db,
 794                              moduleToPkgConfAll  = mkModuleMap pkg_db,
 795                              installedPackageIdMap = ipid_map
 796                            }
 797
 798   return (pstate, new_dep_preload, this_package)
 799
 800
 801 -- -----------------------------------------------------------------------------
 802 -- Make the mapping from module to package info
 803
 804 mkModuleMap
 805   :: PackageConfigMap
 806   -> UniqFM [(PackageConfig, Bool)]
 807 mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids
 808   where
 809         pkgids = map packageConfigId (eltsUFM pkg_db)
 810
 811         extend_modmap pkgid modmap =
 812                 addListToUFM_C (++) modmap
 813                    ([(m, [(pkg, True)])  | m <- exposed_mods] ++
 814                     [(m, [(pkg, False)]) | m <- hidden_mods])
 815           where
 816                 pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid)
 817                 exposed_mods = exposedModules pkg
 818                 hidden_mods  = hiddenModules pkg
 819
 820 pprSPkg :: PackageConfig -> SDoc
 821 pprSPkg p = text (display (sourcePackageId p))
 822
 823 pprIPkg :: PackageConfig -> SDoc
 824 pprIPkg p = text (display (installedPackageId p))
 825
 826 -- -----------------------------------------------------------------------------
 827 -- Extracting information from the packages in scope
 828
 829 -- Many of these functions take a list of packages: in those cases,
 830 -- the list is expected to contain the "dependent packages",
 831 -- i.e. those packages that were found to be depended on by the
 832 -- current module/program.  These can be auto or non-auto packages, it
 833 -- doesn't really matter.  The list is always combined with the list
 834 -- of preload (command-line) packages to determine which packages to
 835 -- use.
 836
 837 -- | Find all the include directories in these and the preload packages
 838 getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String]
 839 getPackageIncludePath dflags pkgs =
 840   collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
 841
 842 collectIncludeDirs :: [PackageConfig] -> [FilePath]
 843 collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
 844
 845 -- | Find all the library paths in these and the preload packages
 846 getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String]
 847 getPackageLibraryPath dflags pkgs =
 848   collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
 849
 850 collectLibraryPaths :: [PackageConfig] -> [FilePath]
 851 collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
 852
 853 -- | Find all the link options in these and the preload packages
 854 getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String]
 855 getPackageLinkOpts dflags pkgs =
 856   collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
 857
 858 collectLinkOpts :: DynFlags -> [PackageConfig] -> [String]
 859 collectLinkOpts dflags ps = concat (map all_opts ps)
 860   where
 861         libs p     = packageHsLibs dflags p ++ extraLibraries p
 862         all_opts p = map ("-l" ++) (libs p) ++ ldOptions p
 863
 864 packageHsLibs :: DynFlags -> PackageConfig -> [String]
 865 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
 866   where
 867         ways0 = ways dflags
 868
 869         ways1 = filter ((/= WayDyn) . wayName) ways0
 870         -- the name of a shared library is libHSfoo-ghc<version>.so
 871         -- we leave out the _dyn, because it is superfluous
 872
 873         -- debug RTS includes support for -eventlog
 874         ways2 | WayDebug `elem` map wayName ways1
 875               = filter ((/= WayEventLog) . wayName) ways1
 876               | otherwise
 877               = ways1
 878
 879         tag     = mkBuildTag (filter (not . wayRTSOnly) ways2)
 880         rts_tag = mkBuildTag ways2
 881
 882         mkDynName | opt_Static = id
 883                   | otherwise = (++ ("-ghc" ++ cProjectVersion))
 884
 885         addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)
 886         addSuffix other_lib      = other_lib ++ (expandTag tag)
 887
 888         expandTag t | null t = ""
 889                     | otherwise = '_':t
 890
 891 -- | Find all the C-compiler options in these and the preload packages
 892 getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
 893 getPackageExtraCcOpts dflags pkgs = do
 894   ps <- getPreloadPackagesAnd dflags pkgs
 895   return (concatMap ccOptions ps)
 896
 897 -- | Find all the package framework paths in these and the preload packages
 898 getPackageFrameworkPath  :: DynFlags -> [PackageId] -> IO [String]
 899 getPackageFrameworkPath dflags pkgs = do
 900   ps <- getPreloadPackagesAnd dflags pkgs
 901   return (nub (filter notNull (concatMap frameworkDirs ps)))
 902
 903 -- | Find all the package frameworks in these and the preload packages
 904 getPackageFrameworks  :: DynFlags -> [PackageId] -> IO [String]
 905 getPackageFrameworks dflags pkgs = do
 906   ps <- getPreloadPackagesAnd dflags pkgs
 907   return (concatMap frameworks ps)
 908
 909 -- -----------------------------------------------------------------------------
 910 -- Package Utils
 911
 912 -- | Takes a 'Module', and if the module is in a package returns
 913 -- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package,
 914 -- and exposed is @True@ if the package exposes the module.
 915 lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)]
 916 lookupModuleInAllPackages dflags m
 917   = case lookupModuleWithSuggestions dflags m of
 918       Right pbs -> pbs
 919       Left  _   -> []
 920
 921 lookupModuleWithSuggestions
 922   :: DynFlags -> ModuleName
 923   -> Either [Module] [(PackageConfig,Bool)]
 924          -- Lookup module in all packages
 925          -- Right pbs   =>   found in pbs
 926          -- Left  ms    =>   not found; but here are sugestions
 927 lookupModuleWithSuggestions dflags m
 928   = case lookupUFM (moduleToPkgConfAll pkg_state) m of
 929         Nothing -> Left suggestions
 930         Just ps -> Right ps
 931   where
 932     pkg_state = pkgState dflags
 933     suggestions
 934       | dopt Opt_HelpfulErrors dflags = fuzzyLookup (moduleNameString m) all_mods
 935       | otherwise                     = []
 936
 937     all_mods :: [(String, Module)]     -- All modules
 938     all_mods = [ (moduleNameString mod_nm, mkModule pkg_id mod_nm)
 939                | pkg_config <- eltsUFM (pkgIdMap pkg_state)
 940                , let pkg_id = packageConfigId pkg_config
 941                , mod_nm <- exposedModules pkg_config ]
 942
 943 -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
 944 -- 'PackageConfig's
 945 getPreloadPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig]
 946 getPreloadPackagesAnd dflags pkgids =
 947   let
 948       state   = pkgState dflags
 949       pkg_map = pkgIdMap state
 950       ipid_map = installedPackageIdMap state
 951       preload = preloadPackages state
 952       pairs = zip pkgids (repeat Nothing)
 953   in do
 954   all_pkgs <- throwErr (foldM (add_package pkg_map ipid_map) preload pairs)
 955   return (map (getPackageDetails state) all_pkgs)
 956
 957 -- Takes a list of packages, and returns the list with dependencies included,
 958 -- in reverse dependency order (a package appears before those it depends on).
 959 closeDeps :: PackageConfigMap
 960           -> Map InstalledPackageId PackageId
 961           -> [(PackageId, Maybe PackageId)]
 962           -> IO [PackageId]
 963 closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps)
 964
 965 throwErr :: MaybeErr Message a -> IO a
 966 throwErr m = case m of
 967                 Failed e    -> ghcError (CmdLineError (showSDoc e))
 968                 Succeeded r -> return r
 969
 970 closeDepsErr :: PackageConfigMap
 971              -> Map InstalledPackageId PackageId
 972              -> [(PackageId,Maybe PackageId)]
 973              -> MaybeErr Message [PackageId]
 974 closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
 975
 976 -- internal helper
 977 add_package :: PackageConfigMap
 978             -> Map InstalledPackageId PackageId
 979             -> [PackageId]
 980             -> (PackageId,Maybe PackageId)
 981             -> MaybeErr Message [PackageId]
 982 add_package pkg_db ipid_map ps (p, mb_parent)
 983   | p `elem` ps = return ps     -- Check if we've already added this package
 984   | otherwise =
 985       case lookupPackage pkg_db p of
 986         Nothing -> Failed (missingPackageMsg (packageIdString p) <>
 987                            missingDependencyMsg mb_parent)
 988         Just pkg -> do
 989            -- Add the package's dependents also
 990            ps' <- foldM add_package_ipid ps (depends pkg)
 991            return (p : ps')
 992           where
 993             add_package_ipid ps ipid@(InstalledPackageId str)
 994               | Just pid <- Map.lookup ipid ipid_map
 995               = add_package pkg_db ipid_map ps (pid, Just p)
 996               | otherwise
 997               = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent)
 998
 999 missingPackageErr :: String -> IO a
1000 missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p)))
1001
1002 missingPackageMsg :: String -> SDoc
1003 missingPackageMsg p = ptext (sLit "unknown package:") <+> text p
1004
1005 missingDependencyMsg :: Maybe PackageId -> SDoc
1006 missingDependencyMsg Nothing = empty
1007 missingDependencyMsg (Just parent)
1008   = space <> parens (ptext (sLit "dependency of") <+> ftext (packageIdFS parent))
1009
1010 -- -----------------------------------------------------------------------------
1011
1012 -- | Will the 'Name' come from a dynamically linked library?
1013 isDllName :: PackageId -> Name -> Bool
1014 -- Despite the "dll", I think this function just means that
1015 -- the synbol comes from another dynamically-linked package,
1016 -- and applies on all platforms, not just Windows
1017 isDllName this_pkg name
1018   | opt_Static = False
1019   | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg
1020   | otherwise = False  -- no, it is not even an external name
1021
1022 -- -----------------------------------------------------------------------------
1023 -- Displaying packages
1024
1025 -- | Show package info on console, if verbosity is >= 3
1026 dumpPackages :: DynFlags -> IO ()
1027 dumpPackages dflags
1028   = do  let pkg_map = pkgIdMap (pkgState dflags)
1029         putMsg dflags $
1030               vcat (map (text . showInstalledPackageInfo
1031                               . packageConfigToInstalledPackageInfo)
1032                         (eltsUFM pkg_map))
1033 \end{code}