compiler/main/Packages.lhs

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