Packages.lhs 41.8 KB
Newer Older
1
%
2
% (c) The University of Glasgow, 2006
3 4
%
\begin{code}
5
-- | Package manipulation
6
module Packages (
7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26
        module PackageConfig,

        -- * The PackageConfigMap
        PackageConfigMap, emptyPackageConfigMap, lookupPackage,
        extendPackageConfigMap, dumpPackages,

        -- * Reading the package config, and processing cmdline args
        PackageState(..),
        initPackages,
        getPackageDetails,
        lookupModuleInAllPackages, lookupModuleWithSuggestions,

        -- * Inspecting the set of packages in scope
        getPackageIncludePath,
        getPackageLibraryPath,
        getPackageLinkOpts,
        getPackageExtraCcOpts,
        getPackageFrameworkPath,
        getPackageFrameworks,
        getPreloadPackagesAnd,
27

28
        collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
29
        packageHsLibs,
30

31 32
        -- * Utils
        isDllName
33
    )
34 35 36
where

#include "HsVersions.h"
37

38
import PackageConfig
39
import DynFlags
40
import StaticFlags
41 42
import Config           ( cProjectVersion )
import Name             ( Name, nameModule_maybe )
43
import UniqFM
44
import Module
45 46 47
import Util
import Panic
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, MsgDoc )
56
import Exception
57

Simon Marlow's avatar
Simon Marlow committed
58
import System.Directory
59 60
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
Simon Marlow's avatar
Simon Marlow committed
61
import Control.Monad
62
import Data.List as List
63 64 65
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
66
import qualified Data.Set as Set
Simon Marlow's avatar
Simon Marlow committed
67

68 69 70
-- ---------------------------------------------------------------------------
-- The Package state

71
-- | Package state is all stored in 'DynFlag's, including the details of
72 73 74
-- all packages, which packages are exposed, and which modules they
-- provide.
--
75 76
-- The package state is computed by 'initPackages', and kept in DynFlags.
--
77 78 79
--   * @-package <pkg>@ causes @<pkg>@ to become exposed, and all other packages
--      with the same name to become hidden.
--
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 85
--     their dependencies.
--
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 94
--     program depends on (the compiler knows this list by the
--     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,
Ian Lynagh's avatar
Ian Lynagh committed
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 99 100 101 102
--     contain any Haskell modules, and therefore won't be discovered
--     by the normal mechanism of dependency tracking.

-- Notes on DLLs
-- ~~~~~~~~~~~~~
103 104 105 106
-- When compiling module A, which imports module B, we need to
-- know whether B will be in the same DLL as A.
--      If it's in the same DLL, we refer to B_f_closure
--      If it isn't, we refer to _imp__B_f_closure
107 108 109 110
-- When compiling A, we record in B's Module value whether it's
-- in a different DLL, by setting the DLL flag.

data PackageState = PackageState {
111 112 113
  pkgIdMap              :: PackageConfigMap, -- PackageId   -> PackageConfig
        -- The exposed flags are adjusted according to -package and
        -- -hide-package flags, and -ignore-package removes packages.
114

115
  preloadPackages      :: [PackageId],
116 117 118
        -- The packages we're going to link in eagerly.  This list
        -- should be in reverse dependency order; that is, a package
        -- is always mentioned before the packages it depends on.
119

120 121 122 123 124
  moduleToPkgConfAll    :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping
        -- Derived from pkgIdMap.
        -- Maps Module to (pkgconf,exposed), where pkgconf is the
        -- PackageConfig for the package containing the module, and
        -- 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 131
type PackageConfigMap = UniqFM PackageConfig

132
type InstalledPackageIdMap = Map InstalledPackageId PackageId
133

134
type InstalledPackageIndex = Map InstalledPackageId PackageConfig
135

136 137 138
emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap = emptyUFM

139
-- | Find the package we know about with the given id (e.g. \"foo-1.0\"), if any
140 141 142 143 144
lookupPackage :: PackageConfigMap -> PackageId -> Maybe PackageConfig
lookupPackage = lookupUFM

extendPackageConfigMap
   :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
145
extendPackageConfigMap pkg_map new_pkgs
146 147 148
  = foldl add pkg_map new_pkgs
  where add pkg_map p = addToUFM pkg_map (packageConfigId p) p

149 150
-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
151
getPackageDetails :: PackageState -> PackageId -> PackageConfig
Ian Lynagh's avatar
Ian Lynagh committed
152
getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid)
153 154

-- ----------------------------------------------------------------------------
155
-- Loading the package db files and building up the package state
156

157
-- | Call this after 'DynFlags.parseDynFlags'.  It reads the package
158
-- database files, and sets up various internal tables of package
159 160
-- information, according to the package-related flags on the
-- command-line (@-package@, @-hide-package@ etc.)
161 162 163
--
-- Returns a list of packages to link in if we're doing dynamic linking.
-- This list contains the packages that the user explicitly mentioned with
164
-- @-package@ flags.
165 166 167
--
-- 'initPackages' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
168
-- 'pkgState' in 'DynFlags' and return a list of packages to
169 170
-- link in.
initPackages :: DynFlags -> IO (DynFlags, [PackageId])
171
initPackages dflags = do
172 173
  pkg_db <- case pkgDatabase dflags of
                Nothing -> readPackageConfigs dflags
174
                Just db -> return $ setBatchPackageFlags 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 180
                  thisPackage = this_pkg },
          preload)
181 182

-- -----------------------------------------------------------------------------
183 184
-- Reading the package database(s)

185
readPackageConfigs :: DynFlags -> IO [PackageConfig]
186
readPackageConfigs dflags = do
187
  let -- Read global package db, unless the -no-user-package-db flag was given
188 189
      global_conf_refs = [GlobalPkgConf | dopt Opt_ReadGlobalPackageConf dflags]
      -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
190
      -- unless the -no-user-package-db flag was given.
191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
      user_conf_refs = [UserPkgConf | dopt Opt_ReadUserPackageConf dflags]

      system_conf_refs = global_conf_refs ++ user_conf_refs

  e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH")
  let base_conf_refs = case e_pkg_path of
        Left _ -> system_conf_refs
        Right path
         | null (last cs)
         -> map PkgConfFile (init cs) ++ system_conf_refs
         | otherwise
         -> map PkgConfFile cs
         where cs = parseSearchPath path
         -- if the path ends in a separator (eg. "/foo/bar:")
         -- the we tack on the base paths.

  let conf_refs = base_conf_refs ++ reverse (extraPkgConfs dflags)
  -- later packages shadow earlier ones.  extraPkgConfs
  -- is in the opposite order to the flags on the
  -- command line.
  confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs

  liftM concat $ mapM (readPackageConfig dflags) confs

resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
resolvePackageConfig _ UserPkgConf = handleIO (\_ -> return Nothing) $ do
  appdir <- getAppUserDataDirectory "ghc"
  let dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
      pkgconf = dir </> "package.conf.d"
  exist <- doesDirectoryExist pkgconf
  return $ if exist then Just pkgconf else Nothing
resolvePackageConfig _ (PkgConfFile name) = return $ Just name
224

225 226
readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
readPackageConfig dflags conf_file = do
227 228
  isdir <- doesDirectoryExist conf_file

229
  proto_pkg_configs <-
230 231 232 233 234 235
    if isdir
       then do let filename = conf_file </> "package.cache"
               debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
               conf <- readBinPackageDB filename
               return (map installedPackageInfoToPackageConfig conf)

236
       else do
237 238
            isfile <- doesFileExist conf_file
            when (not isfile) $
239
              ghcError $ InstallationError $
240 241
                "can't find a package database at " ++ conf_file
            debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
242 243
            str <- readFile conf_file
            return (map installedPackageInfoToPackageConfig $ read str)
244

245 246
  let
      top_dir = topDir dflags
247 248
      pkgroot = takeDirectory conf_file
      pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
249
      pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
250 251
  --
  return pkg_configs2
252

253 254
setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs
255
  where
256 257 258 259 260 261 262 263
    maybeHideAll pkgs'
      | dopt Opt_HideAllPackages dflags = map hide pkgs'
      | otherwise                       = pkgs'

    maybeDistrustAll pkgs'
      | dopt Opt_DistrustAllPackages dflags = map distrust pkgs'
      | otherwise                           = pkgs'

264
    hide pkg = pkg{ exposed = False }
dterei's avatar
dterei committed
265
    distrust pkg = pkg{ trusted = False }
266

267
-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285
mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
--
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
mungePackagePaths top_dir pkgroot pkg =
    pkg {
      importDirs  = munge_paths (importDirs pkg),
      includeDirs = munge_paths (includeDirs pkg),
      libraryDirs = munge_paths (libraryDirs pkg),
      frameworkDirs = munge_paths (frameworkDirs pkg),
      haddockInterfaces = munge_paths (haddockInterfaces pkg),
      haddockHTMLs = munge_urls (haddockHTMLs pkg)
    }
286
  where
287 288 289 290
    munge_paths = map munge_path
    munge_urls  = map munge_url

    munge_path p
291 292 293
      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
      | otherwise                                = p
294 295

    munge_url p
296 297 298
      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
      | otherwise                                   = p
299 300 301

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
302 303 304 305 306 307 308 309 310 311 312 313 314
                 ++ FilePath.Posix.joinPath
                        (r : -- We need to drop a leading "/" or "\\"
                             -- if there is one:
                             dropWhile (all isPathSeparator)
                                       (FilePath.splitDirectories p))

    -- We could drop the separator here, and then use </> above. However,
    -- by leaving it in and using ++ we keep the same path separator
    -- rather than letting FilePath change it to use \ as the separator
    stripVarPrefix var path = case stripPrefix var path of
                              Just [] -> Just []
                              Just cs@(c : _) | isPathSeparator c -> Just cs
                              _ -> Nothing
315

316

317
-- -----------------------------------------------------------------------------
318 319 320 321
-- Modify our copy of the package database based on a package flag
-- (-package, -hide-package, -ignore-package).

applyPackageFlag
322 323
   :: UnusablePackages
   -> [PackageConfig]           -- Initial database
324 325 326
   -> PackageFlag               -- flag to apply
   -> IO [PackageConfig]        -- new database

327
applyPackageFlag unusable pkgs flag =
328
  case flag of
329 330 331 332
    ExposePackage str ->
       case selectPackages (matchingStr str) pkgs unusable of
         Left ps         -> packageFlagErr flag ps
         Right (p:ps,qs) -> return (p':ps')
333 334
          where p' = p {exposed=True}
                ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
335 336 337 338 339 340
         _ -> panic "applyPackageFlag"

    ExposePackageId str ->
       case selectPackages (matchingId str) pkgs unusable of
         Left ps         -> packageFlagErr flag ps
         Right (p:ps,qs) -> return (p':ps')
341 342
          where p' = p {exposed=True}
                ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
343 344 345 346 347 348
         _ -> panic "applyPackageFlag"

    HidePackage str ->
       case selectPackages (matchingStr str) pkgs unusable of
         Left ps       -> packageFlagErr flag ps
         Right (ps,qs) -> return (map hide ps ++ qs)
349
          where hide p = p {exposed=False}
350

351 352 353 354 355 356
    -- we trust all matching packages. Maybe should only trust first one?
    -- and leave others the same or set them untrusted
    TrustPackage str ->
       case selectPackages (matchingStr str) pkgs unusable of
         Left ps       -> packageFlagErr flag ps
         Right (ps,qs) -> return (map trust ps ++ qs)
357
          where trust p = p {trusted=True}
358 359 360 361 362

    DistrustPackage str ->
       case selectPackages (matchingStr str) pkgs unusable of
         Left ps       -> packageFlagErr flag ps
         Right (ps,qs) -> return (map distrust ps ++ qs)
363
          where distrust p = p {trusted=False}
364

365 366
    _ -> panic "applyPackageFlag"

367
   where
368 369 370 371
        -- When a package is requested to be exposed, we hide all other
        -- packages with the same name.
        hideAll name ps = map maybe_hide ps
          where maybe_hide p
372 373
                   | pkgName (sourcePackageId p) == name = p {exposed=False}
                   | otherwise                           = p
374

375

376 377 378 379 380 381 382
selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
               -> UnusablePackages
               -> Either [(PackageConfig, UnusablePackageReason)]
                  ([PackageConfig], [PackageConfig])
selectPackages matches pkgs unusable
  = let
        (ps,rest) = partition matches pkgs
383
        reasons = [ (p, Map.lookup (installedPackageId p) unusable)
384 385 386 387 388
                  | p <- ps ]
    in
    if all (isJust.snd) reasons
       then Left  [ (p, reason) | (p,Just reason) <- reasons ]
       else Right (sortByVersion [ p | (p,Nothing) <- reasons ], rest)
389 390 391

-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
392 393
matchingStr :: String -> PackageConfig -> Bool
matchingStr str p
394 395
        =  str == display (sourcePackageId p)
        || str == display (pkgName (sourcePackageId p))
396

397 398
matchingId :: String -> PackageConfig -> Bool
matchingId str p =  InstalledPackageId str == installedPackageId p
399

Ian Lynagh's avatar
Ian Lynagh committed
400
sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m]
401
sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId)))
Ian Lynagh's avatar
Ian Lynagh committed
402 403

comparing :: Ord a => (t -> a) -> t -> t -> Ordering
404 405
comparing f a b = f a `compare` f b

406 407 408
packageFlagErr :: PackageFlag
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
409 410 411 412 413 414 415 416

-- for missing DPH package we emit a more helpful error message, because
-- this may be the result of using -fdph-par or -fdph-seq.
packageFlagErr (ExposePackage pkg) [] | is_dph_package pkg
  = ghcError (CmdLineError (showSDoc $ dph_err))
  where dph_err = text "the " <> text pkg <> text " package is not installed."
                  $$ text "To install it: \"cabal install dph\"."
        is_dph_package pkg = "dph" `isPrefixOf` pkg
417

418
packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err))
419
  where err = text "cannot satisfy " <> ppr_flag <>
420 421 422 423 424 425 426 427
                (if null reasons then empty else text ": ") $$
              nest 4 (ppr_reasons $$
                      text "(use -v for more information)")
        ppr_flag = case flag of
                     IgnorePackage p -> text "-ignore-package " <> text p
                     HidePackage p   -> text "-hide-package " <> text p
                     ExposePackage p -> text "-package " <> text p
                     ExposePackageId p -> text "-package-id " <> text p
428 429
                     TrustPackage p    -> text "-trust " <> text p
                     DistrustPackage p -> text "-distrust " <> text p
430 431 432
        ppr_reasons = vcat (map ppr_reason reasons)
        ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason

433 434 435 436 437 438 439 440 441 442 443 444
-- -----------------------------------------------------------------------------
-- Hide old versions of packages

--
-- hide all packages for which there is also a later version
-- that is already exposed.  This just makes it non-fatal to have two
-- versions of a package exposed, which can happen if you install a
-- later version of a package in the user database, for example.
--
hideOldPackages :: DynFlags -> [PackageConfig] -> IO [PackageConfig]
hideOldPackages dflags pkgs = mapM maybe_hide pkgs
  where maybe_hide p
445 446 447 448 449 450 451 452 453 454 455 456 457 458
           | not (exposed p) = return p
           | (p' : _) <- later_versions = do
                debugTraceMsg dflags 2 $
                   (ptext (sLit "hiding package") <+> pprSPkg p <+>
                    ptext (sLit "to avoid conflict with later version") <+>
                    pprSPkg p')
                return (p {exposed=False})
           | otherwise = return p
          where myname = pkgName (sourcePackageId p)
                myversion = pkgVersion (sourcePackageId p)
                later_versions = [ p | p <- pkgs, exposed p,
                                       let pkg = sourcePackageId p,
                                       pkgName pkg == myname,
                                       pkgVersion pkg > myversion ]
459

460 461 462 463 464 465
-- -----------------------------------------------------------------------------
-- Wired-in packages

findWiredInPackages
   :: DynFlags
   -> [PackageConfig]           -- database
466
   -> IO [PackageConfig]
467

468
findWiredInPackages dflags pkgs = do
Simon Marlow's avatar
Simon Marlow committed
469 470 471 472 473
  --
  -- Now we must find our wired-in packages, and rename them to
  -- their canonical names (eg. base-1.0 ==> base).
  --
  let
474 475 476 477 478 479 480 481 482 483 484
        wired_in_pkgids :: [String]
        wired_in_pkgids = map packageIdString
                          [ primPackageId,
                            integerPackageId,
                            basePackageId,
                            rtsPackageId,
                            thPackageId,
                            dphSeqPackageId,
                            dphParPackageId ]

        matches :: PackageConfig -> String -> Bool
485
        pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid
Simon Marlow's avatar
Simon Marlow committed
486

487 488 489 490
        -- find which package corresponds to each wired-in package
        -- delete any other packages with the same name
        -- update the package and any dependencies to point to the new
        -- one.
491 492 493 494 495 496
        --
        -- When choosing which package to map to a wired-in package
        -- name, we prefer exposed packages, and pick the latest
        -- version.  To override the default choice, -hide-package
        -- could be used to hide newer versions.
        --
497 498 499
        findWiredInPackage :: [PackageConfig] -> String
                           -> IO (Maybe InstalledPackageId)
        findWiredInPackage pkgs wired_pkg =
500
           let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
501 502 503
           case all_ps of
                []   -> notfound
                many -> pick (head (sortByVersion many))
504 505
          where
                notfound = do
506 507 508 509 510 511
                          debugTraceMsg dflags 2 $
                            ptext (sLit "wired-in package ")
                                 <> text wired_pkg
                                 <> ptext (sLit " not found.")
                          return Nothing
                pick :: InstalledPackageInfo_ ModuleName
512
                     -> IO (Maybe InstalledPackageId)
513 514
                pick pkg = do
                        debugTraceMsg dflags 2 $
515 516 517 518 519
                            ptext (sLit "wired-in package ")
                                 <> text wired_pkg
                                 <> ptext (sLit " mapped to ")
                                 <> pprIPkg pkg
                        return (Just (installedPackageId pkg))
520

Simon Marlow's avatar
Simon Marlow committed
521

522
  mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids
523
  let
Simon Marlow's avatar
Simon Marlow committed
524 525
        wired_in_ids = catMaybes mb_wired_in_ids

526 527 528 529 530 531 532 533
        -- this is old: we used to assume that if there were
        -- multiple versions of wired-in packages installed that
        -- they were mutually exclusive.  Now we're assuming that
        -- you have one "main" version of each wired-in package
        -- (the latest version), and the others are backward-compat
        -- wrappers that depend on this one.  e.g. base-4.0 is the
        -- latest, base-3.0 is a compat wrapper depending on base-4.0.
        {-
534 535
        deleteOtherWiredInPackages pkgs = filterOut bad pkgs
          where bad p = any (p `matches`) wired_in_pkgids
536 537
                      && package p `notElem` map fst wired_in_ids
        -}
Simon Marlow's avatar
Simon Marlow committed
538

539 540
        updateWiredInDependencies pkgs = map upd_pkg pkgs
          where upd_pkg p
541
                  | installedPackageId p `elem` wired_in_ids
542
                  = p { sourcePackageId = (sourcePackageId p){ pkgVersion = Version [] [] } }
543 544
                  | otherwise
                  = p
Simon Marlow's avatar
Simon Marlow committed
545

546
  return $ updateWiredInDependencies pkgs
547

548 549 550 551 552 553 554
-- ----------------------------------------------------------------------------

data UnusablePackageReason
  = IgnoredWithFlag
  | MissingDependencies [InstalledPackageId]
  | ShadowedBy InstalledPackageId

555
type UnusablePackages = Map InstalledPackageId UnusablePackageReason
556 557 558 559 560 561 562 563 564 565 566 567 568

pprReason :: SDoc -> UnusablePackageReason -> SDoc
pprReason pref reason = case reason of
  IgnoredWithFlag ->
      pref <+> ptext (sLit "ignored due to an -ignore-package flag")
  MissingDependencies deps ->
      pref <+>
      ptext (sLit "unusable due to missing or recursive dependencies:") $$
        nest 2 (hsep (map (text.display) deps))
  ShadowedBy ipid ->
      pref <+> ptext (sLit "shadowed by package ") <> text (display ipid)

reportUnusable :: DynFlags -> UnusablePackages -> IO ()
569
reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
570 571 572 573 574 575 576
  where
    report (ipid, reason) =
       debugTraceMsg dflags 2 $
         pprReason
           (ptext (sLit "package") <+>
            text (display ipid) <+> text "is") reason

577
-- ----------------------------------------------------------------------------
578
--
579 580 581 582 583
-- Detect any packages that have missing dependencies, and also any
-- mutually-recursive groups of packages (loops in the package graph
-- are not allowed).  We do this by taking the least fixpoint of the
-- dependency graph, repeatedly adding packages whose dependencies are
-- satisfied until no more can be added.
584
--
585
findBroken :: [PackageConfig] -> UnusablePackages
586
findBroken pkgs = go [] Map.empty pkgs
587
 where
588 589 590
   go avail ipids not_avail =
     case partitionWith (depsAvailable ipids) not_avail of
        ([], not_avail) ->
591 592
            Map.fromList [ (installedPackageId p, MissingDependencies deps)
                         | (p,deps) <- not_avail ]
593 594
        (new_avail, not_avail) ->
            go (new_avail ++ avail) new_ipids (map fst not_avail)
595
            where new_ipids = Map.insertList
596
                                [ (installedPackageId p, p) | p <- new_avail ]
597
                                ipids
598

599
   depsAvailable :: InstalledPackageIndex
600
                 -> PackageConfig
601
                 -> Either PackageConfig (PackageConfig, [InstalledPackageId])
602
   depsAvailable ipids pkg
603 604
        | null dangling = Left pkg
        | otherwise     = Right (pkg, dangling)
605
        where dangling = filter (not . (`Map.member` ipids)) (depends pkg)
606

607 608 609 610
-- -----------------------------------------------------------------------------
-- Eliminate shadowed packages, giving the user some feedback

-- later packages in the list should shadow earlier ones with the same
611 612 613 614 615 616
-- package name/version.  Additionally, a package may be preferred if
-- it is in the transitive closure of packages selected using -package-id
-- flags.
shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
shadowPackages pkgs preferred
 = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
617
   in  Map.fromList shadowed
618
 where
619
 check (shadowed,pkgmap) pkg
620 621
      | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)
      , let
622
            ipid_new = installedPackageId pkg
623
            ipid_old = installedPackageId oldpkg
624
        --
625
      , ipid_old /= ipid_new
626
      = if ipid_old `elem` preferred
627 628
           then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap )
           else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' )
629
      | otherwise
630 631 632
      = (shadowed, pkgmap')
      where
        pkgmap' = addToUFM pkgmap (packageConfigId pkg) pkg
633 634 635 636

-- -----------------------------------------------------------------------------

ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
637
ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
638 639 640 641 642
  where
  doit (IgnorePackage str) =
     case partition (matchingStr str) pkgs of
         (ps, _) -> [ (installedPackageId p, IgnoredWithFlag)
                    | p <- ps ]
643 644 645
        -- missing package is not an error for -ignore-package,
        -- because a common usage is to -ignore-package P as
        -- a preventative measure just in case P exists.
646
  doit _ = panic "ignorePackages"
647

648 649 650 651 652
-- -----------------------------------------------------------------------------

depClosure :: InstalledPackageIndex
           -> [InstalledPackageId]
           -> [InstalledPackageId]
653
depClosure index ipids = closure Map.empty ipids
654
  where
655
   closure set [] = Map.keys set
656
   closure set (ipid : ipids)
657
     | ipid `Map.member` set = closure set ipids
658
     | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set)
659
                                                 (depends p ++ ipids)
660 661
     | otherwise = closure set ipids

662 663 664 665 666 667
-- -----------------------------------------------------------------------------
-- When all the command-line options are in, we can process our package
-- settings and populate the package state.

mkPackageState
    :: DynFlags
668
    -> [PackageConfig]          -- initial database
669 670 671 672 673 674 675
    -> [PackageId]              -- preloaded packages
    -> PackageId                -- this package
    -> IO (PackageState,
           [PackageId],         -- new packages to preload
           PackageId) -- this package, might be modified if the current
                      -- package is a wired-in package.

676 677
mkPackageState dflags pkgs0 preload0 this_package = do

678 679 680
{-
   Plan.

681
   1. P = transitive closure of packages selected by -package-id
682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715

   2. Apply shadowing.  When there are multiple packages with the same
      sourcePackageId,
        * if one is in P, use that one
        * otherwise, use the one highest in the package stack
      [
       rationale: we cannot use two packages with the same sourcePackageId
       in the same program, because sourcePackageId is the symbol prefix.
       Hence we must select a consistent set of packages to use.  We have
       a default algorithm for doing this: packages higher in the stack
       shadow those lower down.  This default algorithm can be overriden
       by giving explicit -package-id flags; then we have to take these
       preferences into account when selecting which other packages are
       made available.

       Our simple algorithm throws away some solutions: there may be other
       consistent sets that would satisfy the -package flags, but it's
       not GHC's job to be doing constraint solving.
      ]

   3. remove packages selected by -ignore-package

   4. remove any packages with missing dependencies, or mutually recursive
      dependencies.

   5. report (with -v) any packages that were removed by steps 2-4

   6. apply flags to set exposed/hidden on the resulting packages
      - if any flag refers to a package which was removed by 2-4, then
        we can give an error message explaining why

   7. hide any packages which are superseded by later exposed packages
-}

716
  let
717
      flags = reverse (packageFlags dflags)
718

719
      -- pkgs0 with duplicate packages filtered out.  This is
720 721 722
      -- important: it is possible for a package in the global package
      -- DB to have the same IPID as a package in the user DB, and
      -- we want the latter to take precedence.  This is not the same
723 724
      -- as shadowing (below), since in this case the two packages
      -- have the same ABI and are interchangeable.
725 726 727 728 729 730 731 732 733 734
      --
      -- #4072: note that we must retain the ordering of the list here
      -- so that shadowing behaves as expected when we apply it later.
      pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0
          where del p (s,ps)
                  | pid `Set.member` s = (s,ps)
                  | otherwise          = (Set.insert pid s, p:ps)
                  where pid = installedPackageId p
          -- XXX this is just a variant of nub

735
      ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]
736

737 738
      ipid_selected = depClosure ipid_map [ InstalledPackageId i
                                          | ExposePackageId i <- flags ]
739

740 741 742 743
      (ignore_flags, other_flags) = partition is_ignore flags
      is_ignore IgnorePackage{} = True
      is_ignore _ = False

744
      shadowed = shadowPackages pkgs0_unique ipid_selected
745

746
      ignored  = ignorePackages ignore_flags pkgs0_unique
747

748
      pkgs0' = filter (not . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique
749
      broken   = findBroken pkgs0'
750
      unusable = shadowed `Map.union` ignored `Map.union` broken
751 752 753

  reportUnusable dflags unusable

754
  --
755 756
  -- Modify the package database according to the command-line flags
  -- (-package, -hide-package, -ignore-package, -hide-all-packages).
757
  --
758
  pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags
759
  let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1
760 761 762 763 764 765

  -- Here we build up a set of the packages mentioned in -package
  -- flags on the command line; these are called the "preload"
  -- packages.  we link these packages in eagerly.  The preload set
  -- should contain at least rts & base, which is why we pretend that
  -- the command line contains -package rts & -package base.
766
  --
767 768 769 770 771
  let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]

      get_exposed (ExposePackage   s) = filter (matchingStr s) pkgs2
      get_exposed (ExposePackageId s) = filter (matchingId  s) pkgs2
      get_exposed _                   = []
772 773

  -- hide packages that are subsumed by later versions
774
  pkgs3 <- hideOldPackages dflags pkgs2
775 776

  -- sort out which packages are wired in
777
  pkgs4 <- findWiredInPackages dflags pkgs3
778

779
  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4
780

781 782
      ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
                              | p <- pkgs4 ]
783 784

      lookupIPID ipid@(InstalledPackageId str)
785 786
         | Just pid <- Map.lookup ipid ipid_map = return pid
         | otherwise                            = missingPackageErr str
787 788 789 790

  preload2 <- mapM lookupIPID preload1

  let
791
      -- add base & rts to the preload packages
792
      basicLinkedPackages
793
       | dopt Opt_AutoLinkPackages dflags
794 795
          = filter (flip elemUFM pkg_db) [basePackageId, rtsPackageId]
       | otherwise = []
796 797 798
      -- but in any case remove the current package from the set of
      -- preloaded packages so that base/rts does not end up in the
      -- set up preloaded package when we are just building it
799 800
      preload3 = nub $ filter (/= this_package)
                     $ (basicLinkedPackages ++ preload2)
801

802
  -- Close the preload packages with their dependencies
803
  dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing))
804 805 806
  let new_dep_preload = filter (`notElem` preload0) dep_preload

  let pstate = PackageState{ preloadPackages     = dep_preload,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
807 808
                             pkgIdMap            = pkg_db,
                             moduleToPkgConfAll  = mkModuleMap pkg_db,
809
                             installedPackageIdMap = ipid_map
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
810
                           }
Simon Marlow's avatar
Simon Marlow committed
811

812
  return (pstate, new_dep_preload, this_package)
813

814

815 816
-- -----------------------------------------------------------------------------
-- Make the mapping from module to package info
817

818 819
mkModuleMap
  :: PackageConfigMap
Simon Marlow's avatar
Simon Marlow committed
820
  -> UniqFM [(PackageConfig, Bool)]
821
mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids
822
  where
823
        pkgids = map packageConfigId (eltsUFM pkg_db)
824 825 826 827 828 829 830 831 832

        extend_modmap pkgid modmap =
                addListToUFM_C (++) modmap
                   ([(m, [(pkg, True)])  | m <- exposed_mods] ++
                    [(m, [(pkg, False)]) | m <- hidden_mods])
          where
                pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid)
                exposed_mods = exposedModules pkg
                hidden_mods  = hiddenModules pkg
833

834 835 836 837 838
pprSPkg :: PackageConfig -> SDoc
pprSPkg p = text (display (sourcePackageId p))

pprIPkg :: PackageConfig -> SDoc
pprIPkg p = text (display (installedPackageId p))
839

840
-- -----------------------------------------------------------------------------
841
-- Extracting information from the packages in scope
842

843 844 845 846 847
-- Many of these functions take a list of packages: in those cases,
-- the list is expected to contain the "dependent packages",
-- i.e. those packages that were found to be depended on by the
-- current module/program.  These can be auto or non-auto packages, it
-- doesn't really matter.  The list is always combined with the list
848
-- of preload (command-line) packages to determine which packages to
849
-- use.
850

851
-- | Find all the include directories in these and the preload packages
852
getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String]
853 854 855
getPackageIncludePath dflags pkgs =
  collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs

856
collectIncludeDirs :: [PackageConfig] -> [FilePath]
857
collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
858

859
-- | Find all the library paths in these and the preload packages
860
getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String]
861 862 863 864 865
getPackageLibraryPath dflags pkgs =
  collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs

collectLibraryPaths :: [PackageConfig] -> [FilePath]
collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
866

867
-- | Find all the link options in these and the preload packages
868
getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String]
869
getPackageLinkOpts dflags pkgs =
870 871 872 873
  collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs

collectLinkOpts :: DynFlags -> [PackageConfig] -> [String]
collectLinkOpts dflags ps = concat (map all_opts ps)
874
  where
875 876
        libs p     = packageHsLibs dflags p ++ extraLibraries p
        all_opts p = map ("-l" ++) (libs p) ++ ldOptions p
877 878 879

packageHsLibs :: DynFlags -> PackageConfig -> [String]
packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
880
  where
881 882 883
        ways0 = ways dflags

        ways1 = filter ((/= WayDyn) . wayName) ways0
884 885 886
        -- the name of a shared library is libHSfoo-ghc<version>.so
        -- we leave out the _dyn, because it is superfluous

887
        -- debug RTS includes support for -eventlog
888
        ways2 | WayDebug `elem` map wayName ways1
889
              = filter ((/= WayEventLog) . wayName) ways1
890 891 892 893 894
              | otherwise
              = ways1

        tag     = mkBuildTag (filter (not . wayRTSOnly) ways2)
        rts_tag = mkBuildTag ways2
895

896 897
        mkDynName | opt_Static = id
                  | otherwise = (++ ("-ghc" ++ cProjectVersion))
898

899 900
        addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)
        addSuffix other_lib      = other_lib ++ (expandTag tag)
901

902
        expandTag t | null t = ""
903
                    | otherwise = '_':t
904

905
-- | Find all the C-compiler options in these and the preload packages
906 907
getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
getPackageExtraCcOpts dflags pkgs = do
908
  ps <- getPreloadPackagesAnd dflags pkgs
909
  return (concatMap ccOptions ps)
910

911
-- | Find all the package framework paths in these and the preload packages
912 913
getPackageFrameworkPath  :: DynFlags -> [PackageId] -> IO [String]
getPackageFrameworkPath dflags pkgs = do
914
  ps <- getPreloadPackagesAnd dflags pkgs
915 916
  return (nub (filter notNull (concatMap frameworkDirs ps)))

917
-- | Find all the package frameworks in these and the preload packages
918 919
getPackageFrameworks  :: DynFlags -> [PackageId] -> IO [String]
getPackageFrameworks dflags pkgs = do
920
  ps <- getPreloadPackagesAnd dflags pkgs
921
  return (concatMap frameworks ps)
922 923 924

-- -----------------------------------------------------------------------------
-- Package Utils
925

926
-- | Takes a 'Module', and if the module is in a package returns
927 928
-- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package,
-- and exposed is @True@ if the package exposes the module.
Simon Marlow's avatar
Simon Marlow committed
929
lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)]
930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950