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 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 packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err))
 363   where err = text "cannot satisfy " <> ppr_flag <>
 364                 (if null reasons then empty else text ": ") $$
 365               nest 4 (ppr_reasons $$
 366                       text "(use -v for more information)")
 367         ppr_flag = case flag of
 368                      IgnorePackage p -> text "-ignore-package " <> text p
 369                      HidePackage p   -> text "-hide-package " <> text p
 370                      ExposePackage p -> text "-package " <> text p
 371                      ExposePackageId p -> text "-package-id " <> text p
 372         ppr_reasons = vcat (map ppr_reason reasons)
 373         ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason
 374
 375 -- -----------------------------------------------------------------------------
 376 -- Hide old versions of packages
 377
 378 --
 379 -- hide all packages for which there is also a later version
 380 -- that is already exposed.  This just makes it non-fatal to have two
 381 -- versions of a package exposed, which can happen if you install a
 382 -- later version of a package in the user database, for example.
 383 --
 384 hideOldPackages :: DynFlags -> [PackageConfig] -> IO [PackageConfig]
 385 hideOldPackages dflags pkgs = mapM maybe_hide pkgs
 386   where maybe_hide p
 387            | not (exposed p) = return p
 388            | (p' : _) <- later_versions = do
 389                 debugTraceMsg dflags 2 $
 390                    (ptext (sLit "hiding package") <+> pprSPkg p <+>
 391                     ptext (sLit "to avoid conflict with later version") <+>
 392                     pprSPkg p')
 393                 return (p {exposed=False})
 394            | otherwise = return p
 395           where myname = pkgName (sourcePackageId p)
 396                 myversion = pkgVersion (sourcePackageId p)
 397                 later_versions = [ p | p <- pkgs, exposed p,
 398                                     let pkg = sourcePackageId p,
 399                                     pkgName pkg == myname,
 400                                     pkgVersion pkg > myversion ]
 401
 402 -- -----------------------------------------------------------------------------
 403 -- Wired-in packages
 404
 405 findWiredInPackages
 406    :: DynFlags
 407    -> [PackageConfig]           -- database
 408    -> IO [PackageConfig]
 409
 410 findWiredInPackages dflags pkgs = do
 411   --
 412   -- Now we must find our wired-in packages, and rename them to
 413   -- their canonical names (eg. base-1.0 ==> base).
 414   --
 415   let
 416         wired_in_pkgids :: [String]
 417         wired_in_pkgids = map packageIdString
 418                           [ primPackageId,
 419                             integerPackageId,
 420                             basePackageId,
 421                             rtsPackageId,
 422                             haskell98PackageId,
 423                             thPackageId,
 424                             dphSeqPackageId,
 425                             dphParPackageId ]
 426
 427         matches :: PackageConfig -> String -> Bool
 428         pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid
 429
 430         -- find which package corresponds to each wired-in package
 431         -- delete any other packages with the same name
 432         -- update the package and any dependencies to point to the new
 433         -- one.
 434         --
 435         -- When choosing which package to map to a wired-in package
 436         -- name, we prefer exposed packages, and pick the latest
 437         -- version.  To override the default choice, -hide-package
 438         -- could be used to hide newer versions.
 439         --
 440         findWiredInPackage :: [PackageConfig] -> String
 441                            -> IO (Maybe InstalledPackageId)
 442         findWiredInPackage pkgs wired_pkg =
 443            let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
 444            case all_ps of
 445                 []   -> notfound
 446                 many -> pick (head (sortByVersion many))
 447           where
 448                 notfound = do
 449                           debugTraceMsg dflags 2 $
 450                             ptext (sLit "wired-in package ")
 451                                  <> text wired_pkg
 452                                  <> ptext (sLit " not found.")
 453                           return Nothing
 454                 pick :: InstalledPackageInfo_ ModuleName
 455                      -> IO (Maybe InstalledPackageId)
 456                 pick pkg = do
 457                         debugTraceMsg dflags 2 $
 458                             ptext (sLit "wired-in package ")
 459                                  <> text wired_pkg
 460                                  <> ptext (sLit " mapped to ")
 461                                  <> pprIPkg pkg
 462                         return (Just (installedPackageId pkg))
 463
 464
 465   mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids
 466   let
 467         wired_in_ids = catMaybes mb_wired_in_ids
 468
 469         -- this is old: we used to assume that if there were
 470         -- multiple versions of wired-in packages installed that
 471         -- they were mutually exclusive.  Now we're assuming that
 472         -- you have one "main" version of each wired-in package
 473         -- (the latest version), and the others are backward-compat
 474         -- wrappers that depend on this one.  e.g. base-4.0 is the
 475         -- latest, base-3.0 is a compat wrapper depending on base-4.0.
 476         {-
 477         deleteOtherWiredInPackages pkgs = filterOut bad pkgs
 478           where bad p = any (p `matches`) wired_in_pkgids
 479                       && package p `notElem` map fst wired_in_ids
 480         -}
 481
 482         updateWiredInDependencies pkgs = map upd_pkg pkgs
 483           where upd_pkg p
 484                   | installedPackageId p `elem` wired_in_ids
 485                   = p { sourcePackageId = (sourcePackageId p){ pkgVersion = Version [] [] } }
 486                   | otherwise
 487                   = p
 488
 489   return $ updateWiredInDependencies pkgs
 490
 491 -- ----------------------------------------------------------------------------
 492
 493 data UnusablePackageReason
 494   = IgnoredWithFlag
 495   | MissingDependencies [InstalledPackageId]
 496   | ShadowedBy InstalledPackageId
 497
 498 type UnusablePackages = Map InstalledPackageId UnusablePackageReason
 499
 500 pprReason :: SDoc -> UnusablePackageReason -> SDoc
 501 pprReason pref reason = case reason of
 502   IgnoredWithFlag ->
 503       pref <+> ptext (sLit "ignored due to an -ignore-package flag")
 504   MissingDependencies deps ->
 505       pref <+>
 506       ptext (sLit "unusable due to missing or recursive dependencies:") $$
 507         nest 2 (hsep (map (text.display) deps))
 508   ShadowedBy ipid ->
 509       pref <+> ptext (sLit "shadowed by package ") <> text (display ipid)
 510
 511 reportUnusable :: DynFlags -> UnusablePackages -> IO ()
 512 reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
 513   where
 514     report (ipid, reason) =
 515        debugTraceMsg dflags 2 $
 516          pprReason
 517            (ptext (sLit "package") <+>
 518             text (display ipid) <+> text "is") reason
 519
 520 -- ----------------------------------------------------------------------------
 521 --
 522 -- Detect any packages that have missing dependencies, and also any
 523 -- mutually-recursive groups of packages (loops in the package graph
 524 -- are not allowed).  We do this by taking the least fixpoint of the
 525 -- dependency graph, repeatedly adding packages whose dependencies are
 526 -- satisfied until no more can be added.
 527 --
 528 findBroken :: [PackageConfig] -> UnusablePackages
 529 findBroken pkgs = go [] Map.empty pkgs
 530  where
 531    go avail ipids not_avail =
 532      case partitionWith (depsAvailable ipids) not_avail of
 533         ([], not_avail) ->
 534             Map.fromList [ (installedPackageId p, MissingDependencies deps)
 535                          | (p,deps) <- not_avail ]
 536         (new_avail, not_avail) ->
 537             go (new_avail ++ avail) new_ipids (map fst not_avail)
 538             where new_ipids = Map.insertList
 539                                 [ (installedPackageId p, p) | p <- new_avail ]
 540                                 ipids
 541
 542    depsAvailable :: InstalledPackageIndex
 543                  -> PackageConfig
 544                  -> Either PackageConfig (PackageConfig, [InstalledPackageId])
 545    depsAvailable ipids pkg
 546         | null dangling = Left pkg
 547         | otherwise     = Right (pkg, dangling)
 548         where dangling = filter (not . (`Map.member` ipids)) (depends pkg)
 549
 550 -- -----------------------------------------------------------------------------
 551 -- Eliminate shadowed packages, giving the user some feedback
 552
 553 -- later packages in the list should shadow earlier ones with the same
 554 -- package name/version.  Additionally, a package may be preferred if
 555 -- it is in the transitive closure of packages selected using -package-id
 556 -- flags.
 557 shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
 558 shadowPackages pkgs preferred
 559  = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
 560    in  Map.fromList shadowed
 561  where
 562  check (shadowed,pkgmap) pkg
 563       | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)
 564       , let
 565             ipid_new = installedPackageId pkg
 566             ipid_old = installedPackageId oldpkg
 567         --
 568       , ipid_old /= ipid_new
 569       = if ipid_old `elem` preferred
 570            then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap )
 571            else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' )
 572       | otherwise
 573       = (shadowed, pkgmap')
 574       where
 575         pkgmap' = addToUFM pkgmap (packageConfigId pkg) pkg
 576
 577 -- -----------------------------------------------------------------------------
 578
 579 ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
 580 ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
 581   where
 582   doit (IgnorePackage str) =
 583      case partition (matchingStr str) pkgs of
 584          (ps, _) -> [ (installedPackageId p, IgnoredWithFlag)
 585                     | p <- ps ]
 586         -- missing package is not an error for -ignore-package,
 587         -- because a common usage is to -ignore-package P as
 588         -- a preventative measure just in case P exists.
 589   doit _ = panic "ignorePackages"
 590
 591 -- -----------------------------------------------------------------------------
 592
 593 depClosure :: InstalledPackageIndex
 594            -> [InstalledPackageId]
 595            -> [InstalledPackageId]
 596 depClosure index ipids = closure Map.empty ipids
 597   where
 598    closure set [] = Map.keys set
 599    closure set (ipid : ipids)
 600      | ipid `Map.member` set = closure set ipids
 601      | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set)
 602                                                  (depends p ++ ipids)
 603      | otherwise = closure set ipids
 604
 605 -- -----------------------------------------------------------------------------
 606 -- When all the command-line options are in, we can process our package
 607 -- settings and populate the package state.
 608
 609 mkPackageState
 610     :: DynFlags
 611     -> [PackageConfig]          -- initial database
 612     -> [PackageId]              -- preloaded packages
 613     -> PackageId                -- this package
 614     -> IO (PackageState,
 615            [PackageId],         -- new packages to preload
 616            PackageId) -- this package, might be modified if the current
 617
 618                       -- package is a wired-in package.
 619
 620 mkPackageState dflags pkgs0 preload0 this_package = do
 621
 622 {-
 623    Plan.
 624
 625    1. P = transitive closure of packages selected by -package-id
 626
 627    2. Apply shadowing.  When there are multiple packages with the same
 628       sourcePackageId,
 629         * if one is in P, use that one
 630         * otherwise, use the one highest in the package stack
 631       [
 632        rationale: we cannot use two packages with the same sourcePackageId
 633        in the same program, because sourcePackageId is the symbol prefix.
 634        Hence we must select a consistent set of packages to use.  We have
 635        a default algorithm for doing this: packages higher in the stack
 636        shadow those lower down.  This default algorithm can be overriden
 637        by giving explicit -package-id flags; then we have to take these
 638        preferences into account when selecting which other packages are
 639        made available.
 640
 641        Our simple algorithm throws away some solutions: there may be other
 642        consistent sets that would satisfy the -package flags, but it's
 643        not GHC's job to be doing constraint solving.
 644       ]
 645
 646    3. remove packages selected by -ignore-package
 647
 648    4. remove any packages with missing dependencies, or mutually recursive
 649       dependencies.
 650
 651    5. report (with -v) any packages that were removed by steps 2-4
 652
 653    6. apply flags to set exposed/hidden on the resulting packages
 654       - if any flag refers to a package which was removed by 2-4, then
 655         we can give an error message explaining why
 656
 657    7. hide any packages which are superseded by later exposed packages
 658 -}
 659
 660   let
 661       flags = reverse (packageFlags dflags)
 662
 663       -- pkgs0 with duplicate packages filtered out.  This is
 664       -- important: it is possible for a package in the global package
 665       -- DB to have the same IPID as a package in the user DB, and
 666       -- we want the latter to take precedence.  This is not the same
 667       -- as shadowing (below), since in this case the two packages
 668       -- have the same ABI and are interchangeable.
 669       --
 670       -- #4072: note that we must retain the ordering of the list here
 671       -- so that shadowing behaves as expected when we apply it later.
 672       pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0
 673           where del p (s,ps)
 674                   | pid `Set.member` s = (s,ps)
 675                   | otherwise          = (Set.insert pid s, p:ps)
 676                   where pid = installedPackageId p
 677           -- XXX this is just a variant of nub
 678
 679       ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]
 680
 681       ipid_selected = depClosure ipid_map [ InstalledPackageId i
 682                                           | ExposePackageId i <- flags ]
 683
 684       (ignore_flags, other_flags) = partition is_ignore flags
 685       is_ignore IgnorePackage{} = True
 686       is_ignore _ = False
 687
 688       shadowed = shadowPackages pkgs0_unique ipid_selected
 689
 690       ignored  = ignorePackages ignore_flags pkgs0_unique
 691
 692       pkgs0' = filter (not . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique
 693       broken   = findBroken pkgs0'
 694       unusable = shadowed `Map.union` ignored `Map.union` broken
 695
 696   reportUnusable dflags unusable
 697
 698   --
 699   -- Modify the package database according to the command-line flags
 700   -- (-package, -hide-package, -ignore-package, -hide-all-packages).
 701   --
 702   pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags
 703   let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1
 704
 705   -- Here we build up a set of the packages mentioned in -package
 706   -- flags on the command line; these are called the "preload"
 707   -- packages.  we link these packages in eagerly.  The preload set
 708   -- should contain at least rts & base, which is why we pretend that
 709   -- the command line contains -package rts & -package base.
 710   --
 711   let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]
 712
 713       get_exposed (ExposePackage   s) = filter (matchingStr s) pkgs2
 714       get_exposed (ExposePackageId s) = filter (matchingId  s) pkgs2
 715       get_exposed _                   = []
 716
 717   -- hide packages that are subsumed by later versions
 718   pkgs3 <- hideOldPackages dflags pkgs2
 719
 720   -- sort out which packages are wired in
 721   pkgs4 <- findWiredInPackages dflags pkgs3
 722
 723   let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4
 724
 725       ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
 726                               | p <- pkgs4 ]
 727
 728       lookupIPID ipid@(InstalledPackageId str)
 729          | Just pid <- Map.lookup ipid ipid_map = return pid
 730          | otherwise                            = missingPackageErr str
 731
 732   preload2 <- mapM lookupIPID preload1
 733
 734   let
 735       -- add base & rts to the preload packages
 736       basicLinkedPackages
 737        | dopt Opt_AutoLinkPackages dflags
 738           = filter (flip elemUFM pkg_db) [basePackageId, rtsPackageId]
 739        | otherwise = []
 740       -- but in any case remove the current package from the set of
 741       -- preloaded packages so that base/rts does not end up in the
 742       -- set up preloaded package when we are just building it
 743       preload3 = nub $ filter (/= this_package)
 744                      $ (basicLinkedPackages ++ preload2)
 745
 746   -- Close the preload packages with their dependencies
 747   dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing))
 748   let new_dep_preload = filter (`notElem` preload0) dep_preload
 749
 750   let pstate = PackageState{ preloadPackages     = dep_preload,
 751                              pkgIdMap            = pkg_db,
 752                              moduleToPkgConfAll  = mkModuleMap pkg_db,
 753                              installedPackageIdMap = ipid_map
 754                            }
 755
 756   return (pstate, new_dep_preload, this_package)
 757
 758
 759 -- -----------------------------------------------------------------------------
 760 -- Make the mapping from module to package info
 761
 762 mkModuleMap
 763   :: PackageConfigMap
 764   -> UniqFM [(PackageConfig, Bool)]
 765 mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids
 766   where
 767         pkgids = map packageConfigId (eltsUFM pkg_db)
 768
 769         extend_modmap pkgid modmap =
 770                 addListToUFM_C (++) modmap
 771                    ([(m, [(pkg, True)])  | m <- exposed_mods] ++
 772                     [(m, [(pkg, False)]) | m <- hidden_mods])
 773           where
 774                 pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid)
 775                 exposed_mods = exposedModules pkg
 776                 hidden_mods  = hiddenModules pkg
 777
 778 pprSPkg :: PackageConfig -> SDoc
 779 pprSPkg p = text (display (sourcePackageId p))
 780
 781 pprIPkg :: PackageConfig -> SDoc
 782 pprIPkg p = text (display (installedPackageId p))
 783
 784 -- -----------------------------------------------------------------------------
 785 -- Extracting information from the packages in scope
 786
 787 -- Many of these functions take a list of packages: in those cases,
 788 -- the list is expected to contain the "dependent packages",
 789 -- i.e. those packages that were found to be depended on by the
 790 -- current module/program.  These can be auto or non-auto packages, it
 791 -- doesn't really matter.  The list is always combined with the list
 792 -- of preload (command-line) packages to determine which packages to
 793 -- use.
 794
 795 -- | Find all the include directories in these and the preload packages
 796 getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String]
 797 getPackageIncludePath dflags pkgs =
 798   collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
 799
 800 collectIncludeDirs :: [PackageConfig] -> [FilePath]
 801 collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
 802
 803 -- | Find all the library paths in these and the preload packages
 804 getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String]
 805 getPackageLibraryPath dflags pkgs =
 806   collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
 807
 808 collectLibraryPaths :: [PackageConfig] -> [FilePath]
 809 collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
 810
 811 -- | Find all the link options in these and the preload packages
 812 getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String]
 813 getPackageLinkOpts dflags pkgs =
 814   collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
 815
 816 collectLinkOpts :: DynFlags -> [PackageConfig] -> [String]
 817 collectLinkOpts dflags ps = concat (map all_opts ps)
 818   where
 819         libs p     = packageHsLibs dflags p ++ extraLibraries p
 820         all_opts p = map ("-l" ++) (libs p) ++ ldOptions p
 821
 822 packageHsLibs :: DynFlags -> PackageConfig -> [String]
 823 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
 824   where
 825         ways0 = ways dflags
 826
 827         ways1 = filter ((/= WayDyn) . wayName) ways0
 828         -- the name of a shared library is libHSfoo-ghc<version>.so
 829         -- we leave out the _dyn, because it is superfluous
 830
 831         -- debug RTS includes support for -eventlog
 832         ways2 | WayDebug `elem` map wayName ways1
 833               = filter ((/= WayEventLog) . wayName) ways1
 834               | otherwise
 835               = ways1
 836
 837         tag     = mkBuildTag (filter (not . wayRTSOnly) ways2)
 838         rts_tag = mkBuildTag ways2
 839
 840         mkDynName | opt_Static = id
 841                   | otherwise = (++ ("-ghc" ++ cProjectVersion))
 842
 843         addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)
 844         addSuffix other_lib      = other_lib ++ (expandTag tag)
 845
 846         expandTag t | null t = ""
 847                     | otherwise = '_':t
 848
 849 -- | Find all the C-compiler options in these and the preload packages
 850 getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
 851 getPackageExtraCcOpts dflags pkgs = do
 852   ps <- getPreloadPackagesAnd dflags pkgs
 853   return (concatMap ccOptions ps)
 854
 855 -- | Find all the package framework paths in these and the preload packages
 856 getPackageFrameworkPath  :: DynFlags -> [PackageId] -> IO [String]
 857 getPackageFrameworkPath dflags pkgs = do
 858   ps <- getPreloadPackagesAnd dflags pkgs
 859   return (nub (filter notNull (concatMap frameworkDirs ps)))
 860
 861 -- | Find all the package frameworks in these and the preload packages
 862 getPackageFrameworks  :: DynFlags -> [PackageId] -> IO [String]
 863 getPackageFrameworks dflags pkgs = do
 864   ps <- getPreloadPackagesAnd dflags pkgs
 865   return (concatMap frameworks ps)
 866
 867 -- -----------------------------------------------------------------------------
 868 -- Package Utils
 869
 870 -- | Takes a 'Module', and if the module is in a package returns
 871 -- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package,
 872 -- and exposed is @True@ if the package exposes the module.
 873 lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)]
 874 lookupModuleInAllPackages dflags m =
 875   case lookupUFM (moduleToPkgConfAll (pkgState dflags)) m of
 876         Nothing -> []
 877         Just ps -> ps
 878
 879 -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
 880 -- 'PackageConfig's
 881 getPreloadPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig]
 882 getPreloadPackagesAnd dflags pkgids =
 883   let
 884       state   = pkgState dflags
 885       pkg_map = pkgIdMap state
 886       ipid_map = installedPackageIdMap state
 887       preload = preloadPackages state
 888       pairs = zip pkgids (repeat Nothing)
 889   in do
 890   all_pkgs <- throwErr (foldM (add_package pkg_map ipid_map) preload pairs)
 891   return (map (getPackageDetails state) all_pkgs)
 892
 893 -- Takes a list of packages, and returns the list with dependencies included,
 894 -- in reverse dependency order (a package appears before those it depends on).
 895 closeDeps :: PackageConfigMap
 896           -> Map InstalledPackageId PackageId
 897           -> [(PackageId, Maybe PackageId)]
 898           -> IO [PackageId]
 899 closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps)
 900
 901 throwErr :: MaybeErr Message a -> IO a
 902 throwErr m = case m of
 903                 Failed e    -> ghcError (CmdLineError (showSDoc e))
 904                 Succeeded r -> return r
 905
 906 closeDepsErr :: PackageConfigMap
 907              -> Map InstalledPackageId PackageId
 908              -> [(PackageId,Maybe PackageId)]
 909              -> MaybeErr Message [PackageId]
 910 closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
 911
 912 -- internal helper
 913 add_package :: PackageConfigMap
 914             -> Map InstalledPackageId PackageId
 915             -> [PackageId]
 916             -> (PackageId,Maybe PackageId)
 917             -> MaybeErr Message [PackageId]
 918 add_package pkg_db ipid_map ps (p, mb_parent)
 919   | p `elem` ps = return ps     -- Check if we've already added this package
 920   | otherwise =
 921       case lookupPackage pkg_db p of
 922         Nothing -> Failed (missingPackageMsg (packageIdString p) <>
 923                            missingDependencyMsg mb_parent)
 924         Just pkg -> do
 925            -- Add the package's dependents also
 926            ps' <- foldM add_package_ipid ps (depends pkg)
 927            return (p : ps')
 928           where
 929             add_package_ipid ps ipid@(InstalledPackageId str)
 930               | Just pid <- Map.lookup ipid ipid_map
 931               = add_package pkg_db ipid_map ps (pid, Just p)
 932               | otherwise
 933               = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent)
 934
 935 missingPackageErr :: String -> IO a
 936 missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p)))
 937
 938 missingPackageMsg :: String -> SDoc
 939 missingPackageMsg p = ptext (sLit "unknown package:") <+> text p
 940
 941 missingDependencyMsg :: Maybe PackageId -> SDoc
 942 missingDependencyMsg Nothing = empty
 943 missingDependencyMsg (Just parent)
 944   = space <> parens (ptext (sLit "dependency of") <+> ftext (packageIdFS parent))
 945
 946 -- -----------------------------------------------------------------------------
 947
 948 -- | Will the 'Name' come from a dynamically linked library?
 949 isDllName :: PackageId -> Name -> Bool
 950 isDllName this_pkg name
 951   | opt_Static = False
 952   | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg
 953   | otherwise = False  -- no, it is not even an external name
 954
 955 -- -----------------------------------------------------------------------------
 956 -- Displaying packages
 957
 958 -- | Show package info on console, if verbosity is >= 3
 959 dumpPackages :: DynFlags -> IO ()
 960 dumpPackages dflags
 961   = do  let pkg_map = pkgIdMap (pkgState dflags)
 962         putMsg dflags $
 963               vcat (map (text . showInstalledPackageInfo
 964                               . packageConfigToInstalledPackageInfo)
 965                         (eltsUFM pkg_map))
 966 \end{code}