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