Packages.lhs 40.9 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
	module PackageConfig,

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

	-- * Reading the package config, and processing cmdline args
14
	PackageState(..),
15 16
	initPackages,
	getPackageDetails,
17
        lookupModuleInAllPackages, lookupModuleWithSuggestions,
18

19 20 21 22 23 24 25
	-- * Inspecting the set of packages in scope
	getPackageIncludePath,
	getPackageLibraryPath,
	getPackageLinkOpts,
	getPackageExtraCcOpts,
	getPackageFrameworkPath,
	getPackageFrameworks,
26
	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
import Config		( cProjectVersion )
42
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, Message )
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 77
-- The package state is computed by 'initPackages', and kept in DynFlags.
--
--   * @-package <pkg>@ causes @<pkg>@ to become exposed, and all other packages 
78 79
--	with the same name to become hidden.
-- 
80
--   * @-hide-package <pkg>@ causes @<pkg>@ to become hidden.
81
-- 
82 83
--   * Let @exposedPackages@ be the set of packages thus exposed.  
--     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 103 104 105 106 107 108 109 110 111
--     contain any Haskell modules, and therefore won't be discovered
--     by the normal mechanism of dependency tracking.

-- Notes on DLLs
-- ~~~~~~~~~~~~~
-- 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
-- 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 {
  pkgIdMap		:: PackageConfigMap, -- PackageId   -> PackageConfig
112 113
	-- The exposed flags are adjusted according to -package and
	-- -hide-package flags, and -ignore-package removes packages.
114

115 116 117 118 119
  preloadPackages      :: [PackageId],
	-- 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.

120
  moduleToPkgConfAll 	:: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping
121
	-- Derived from pkgIdMap.	
122 123 124
	-- 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 145 146 147 148
lookupPackage :: PackageConfigMap -> PackageId -> Maybe PackageConfig
lookupPackage = lookupUFM

extendPackageConfigMap
   :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
extendPackageConfigMap pkg_map new_pkgs 
  = 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 156

-- ----------------------------------------------------------------------------
-- Loading the package config files and building up the package state

157
-- | Call this after 'DynFlags.parseDynFlags'.  It reads the package
158 159 160
-- configuration files, and sets up various internal tables of package
-- 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 176
  (pkg_state, preload, this_pkg)       
        <- mkPackageState dflags pkg_db [] (thisPackage dflags)
177 178
  return (dflags{ pkgDatabase = Just pkg_db,
		  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
   e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH")
188 189 190 191 192 193 194 195 196 197 198
   system_pkgconfs <- getSystemPackageConfigs dflags

   let pkgconfs = case e_pkg_path of
		    Left _   -> system_pkgconfs
		    Right path
		     | last cs == "" -> init cs ++ system_pkgconfs
		     | otherwise     -> cs
		     where cs = parseSearchPath path
		     -- if the path ends in a separator (eg. "/foo/bar:")
		     -- the we tack on the system paths.

199
   pkgs <- mapM (readPackageConfig dflags)
200
                (pkgconfs ++ reverse (extraPkgConfs dflags))
201 202 203
                -- later packages shadow earlier ones.  extraPkgConfs
                -- is in the opposite order to the flags on the
                -- command line.
204

205
   return (concat pkgs)
206 207 208 209


getSystemPackageConfigs :: DynFlags -> IO [FilePath]
getSystemPackageConfigs dflags = do
210
	-- System one always comes first
211
   let system_pkgconf = systemPackageConfig dflags
212 213 214

	-- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
	-- unless the -no-user-package-conf flag was given.
215
   user_pkgconf <- do
216
      if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do
sof's avatar
sof committed
217 218
      appdir <- getAppUserDataDirectory "ghc"
      let 
219 220 221 222 223
     	 dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
         pkgconf = dir </> "package.conf.d"
      --
      exist <- doesDirectoryExist pkgconf
      if exist then return [pkgconf] else return []
224
    `catchIO` (\_ -> return [])
225

226
   return (system_pkgconf : user_pkgconf)
227

228 229
readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
readPackageConfig dflags conf_file = do
230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
  isdir <- doesDirectoryExist conf_file

  proto_pkg_configs <- 
    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)

       else do 
            isfile <- doesFileExist conf_file
            when (not isfile) $
              ghcError $ InstallationError $ 
                "can't find a package database at " ++ conf_file
            debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
245 246
            str <- readFile conf_file
            return (map installedPackageInfoToPackageConfig $ read str)
247

248 249
  let
      top_dir = topDir dflags
250 251
      pkgroot = takeDirectory conf_file
      pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
252
      pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
253 254
  --
  return pkg_configs2
255

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

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

267
    hide pkg = pkg{ exposed = False }
268
    distrust pkg = pkg{ exposed = False }
269

270
-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293
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)
    }
  where 
    munge_paths = map munge_path
    munge_urls  = map munge_url

    munge_path p
294 295 296
      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
      | otherwise                                = p
297 298

    munge_url p
299 300 301
      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
      | otherwise                                   = p
302 303 304

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
305 306 307 308 309 310 311 312 313 314 315 316 317
                 ++ 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
318

319

320
-- -----------------------------------------------------------------------------
321 322 323 324
-- Modify our copy of the package database based on a package flag
-- (-package, -hide-package, -ignore-package).

applyPackageFlag
325 326
   :: UnusablePackages
   -> [PackageConfig]           -- Initial database
327 328 329
   -> PackageFlag               -- flag to apply
   -> IO [PackageConfig]        -- new database

330
applyPackageFlag unusable pkgs flag =
331
  case flag of
332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353
    ExposePackage str ->
       case selectPackages (matchingStr str) pkgs unusable of
         Left ps         -> packageFlagErr flag ps
         Right (p:ps,qs) -> return (p':ps')
    	  where p' = p {exposed=True}
    	        ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
         _ -> panic "applyPackageFlag"

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

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

354 355 356 357 358 359 360 361 362 363 364 365 366 367
    -- 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)
    	  where trust p = p {trusted=True}

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

368 369
    _ -> panic "applyPackageFlag"

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

378

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

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

400 401
matchingId :: String -> PackageConfig -> Bool
matchingId str p =  InstalledPackageId str == installedPackageId p
402

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

comparing :: Ord a => (t -> a) -> t -> t -> Ordering
407 408
comparing f a b = f a `compare` f b

409 410 411
packageFlagErr :: PackageFlag
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
412 413 414 415 416 417 418 419 420

-- 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
  
421 422 423 424 425 426 427 428 429 430
packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err))
  where err = text "cannot satisfy " <> ppr_flag <> 
                (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
431 432
                     TrustPackage p    -> text "-trust " <> text p
                     DistrustPackage p -> text "-distrust " <> text p
433 434 435
        ppr_reasons = vcat (map ppr_reason reasons)
        ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason

436 437 438 439 440 441 442 443 444 445 446 447
-- -----------------------------------------------------------------------------
-- 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
448 449 450
	   | not (exposed p) = return p
	   | (p' : _) <- later_versions = do
		debugTraceMsg dflags 2 $
451
		   (ptext (sLit "hiding package") <+> pprSPkg p <+>
Ian Lynagh's avatar
Ian Lynagh committed
452
		    ptext (sLit "to avoid conflict with later version") <+>
453
		    pprSPkg p')
454 455
		return (p {exposed=False})
	   | otherwise = return p
456 457
	  where myname = pkgName (sourcePackageId p)
		myversion = pkgVersion (sourcePackageId p)
458
		later_versions = [ p | p <- pkgs, exposed p,
459
				    let pkg = sourcePackageId p,
460 461 462
				    pkgName pkg == myname,
				    pkgVersion pkg > myversion ]

463 464 465 466 467 468
-- -----------------------------------------------------------------------------
-- Wired-in packages

findWiredInPackages
   :: DynFlags
   -> [PackageConfig]           -- database
469
   -> IO [PackageConfig]
470

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

        matches :: PackageConfig -> String -> Bool
488
        pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid
Simon Marlow's avatar
Simon Marlow committed
489 490 491 492 493

	-- 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.
494 495 496 497 498 499
        --
        -- 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.
        --
500 501
	findWiredInPackage :: [PackageConfig] -> String
			   -> IO (Maybe InstalledPackageId)
Simon Marlow's avatar
Simon Marlow committed
502
	findWiredInPackage pkgs wired_pkg =
503
           let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
504 505 506
	   case all_ps of
		[]   -> notfound
		many -> pick (head (sortByVersion many))
507 508 509
          where
                notfound = do
			  debugTraceMsg dflags 2 $
Ian Lynagh's avatar
Ian Lynagh committed
510
			    ptext (sLit "wired-in package ")
511
				 <> text wired_pkg
Ian Lynagh's avatar
Ian Lynagh committed
512
				 <> ptext (sLit " not found.")
513
			  return Nothing
514
		pick :: InstalledPackageInfo_ ModuleName
515
                     -> IO (Maybe InstalledPackageId)
516 517
                pick pkg = do
                        debugTraceMsg dflags 2 $
Ian Lynagh's avatar
Ian Lynagh committed
518
			    ptext (sLit "wired-in package ")
519
				 <> text wired_pkg
Ian Lynagh's avatar
Ian Lynagh committed
520
				 <> ptext (sLit " mapped to ")
521
				 <> pprIPkg pkg
522
			return (Just (installedPackageId pkg))
523

Simon Marlow's avatar
Simon Marlow committed
524

525
  mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids
Simon Marlow's avatar
Simon Marlow committed
526 527 528
  let 
        wired_in_ids = catMaybes mb_wired_in_ids

529 530 531 532 533 534 535 536 537 538 539 540
        -- 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.
        {-
 	deleteOtherWiredInPackages pkgs = filterOut bad pkgs
 	  where bad p = any (p `matches`) wired_in_pkgids
                      && package p `notElem` map fst wired_in_ids
        -}
Simon Marlow's avatar
Simon Marlow committed
541 542

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

549
  return $ updateWiredInDependencies pkgs
550

551 552 553 554 555 556 557
-- ----------------------------------------------------------------------------

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

558
type UnusablePackages = Map InstalledPackageId UnusablePackageReason
559 560 561 562 563 564 565 566 567 568 569 570 571

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 ()
572
reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
573 574 575 576 577 578 579
  where
    report (ipid, reason) =
       debugTraceMsg dflags 2 $
         pprReason
           (ptext (sLit "package") <+>
            text (display ipid) <+> text "is") reason

580
-- ----------------------------------------------------------------------------
581
--
582 583 584 585 586
-- 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.
587
--
588
findBroken :: [PackageConfig] -> UnusablePackages
589
findBroken pkgs = go [] Map.empty pkgs
590
 where
591 592 593
   go avail ipids not_avail =
     case partitionWith (depsAvailable ipids) not_avail of
        ([], not_avail) ->
594 595
            Map.fromList [ (installedPackageId p, MissingDependencies deps)
                         | (p,deps) <- not_avail ]
596 597
        (new_avail, not_avail) ->
            go (new_avail ++ avail) new_ipids (map fst not_avail)
598
            where new_ipids = Map.insertList
599
                                [ (installedPackageId p, p) | p <- new_avail ]
600
                                ipids
601

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

610 611 612 613
-- -----------------------------------------------------------------------------
-- Eliminate shadowed packages, giving the user some feedback

-- later packages in the list should shadow earlier ones with the same
614 615 616 617 618 619
-- 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
620
   in  Map.fromList shadowed
621
 where
622
 check (shadowed,pkgmap) pkg
623 624
      | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)
      , let
625
            ipid_new = installedPackageId pkg
626
            ipid_old = installedPackageId oldpkg
627
        --
628
      , ipid_old /= ipid_new
629
      = if ipid_old `elem` preferred
630 631
           then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap )
           else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' )
632
      | otherwise
633 634 635
      = (shadowed, pkgmap')
      where
        pkgmap' = addToUFM pkgmap (packageConfigId pkg) pkg
636 637 638 639

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

ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
640
ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
641 642 643 644 645 646 647 648 649
  where
  doit (IgnorePackage str) =
     case partition (matchingStr str) pkgs of
         (ps, _) -> [ (installedPackageId p, IgnoredWithFlag)
                    | p <- ps ]
    	-- 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.
  doit _ = panic "ignorePackages"
650

651 652 653 654 655
-- -----------------------------------------------------------------------------

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

665 666 667 668 669 670
-- -----------------------------------------------------------------------------
-- When all the command-line options are in, we can process our package
-- settings and populate the package state.

mkPackageState
    :: DynFlags
671
    -> [PackageConfig]          -- initial database
672 673 674 675 676 677 678
    -> [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.

679 680
mkPackageState dflags pkgs0 preload0 this_package = do

681 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 716 717 718
{-
   Plan.

   1. P = transitive closure of packages selected by -package-id 

   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
-}

719
  let
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
720 721 722 723 724 725 726
      flags = reverse (packageFlags dflags) ++ dphPackage
      -- expose the appropriate DPH backend library
      dphPackage = case dphBackend dflags of
                     DPHPar  -> [ExposePackage "dph-prim-par", ExposePackage "dph-par"]
                     DPHSeq  -> [ExposePackage "dph-prim-seq", ExposePackage "dph-seq"]
                     DPHThis -> []
                     DPHNone -> []
727

728
      -- pkgs0 with duplicate packages filtered out.  This is
729 730 731
      -- 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
732 733
      -- as shadowing (below), since in this case the two packages
      -- have the same ABI and are interchangeable.
734 735 736 737 738 739 740 741 742 743
      --
      -- #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

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

746 747 748
      ipid_selected = depClosure ipid_map [ InstalledPackageId i
                                          | ExposePackageId i <- flags ]
      
749 750 751 752
      (ignore_flags, other_flags) = partition is_ignore flags
      is_ignore IgnorePackage{} = True
      is_ignore _ = False

753
      shadowed = shadowPackages pkgs0_unique ipid_selected
754

755
      ignored  = ignorePackages ignore_flags pkgs0_unique
756

757
      pkgs0' = filter (not . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique
758
      broken   = findBroken pkgs0'
759
      unusable = shadowed `Map.union` ignored `Map.union` broken
760 761 762

  reportUnusable dflags unusable

763
  --
764 765
  -- Modify the package database according to the command-line flags
  -- (-package, -hide-package, -ignore-package, -hide-all-packages).
766
  --
767
  pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags
768
  let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1
769 770 771 772 773 774

  -- 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.
775
  --
776 777 778 779 780
  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 _                   = []
781 782

  -- hide packages that are subsumed by later versions
783
  pkgs3 <- hideOldPackages dflags pkgs2
784 785

  -- sort out which packages are wired in
786
  pkgs4 <- findWiredInPackages dflags pkgs3
787

788
  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4
789

790 791
      ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
                              | p <- pkgs4 ]
792 793

      lookupIPID ipid@(InstalledPackageId str)
794 795
         | Just pid <- Map.lookup ipid ipid_map = return pid
         | otherwise                            = missingPackageErr str
796 797 798 799

  preload2 <- mapM lookupIPID preload1

  let
800
      -- add base & rts to the preload packages
801
      basicLinkedPackages
802
       | dopt Opt_AutoLinkPackages dflags
803 804
          = filter (flip elemUFM pkg_db) [basePackageId, rtsPackageId]
       | otherwise = []
805 806 807
      -- 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
808 809
      preload3 = nub $ filter (/= this_package)
                     $ (basicLinkedPackages ++ preload2)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
810
 
811
  -- Close the preload packages with their dependencies
812
  dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing))
813 814 815
  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
816 817
                             pkgIdMap            = pkg_db,
                             moduleToPkgConfAll  = mkModuleMap pkg_db,
818
                             installedPackageIdMap = ipid_map
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
819
                           }
Simon Marlow's avatar
Simon Marlow committed
820

821
  return (pstate, new_dep_preload, this_package)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
822
  
823

824 825
-- -----------------------------------------------------------------------------
-- Make the mapping from module to package info
826

827 828
mkModuleMap
  :: PackageConfigMap
Simon Marlow's avatar
Simon Marlow committed
829
  -> UniqFM [(PackageConfig, Bool)]
830
mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids
831
  where
832 833
        pkgids = map packageConfigId (eltsUFM pkg_db)
        
Simon Marlow's avatar
Simon Marlow committed
834
	extend_modmap pkgid modmap =
835
		addListToUFM_C (++) modmap 
836 837
		   ([(m, [(pkg, True)])  | m <- exposed_mods] ++
		    [(m, [(pkg, False)]) | m <- hidden_mods])
838
	  where
Simon Marlow's avatar
Simon Marlow committed
839
		pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid)
840 841
	        exposed_mods = exposedModules pkg
	        hidden_mods  = hiddenModules pkg
842

843 844 845 846 847
pprSPkg :: PackageConfig -> SDoc
pprSPkg p = text (display (sourcePackageId p))

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

849
-- -----------------------------------------------------------------------------
850
-- Extracting information from the packages in scope
851

852 853 854 855 856
-- 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
857
-- of preload (command-line) packages to determine which packages to
858
-- use.
859

860
-- | Find all the include directories in these and the preload packages
861
getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String]
862 863 864 865 866
getPackageIncludePath dflags pkgs =
  collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs

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

868
-- | Find all the library paths in these and the preload packages
869
getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String]
870 871 872 873 874
getPackageLibraryPath dflags pkgs =
  collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs

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

876
-- | Find all the link options in these and the preload packages
877
getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String]
878 879 880 881 882
getPackageLinkOpts dflags pkgs = 
  collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs

collectLinkOpts :: DynFlags -> [PackageConfig] -> [String]
collectLinkOpts dflags ps = concat (map all_opts ps)
883 884 885 886 887 888
  where
      	libs p     = packageHsLibs dflags p ++ extraLibraries p
	all_opts p = map ("-l" ++) (libs p) ++ ldOptions p

packageHsLibs :: DynFlags -> PackageConfig -> [String]
packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
889
  where
890 891 892
        ways0 = ways dflags

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

896
        -- debug RTS includes support for -eventlog
897
        ways2 | WayDebug `elem` map wayName ways1 
898
              = filter ((/= WayEventLog) . wayName) ways1
899 900 901 902 903
              | otherwise
              = ways1

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

905 906
	mkDynName | opt_Static = id
		  | otherwise = (++ ("-ghc" ++ cProjectVersion))
907

908 909
        addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)
        addSuffix other_lib      = other_lib ++ (expandTag tag)
910

911 912
        expandTag t | null t = ""
		    | otherwise = '_':t
913

914
-- | Find all the C-compiler options in these and the preload packages
915 916
getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String]
getPackageExtraCcOpts dflags pkgs = do
917
  ps <- getPreloadPackagesAnd dflags pkgs
918
  return (concatMap ccOptions ps)
919

920
-- | Find all the package framework paths in these and the preload packages
921 922
getPackageFrameworkPath  :: DynFlags -> [PackageId] -> IO [String]
getPackageFrameworkPath dflags pkgs = do
923
  ps <- getPreloadPackagesAnd dflags pkgs
924 925
  return (nub (filter notNull (concatMap frameworkDirs ps)))

926
-- | Find all the package frameworks in these and the preload packages
927 928
getPackageFrameworks  :: DynFlags -> [PackageId] -> IO [String]
getPackageFrameworks dflags pkgs = do
929
  ps <- getPreloadPackagesAnd dflags pkgs
930
  return (concatMap frameworks ps)
931 932 933

-- -----------------------------------------------------------------------------
-- Package Utils
934

935 936 937
-- | Takes a 'Module', and if the module is in a package returns 
-- @(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
938
lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)]
939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964
lookupModuleInAllPackages dflags m
  = case lookupModuleWithSuggestions dflags m of
      Right pbs -> pbs
      Left  _   -> []

lookupModuleWithSuggestions
  :: DynFlags -> ModuleName
  -> Either [Module] [(PackageConfig,Bool)]
         -- Lookup module in all packages
         -- Right pbs   =>   found in pbs
         -- Left  ms    =>   not found; but here are sugestions
lookupModuleWithSuggestions dflags m
  = case lookupUFM (moduleToPkgConfAll pkg_state) m of
        Nothing -> Left suggestions
        Just ps -> Right ps
  where
    pkg_state = pkgState dflags
    suggestions
      | dopt Opt_HelpfulErrors dflags = fuzzyLookup (moduleNameString m) all_mods
      | otherwise                     = []

    all_mods :: [(String, Module)]     -- All modules
    all_mods = [ (moduleNameString mod_nm, mkModule pkg_id mod_nm)
               | pkg_config <- eltsUFM (pkgIdMap pkg_state)
               , let pkg_id = packageConfigId pkg_config
               , mod_nm <- exposedModules pkg_config ]
965

966 967
-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
-- 'PackageConfig's