Packages.lhs 42.1 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
41
import Config           ( cProjectVersion )
import Name             ( Name, nameModule_maybe )
42
import UniqFM
43
import Module
44
45
46
import Util
import Panic
import Outputable
47
import Maybes
48

49
import System.Environment ( getEnv )
50
import Distribution.InstalledPackageInfo
51
import Distribution.InstalledPackageInfo.Binary
52
import Distribution.Package hiding (PackageId,depends)
53
import FastString
54
import ErrUtils         ( debugTraceMsg, putMsg, MsgDoc )
55
import Exception
56

Simon Marlow's avatar
Simon Marlow committed
57
import System.Directory
58
59
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
Simon Marlow's avatar
Simon Marlow committed
60
import Control.Monad
61
import Data.Char (isSpace)
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 'DynFlags', 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 system_conf_refs = [UserPkgConf, GlobalPkgConf]
188
189
190
191
192
193
194
195
196
197
198

  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:")
199
         -- then we tack on the system paths.
200

201
  let conf_refs = reverse (extraPkgConfs dflags base_conf_refs)
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
  -- 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
218

219
220
readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
readPackageConfig dflags conf_file = do
221
222
  isdir <- doesDirectoryExist conf_file

223
  proto_pkg_configs <-
224
225
226
227
228
229
    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)

230
       else do
231
232
            isfile <- doesFileExist conf_file
            when (not isfile) $
233
              throwGhcExceptionIO $ InstallationError $
234
235
                "can't find a package database at " ++ conf_file
            debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
236
            str <- readFile conf_file
237
238
239
            case reads str of
                [(configs, rest)]
                    | all isSpace rest -> return (map installedPackageInfoToPackageConfig configs)
240
                _ -> throwGhcExceptionIO $ InstallationError $
241
                        "invalid package database file " ++ conf_file
242

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

251
252
setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs
253
  where
254
    maybeHideAll pkgs'
ian@well-typed.com's avatar
ian@well-typed.com committed
255
      | gopt Opt_HideAllPackages dflags = map hide pkgs'
256
257
258
      | otherwise                       = pkgs'

    maybeDistrustAll pkgs'
ian@well-typed.com's avatar
ian@well-typed.com committed
259
      | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
260
261
      | otherwise                           = pkgs'

262
    hide pkg = pkg{ exposed = False }
dterei's avatar
dterei committed
263
    distrust pkg = pkg{ trusted = False }
264

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

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

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

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
300
301
302
303
304
305
306
307
308
309
310
311
312
                 ++ 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
313

314

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

applyPackageFlag
Ian Lynagh's avatar
Ian Lynagh committed
320
321
   :: DynFlags
   -> UnusablePackages
322
   -> [PackageConfig]           -- Initial database
323
324
325
   -> PackageFlag               -- flag to apply
   -> IO [PackageConfig]        -- new database

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

    ExposePackageId str ->
       case selectPackages (matchingId str) pkgs unusable of
Ian Lynagh's avatar
Ian Lynagh committed
338
         Left ps         -> packageFlagErr dflags flag ps
339
         Right (p:ps,qs) -> return (p':ps')
340
341
          where p' = p {exposed=True}
                ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
342
343
344
345
         _ -> panic "applyPackageFlag"

    HidePackage str ->
       case selectPackages (matchingStr str) pkgs unusable of
Ian Lynagh's avatar
Ian Lynagh committed
346
         Left ps       -> packageFlagErr dflags flag ps
347
         Right (ps,qs) -> return (map hide ps ++ qs)
348
          where hide p = p {exposed=False}
349

350
351
352
353
    -- 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
Ian Lynagh's avatar
Ian Lynagh committed
354
         Left ps       -> packageFlagErr dflags flag ps
355
         Right (ps,qs) -> return (map trust ps ++ qs)
356
          where trust p = p {trusted=True}
357
358
359

    DistrustPackage str ->
       case selectPackages (matchingStr str) pkgs unusable of
Ian Lynagh's avatar
Ian Lynagh committed
360
         Left ps       -> packageFlagErr dflags flag ps
361
         Right (ps,qs) -> return (map distrust ps ++ qs)
362
          where distrust p = p {trusted=False}
363

364
365
    _ -> panic "applyPackageFlag"

366
   where
367
368
369
370
        -- 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
371
372
                   | pkgName (sourcePackageId p) == name = p {exposed=False}
                   | otherwise                           = p
373

374

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

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

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
405
406
packageFlagErr :: DynFlags
               -> PackageFlag
407
408
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
409
410
411

-- for missing DPH package we emit a more helpful error message, because
-- this may be the result of using -fdph-par or -fdph-seq.
Ian Lynagh's avatar
Ian Lynagh committed
412
packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg
413
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
414
415
416
  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
419
packageFlagErr dflags flag reasons
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
420
  where err = text "cannot satisfy " <> ppr_flag <>
421
422
423
424
425
426
427
428
                (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
429
430
                     TrustPackage p    -> text "-trust " <> text p
                     DistrustPackage p -> text "-distrust " <> text p
431
432
433
        ppr_reasons = vcat (map ppr_reason reasons)
        ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason

434
435
436
437
438
439
440
441
442
443
444
445
-- -----------------------------------------------------------------------------
-- 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
446
447
448
449
450
451
452
453
454
455
456
457
458
459
           | 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 ]
460

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

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

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

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

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

Simon Marlow's avatar
Simon Marlow committed
522

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

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

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

547
  return $ updateWiredInDependencies pkgs
548

549
550
551
552
553
554
555
-- ----------------------------------------------------------------------------

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

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

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

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

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

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

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

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

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

649
650
651
652
653
-- -----------------------------------------------------------------------------

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

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

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

677
678
mkPackageState dflags pkgs0 preload0 this_package = do

679
680
681
{-
   Plan.

682
   1. P = transitive closure of packages selected by -package-id
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

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

717
  let
718
      flags = reverse (packageFlags dflags)
719

720
      -- pkgs0 with duplicate packages filtered out.  This is
721
722
723
      -- 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
724
725
      -- as shadowing (below), since in this case the two packages
      -- have the same ABI and are interchangeable.
726
727
728
729
730
731
732
733
734
735
      --
      -- #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

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

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

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

745
      shadowed = shadowPackages pkgs0_unique ipid_selected
746

747
      ignored  = ignorePackages ignore_flags pkgs0_unique
748

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

  reportUnusable dflags unusable

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

  -- 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.
767
  --
768
769
  let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]

770
771
772
      get_exposed (ExposePackage   s)
         = take 1 $ sortByVersion (filter (matchingStr s) pkgs2)
         --  -package P means "the latest version of P" (#7030)
773
774
      get_exposed (ExposePackageId s) = filter (matchingId  s) pkgs2
      get_exposed _                   = []
775
776

  -- hide packages that are subsumed by later versions
777
  pkgs3 <- hideOldPackages dflags pkgs2
778
779

  -- sort out which packages are wired in
780
  pkgs4 <- findWiredInPackages dflags pkgs3
781

782
  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4
783

784
785
      ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
                              | p <- pkgs4 ]
786
787

      lookupIPID ipid@(InstalledPackageId str)
788
         | Just pid <- Map.lookup ipid ipid_map = return pid
Ian Lynagh's avatar
Ian Lynagh committed
789
         | otherwise                            = missingPackageErr dflags str
790
791
792
793

  preload2 <- mapM lookupIPID preload1

  let
794
      -- add base & rts to the preload packages
795
      basicLinkedPackages
ian@well-typed.com's avatar
ian@well-typed.com committed
796
       | gopt Opt_AutoLinkPackages dflags
797
798
          = filter (flip elemUFM pkg_db) [basePackageId, rtsPackageId]
       | otherwise = []
799
800
801
      -- 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
802
803
      preload3 = nub $ filter (/= this_package)
                     $ (basicLinkedPackages ++ preload2)
804

805
  -- Close the preload packages with their dependencies
Ian Lynagh's avatar
Ian Lynagh committed
806
  dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing))
807
808
809
  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
810
811
                             pkgIdMap            = pkg_db,
                             moduleToPkgConfAll  = mkModuleMap pkg_db,
812
                             installedPackageIdMap = ipid_map
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
813
                           }
Simon Marlow's avatar
Simon Marlow committed
814

815
  return (pstate, new_dep_preload, this_package)
816

817

818
819
-- -----------------------------------------------------------------------------
-- Make the mapping from module to package info
820

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

        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
836

837
838
839
840
841
pprSPkg :: PackageConfig -> SDoc
pprSPkg p = text (display (sourcePackageId p))

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

843
-- -----------------------------------------------------------------------------
844
-- Extracting information from the packages in scope
845

846
847
848
849
850
-- 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
851
-- of preload (command-line) packages to determine which packages to
852
-- use.
853

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

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

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

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

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

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

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

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

890
        -- debug RTS includes support for -eventlog
891
892
        ways2 | WayDebug `elem` ways1
              = filter (/= WayEventLog) ways1
893
894
895
896
897
              | otherwise
              = ways1

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

ian@well-typed.com's avatar
ian@well-typed.com committed
899
        mkDynName | gopt Opt_Static dflags = id
900
                  | otherwise = (++ ("-ghc" ++ cProjectVersion))
901

902
903
        addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)
        addSuffix other_lib      = other_lib ++ (expandTag tag)
904

905
        expandTag t | null t = ""
906
                    | otherwise = '_':t
907

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

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

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

-- -----------------------------------------------------------------------------
-- Package Utils
928

929
-- | Takes a 'Module', and if the module is in a package returns
930
931
-- @(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
932
lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)]
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
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
ian@well-typed.com's avatar
ian@well-typed.com committed
951
      | gopt Opt_HelpfulErrors dflags = fuzzyLookup (moduleNameString m) all_mods
952
953
954
955
956
957
958
      | 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 ]
959

960
961
-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
-- 'PackageConfig's
962
963
getPreloadPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig]
getPreloadPackagesAnd dflags pkgids =
964
  let
965
966
      state   = pkgState dflags
      pkg_map = pkgIdMap state
967
      ipid_map = installedPackageIdMap state
968
969
      preload = preloadPackages state
      pairs = zip pkgids (repeat Nothing)
970
  in do
Ian Lynagh's avatar
Ian Lynagh committed
971
  all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs)
972
  return (map (getPackageDetails state) all_pkgs)
973

974
975
-- Takes a list of packages, and returns the list with dependencies included,
-- in reverse dependency order (a package appears before those it depends on).
Ian Lynagh's avatar
Ian Lynagh committed
976
977
closeDeps :: DynFlags
          -> PackageConfigMap
978
          -> Map InstalledPackageId PackageId
979
980
          -> [(PackageId, Maybe PackageId)]
          -> IO [PackageId]
Ian Lynagh's avatar
Ian Lynagh committed
981
982
closeDeps dflags pkg_map ipid_map ps
    = throwErr dflags (closeDepsErr pkg_map ipid_map ps)
983

Ian Lynagh's avatar
Ian Lynagh committed
984
985
986
throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
throwErr dflags m
              = case m of
987
                Failed e    -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
988
                Succeeded r -> return r
989

990
closeDepsErr :: PackageConfigMap
991
             -> Map InstalledPackageId PackageId
992
             -> [(PackageId,Maybe PackageId)]
993
             -> MaybeErr MsgDoc [PackageId]
994
closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
995
996

-- internal helper
997
add_package :: PackageConfigMap
998
            -> Map InstalledPackageId PackageId
999
1000
            -> [PackageId]
            -> (PackageId,Maybe PackageId)
1001
            -> MaybeErr MsgDoc [PackageId]
1002
add_package pkg_db ipid_map ps (p, mb_parent)
1003
  | p `elem` ps = return ps     -- Check if we've already added this package
1004
1005
  | otherwise =
      case lookupPackage pkg_db p of
1006
        Nothing -> Failed (missingPackageMsg (packageIdString p) <>
1007
                           missingDependencyMsg mb_parent)
1008
        Just pkg -> do
1009
1010
1011
           -- Add the package's dependents also
           ps' <- foldM add_package_ipid ps (depends pkg)
           return (p : ps')
1012
1013
          where
            add_package_ipid ps ipid@(InstalledPackageId str)
1014
              | Just pid <- Map.lookup ipid ipid_map
1015
1016
1017
              = add_package pkg_db ipid_map ps (pid, Just p)
              | otherwise
              = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent)
1018

Ian Lynagh's avatar
Ian Lynagh committed
1019
1020
missingPackageErr :: DynFlags -> String -> IO a
missingPackageErr dflags p
1021
    = throwGhcExceptionIO (CmdLineError (showSDoc dflags (missingPackageMsg p)))
Ian Lynagh's avatar
Ian Lynagh committed
1022

Ian Lynagh's avatar
Ian Lynagh committed
1023
missingPackageMsg :: String -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
1024
missingPackageMsg p = ptext (sLit "unknown package:") <+> text p
1025

Ian Lynagh's avatar
Ian Lynagh committed
1026
missingDependencyMsg :: Maybe PackageId -> SDoc
1027
1028
missingDependencyMsg Nothing = empty
missingDependencyMsg (Just parent)