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