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
  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                       -- package is a wired-in package.
 626
 627 mkPackageState dflags pkgs0 preload0 this_package = do
 628
 629 {-
 630    Plan.
 631
 632    1. P = transitive closure of packages selected by -package-id
 633
 634    2. Apply shadowing.  When there are multiple packages with the same
 635       sourcePackageId,
 636         * if one is in P, use that one
 637         * otherwise, use the one highest in the package stack
 638       [
 639        rationale: we cannot use two packages with the same sourcePackageId
 640        in the same program, because sourcePackageId is the symbol prefix.
 641        Hence we must select a consistent set of packages to use.  We have
 642        a default algorithm for doing this: packages higher in the stack
 643        shadow those lower down.  This default algorithm can be overriden
 644        by giving explicit -package-id flags; then we have to take these
 645        preferences into account when selecting which other packages are
 646        made available.
 647
 648        Our simple algorithm throws away some solutions: there may be other
 649        consistent sets that would satisfy the -package flags, but it's
 650        not GHC's job to be doing constraint solving.
 651       ]
 652
 653    3. remove packages selected by -ignore-package
 654
 655    4. remove any packages with missing dependencies, or mutually recursive
 656       dependencies.
 657
 658    5. report (with -v) any packages that were removed by steps 2-4
 659
 660    6. apply flags to set exposed/hidden on the resulting packages
 661       - if any flag refers to a package which was removed by 2-4, then
 662         we can give an error message explaining why
 663
 664    7. hide any packages which are superseded by later exposed packages
 665 -}
 666
 667   let
 668       flags = reverse (packageFlags dflags) ++ dphPackage
 669       -- expose the appropriate DPH backend library
 670       dphPackage = case dphBackend dflags of
 671                      DPHPar  -> [ExposePackage "dph-prim-par", ExposePackage "dph-par"]
 672                      DPHSeq  -> [ExposePackage "dph-prim-seq", ExposePackage "dph-seq"]
 673                      DPHThis -> []
 674                      DPHNone -> []
 675
 676       -- pkgs0 with duplicate packages filtered out.  This is
 677       -- important: it is possible for a package in the global package
 678       -- DB to have the same IPID as a package in the user DB, and
 679       -- we want the latter to take precedence.  This is not the same
 680       -- as shadowing (below), since in this case the two packages
 681       -- have the same ABI and are interchangeable.
 682       --
 683       -- #4072: note that we must retain the ordering of the list here
 684       -- so that shadowing behaves as expected when we apply it later.
 685       pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0
 686           where del p (s,ps)
 687                   | pid `Set.member` s = (s,ps)
 688                   | otherwise          = (Set.insert pid s, p:ps)
 689                   where pid = installedPackageId p
 690           -- XXX this is just a variant of nub
 691
 692       ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]
 693
 694       ipid_selected = depClosure ipid_map [ InstalledPackageId i
 695                                           | ExposePackageId i <- flags ]
 696
 697       (ignore_flags, other_flags) = partition is_ignore flags
 698       is_ignore IgnorePackage{} = True
 699       is_ignore _ = False
 700
 701       shadowed = shadowPackages pkgs0_unique ipid_selected
 702
 703       ignored  = ignorePackages ignore_flags pkgs0_unique
 704
 705       pkgs0' = filter (not . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique
 706       broken   = findBroken pkgs0'
 707       unusable = shadowed `Map.union` ignored `Map.union` broken
 708
 709   reportUnusable dflags unusable
 710
 711   --
 712   -- Modify the package database according to the command-line flags
 713   -- (-package, -hide-package, -ignore-package, -hide-all-packages).
 714   --
 715   pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags
 716   let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1
 717
 718   -- Here we build up a set of the packages mentioned in -package
 719   -- flags on the command line; these are called the "preload"
 720   -- packages.  we link these packages in eagerly.  The preload set
 721   -- should contain at least rts & base, which is why we pretend that
 722   -- the command line contains -package rts & -package base.
 723   --
 724   let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]
 725
 726       get_exposed (ExposePackage   s) = filter (matchingStr s) pkgs2
 727       get_exposed (ExposePackageId s) = filter (matchingId  s) pkgs2
 728       get_exposed _                   = []
 729
 730   -- hide packages that are subsumed by later versions
 731   pkgs3 <- hideOldPackages dflags pkgs2
 732
 733   -- sort out which packages are wired in
 734   pkgs4 <- findWiredInPackages dflags pkgs3
 735
 736   let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4
 737
 738       ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
 739                               | p <- pkgs4 ]
 740
 741       lookupIPID ipid@(InstalledPackageId str)
 742          | Just pid <- Map.lookup ipid ipid_map = return pid
 743          | otherwise                            = missingPackageErr str
 744
 745   preload2 <- mapM lookupIPID preload1
 746
 747   let
 748       -- add base & rts to the preload packages
 749       basicLinkedPackages
 750        | dopt Opt_AutoLinkPackages dflags
 751           = filter (flip elemUFM pkg_db) [basePackageId, rtsPackageId]
 752        | otherwise = []
 753       -- but in any case remove the current package from the set of
 754       -- preloaded packages so that base/rts does not end up in the
 755       -- set up preloaded package when we are just building it
 756       preload3 = nub $ filter (/= this_package)
 757                      $ (basicLinkedPackages ++ preload2)
 758
 759   -- Close the preload packages with their dependencies
 760   dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing))
 761   let new_dep_preload = filter (`notElem` preload0) dep_preload
 762
 763   let pstate = PackageState{ preloadPackages     = dep_preload,
 764                              pkgIdMap            = pkg_db,
 765                              moduleToPkgConfAll  = mkModuleMap pkg_db,
 766                              installedPackageIdMap = ipid_map
 767                            }
 768
 769   return (pstate, new_dep_preload, this_package)
 770
 771
 772 -- -----------------------------------------------------------------------------
 773 -- Make the mapping from module to package info
 774
 775 mkModuleMap
 776   :: PackageConfigMap
 777   -> UniqFM [(PackageConfig, Bool)]
 778 mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids
 779   where
 780         pkgids = map packageConfigId (eltsUFM pkg_db)
 781
 782         extend_modmap pkgid modmap =
 783                 addListToUFM_C (++) modmap
 784                    ([(m, [(pkg, True)])  | m <- exposed_mods] ++
 785                     [(m, [(pkg, False)]) | m <- hidden_mods])
 786           where
 787                 pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid)
 788                 exposed_mods = exposedModules pkg
 789                 hidden_mods  = hiddenModules pkg
 790
 791 pprSPkg :: PackageConfig -> SDoc
 792 pprSPkg p = text (display (sourcePackageId p))
 793
 794 pprIPkg :: PackageConfig -> SDoc
 795 pprIPkg p = text (display (installedPackageId p))
 796
 797 -- -----------------------------------------------------------------------------
 798 -- Extracting information from the packages in scope
 799
 800 -- Many of these functions take a list of packages: in those cases,
 801 -- the list is expected to contain the "dependent packages",
 802 -- i.e. those packages that were found to be depended on by the
 803 -- current module/program.  These can be auto or non-auto packages, it
 804 -- doesn't really matter.  The list is always combined with the list
 805 -- of preload (command-line) packages to determine which packages to
 806 -- use.
 807
 808 -- | Find all the include directories in these and the preload packages
 809 getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String]
 810 getPackageIncludePath dflags pkgs =
 811   collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
 812
 813 collectIncludeDirs :: [PackageConfig] -> [FilePath]
 814 collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
 815
 816 -- | Find all the library paths in these and the preload packages
 817 getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String]
 818 getPackageLibraryPath dflags pkgs =
 819   collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
 820
 821 collectLibraryPaths :: [PackageConfig] -> [FilePath]
 822 collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
 823
 824 -- | Find all the link options in these and the preload packages
 825 getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String]
 826 getPackageLinkOpts dflags pkgs =
 827   collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
 828
 829 collectLinkOpts :: DynFlags -> [PackageConfig] -> [String]
 830 collectLinkOpts dflags ps = concat (map all_opts ps)
 831   where
 832         libs p     = packageHsLibs dflags p ++ extraLibraries p
 833         all_opts p = map ("-l" ++) (libs p) ++ ldOptions p
 834
 835 packageHsLibs :: DynFlags -> PackageConfig -> [String]
 836 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
 837   where
 838         ways0 = ways dflags
 839
 840         ways1 = filter ((/= WayDyn) . wayName) ways0
 841         -- the name of a shared library is libHSfoo-ghc<version>.so
 842         -- we leave out the _dyn, because it is superfluous
 843
 844         -- debug RTS includes support for -eventlog
 845         ways2 | WayDebug `elem` map wayName ways1
 846               = filter ((/= WayEventLog) . wayName) ways1
 847               | otherwise
 848               = ways1
 849
 850         tag     = mkBuildTag (filter (not . wayRTSOnly) ways2)
 851         rts_tag = mkBuildTag ways2
 852
 853         mkDynName | opt_Static = id
 854                   | otherwise = (++ ("-ghc" ++ cProjectVersion))
 855
 856         addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)
 857         addSuffix other_lib      = other_lib ++ (expandTag tag)
 858
 859         expandTag t | null t = ""
 860                     | otherwise = '_':t
 861
 862 -- | Find all the C-compiler options in these and the preload packages
 863 getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
 864 getPackageExtraCcOpts dflags pkgs = do
 865   ps <- getPreloadPackagesAnd dflags pkgs
 866   return (concatMap ccOptions ps)
 867
 868 -- | Find all the package framework paths in these and the preload packages
 869 getPackageFrameworkPath  :: DynFlags -> [PackageId] -> IO [String]
 870 getPackageFrameworkPath dflags pkgs = do
 871   ps <- getPreloadPackagesAnd dflags pkgs
 872   return (nub (filter notNull (concatMap frameworkDirs ps)))
 873
 874 -- | Find all the package frameworks in these and the preload packages
 875 getPackageFrameworks  :: DynFlags -> [PackageId] -> IO [String]
 876 getPackageFrameworks dflags pkgs = do
 877   ps <- getPreloadPackagesAnd dflags pkgs
 878   return (concatMap frameworks ps)
 879
 880 -- -----------------------------------------------------------------------------
 881 -- Package Utils
 882
 883 -- | Takes a 'Module', and if the module is in a package returns
 884 -- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package,
 885 -- and exposed is @True@ if the package exposes the module.
 886 lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)]
 887 lookupModuleInAllPackages dflags m
 888   = case lookupModuleWithSuggestions dflags m of
 889       Right pbs -> pbs
 890       Left  _   -> []
 891
 892 lookupModuleWithSuggestions
 893   :: DynFlags -> ModuleName
 894   -> Either [Module] [(PackageConfig,Bool)]
 895          -- Lookup module in all packages
 896          -- Right pbs   =>   found in pbs
 897          -- Left  ms    =>   not found; but here are sugestions
 898 lookupModuleWithSuggestions dflags m
 899   = case lookupUFM (moduleToPkgConfAll pkg_state) m of
 900         Nothing -> Left suggestions
 901         Just ps -> Right ps
 902   where
 903     pkg_state = pkgState dflags
 904     suggestions
 905       | dopt Opt_HelpfulErrors dflags = fuzzyLookup (moduleNameString m) all_mods
 906       | otherwise                     = []
 907
 908     all_mods :: [(String, Module)]     -- All modules
 909     all_mods = [ (moduleNameString mod_nm, mkModule pkg_id mod_nm)
 910                | pkg_config <- eltsUFM (pkgIdMap pkg_state)
 911                , let pkg_id = packageConfigId pkg_config
 912                , mod_nm <- exposedModules pkg_config ]
 913
 914 -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
 915 -- 'PackageConfig's
 916 getPreloadPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig]
 917 getPreloadPackagesAnd dflags pkgids =
 918   let
 919       state   = pkgState dflags
 920       pkg_map = pkgIdMap state
 921       ipid_map = installedPackageIdMap state
 922       preload = preloadPackages state
 923       pairs = zip pkgids (repeat Nothing)
 924   in do
 925   all_pkgs <- throwErr (foldM (add_package pkg_map ipid_map) preload pairs)
 926   return (map (getPackageDetails state) all_pkgs)
 927
 928 -- Takes a list of packages, and returns the list with dependencies included,
 929 -- in reverse dependency order (a package appears before those it depends on).
 930 closeDeps :: PackageConfigMap
 931           -> Map InstalledPackageId PackageId
 932           -> [(PackageId, Maybe PackageId)]
 933           -> IO [PackageId]
 934 closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps)
 935
 936 throwErr :: MaybeErr Message a -> IO a
 937 throwErr m = case m of
 938                 Failed e    -> ghcError (CmdLineError (showSDoc e))
 939                 Succeeded r -> return r
 940
 941 closeDepsErr :: PackageConfigMap
 942              -> Map InstalledPackageId PackageId
 943              -> [(PackageId,Maybe PackageId)]
 944              -> MaybeErr Message [PackageId]
 945 closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
 946
 947 -- internal helper
 948 add_package :: PackageConfigMap
 949             -> Map InstalledPackageId PackageId
 950             -> [PackageId]
 951             -> (PackageId,Maybe PackageId)
 952             -> MaybeErr Message [PackageId]
 953 add_package pkg_db ipid_map ps (p, mb_parent)
 954   | p `elem` ps = return ps     -- Check if we've already added this package
 955   | otherwise =
 956       case lookupPackage pkg_db p of
 957         Nothing -> Failed (missingPackageMsg (packageIdString p) <>
 958                            missingDependencyMsg mb_parent)
 959         Just pkg -> do
 960            -- Add the package's dependents also
 961            ps' <- foldM add_package_ipid ps (depends pkg)
 962            return (p : ps')
 963           where
 964             add_package_ipid ps ipid@(InstalledPackageId str)
 965               | Just pid <- Map.lookup ipid ipid_map
 966               = add_package pkg_db ipid_map ps (pid, Just p)
 967               | otherwise
 968               = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent)
 969
 970 missingPackageErr :: String -> IO a
 971 missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p)))
 972
 973 missingPackageMsg :: String -> SDoc
 974 missingPackageMsg p = ptext (sLit "unknown package:") <+> text p
 975
 976 missingDependencyMsg :: Maybe PackageId -> SDoc
 977 missingDependencyMsg Nothing = empty
 978 missingDependencyMsg (Just parent)
 979   = space <> parens (ptext (sLit "dependency of") <+> ftext (packageIdFS parent))
 980
 981 -- -----------------------------------------------------------------------------
 982
 983 -- | Will the 'Name' come from a dynamically linked library?
 984 isDllName :: PackageId -> Name -> Bool
 985 -- Despite the "dll", I think this function just means that
 986 -- the synbol comes from another dynamically-linked package,
 987 -- and applies on all platforms, not just Windows
 988 isDllName this_pkg name
 989   | opt_Static = False
 990   | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg
 991   | otherwise = False  -- no, it is not even an external name
 992
 993 -- -----------------------------------------------------------------------------
 994 -- Displaying packages
 995
 996 -- | Show package info on console, if verbosity is >= 3
 997 dumpPackages :: DynFlags -> IO ()
 998 dumpPackages dflags
 999   = do  let pkg_map = pkgIdMap (pkgState dflags)
1000         putMsg dflags $
1001               vcat (map (text . showInstalledPackageInfo
1002                               . packageConfigToInstalledPackageInfo)
1003                         (eltsUFM pkg_map))
1004 \end{code}