Packages.hs 62.8 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2
-- (c) The University of Glasgow, 2006

3
{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns #-}
4

5
-- | Package manipulation
6
module Packages (
7 8 9
        module PackageConfig,

        -- * Reading the package config, and processing cmdline args
10
        PackageState(preloadPackages, explicitPackages),
11
        emptyPackageState,
12
        initPackages,
13 14 15 16
        readPackageConfigs,
        getPackageConfRefs,
        resolvePackageConfig,
        readPackageConfig,
Edsko de Vries's avatar
Edsko de Vries committed
17
        listPackageConfigMap,
18 19 20 21

        -- * Querying the package config
        lookupPackage,
        searchPackageId,
22
        getPackageDetails,
23
        listVisibleModuleNames,
24 25
        lookupModuleInAllPackages,
        lookupModuleWithSuggestions,
26
        lookupPluginModuleWithSuggestions,
27
        LookupResult(..),
28 29
        ModuleSuggestion(..),
        ModuleOrigin(..),
30 31 32 33 34 35 36 37 38

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

40
        collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
41
        packageHsLibs,
42

43
        -- * Utils
44
        unitIdPackageIdString,
45
        pprFlag,
46 47
        pprPackages,
        pprPackagesSimple,
48
        pprModuleMap,
49
        isDllName
50
    )
51 52 53
where

#include "HsVersions.h"
54

55
import GHC.PackageDb
56
import PackageConfig
57
import DynFlags
58
import Name             ( Name, nameModule_maybe )
59
import UniqFM
niteria's avatar
niteria committed
60
import UniqDFM
61
import Module
62 63 64
import Util
import Panic
import Outputable
65
import Maybes
66

67
import System.Environment ( getEnv )
68
import FastString
69
import ErrUtils         ( debugTraceMsg, MsgDoc )
70
import Exception
71
import Unique
72

Simon Marlow's avatar
Simon Marlow committed
73
import System.Directory
74 75
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
Simon Marlow's avatar
Simon Marlow committed
76
import Control.Monad
77
import Data.Char ( toUpper )
78
import Data.List as List
79
import Data.Map (Map)
80
import Data.Set (Set)
81 82 83 84
#if __GLASGOW_HASKELL__ > 710
import Data.Semigroup   ( Semigroup )
import qualified Data.Semigroup as Semigroup
#endif
85
import qualified Data.Map as Map
86
import qualified Data.Map.Strict as MapStrict
87
import qualified FiniteMap as Map
88
import qualified Data.Set as Set
Simon Marlow's avatar
Simon Marlow committed
89

90 91 92
-- ---------------------------------------------------------------------------
-- The Package state

93
-- | Package state is all stored in 'DynFlags', including the details of
94 95 96
-- all packages, which packages are exposed, and which modules they
-- provide.
--
97
-- The package state is computed by 'initPackages', and kept in DynFlags.
98
-- It is influenced by various package flags:
99
--
100 101 102
--   * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed.
--     If @-hide-all-packages@ was not specified, these commands also cause
--      all other packages with the same name to become hidden.
103
--
104
--   * @-hide-package <pkg>@ causes @<pkg>@ to become hidden.
105
--
106 107 108 109
--   * (there are a few more flags, check below for their semantics)
--
-- The package state has the following properties.
--
110
--   * Let @exposedPackages@ be the set of packages thus exposed.
111
--     Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of
112 113
--     their dependencies.
--
114
--   * When searching for a module from an preload import declaration,
115
--     only the exposed modules in @exposedPackages@ are valid.
116 117
--
--   * When searching for a module from an implicit import, all modules
118
--     from @depExposedPackages@ are valid.
119
--
120
--   * When linking in a compilation manager mode, we link in packages the
121 122
--     program depends on (the compiler knows this list by the
--     time it gets to the link step).  Also, we link in all packages
123
--     which were mentioned with preload @-package@ flags on the command-line,
Ian Lynagh's avatar
Ian Lynagh committed
124
--     or are a transitive dependency of same, or are \"base\"\/\"rts\".
125
--     The reason for this is that we might need packages which don't
126 127 128 129 130
--     contain any Haskell modules, and therefore won't be discovered
--     by the normal mechanism of dependency tracking.

-- Notes on DLLs
-- ~~~~~~~~~~~~~
131 132 133 134
-- 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
135 136 137
-- When compiling A, we record in B's Module value whether it's
-- in a different DLL, by setting the DLL flag.

138
-- | Given a module name, there may be multiple ways it came into scope,
139 140 141
-- possibly simultaneously.  This data type tracks all the possible ways
-- it could have come into scope.  Warning: don't use the record functions,
-- they're partial!
142
data ModuleOrigin =
143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
    -- | Module is hidden, and thus never will be available for import.
    -- (But maybe the user didn't realize), so we'll still keep track
    -- of these modules.)
    ModHidden
    -- | Module is public, and could have come from some places.
  | ModOrigin {
        -- | @Just False@ means that this module is in
        -- someone's @exported-modules@ list, but that package is hidden;
        -- @Just True@ means that it is available; @Nothing@ means neither
        -- applies.
        fromOrigPackage :: Maybe Bool
        -- | Is the module available from a reexport of an exposed package?
        -- There could be multiple.
      , fromExposedReexport :: [PackageConfig]
        -- | Is the module available from a reexport of a hidden package?
      , fromHiddenReexport :: [PackageConfig]
        -- | Did the module export come from a package flag? (ToDo: track
        -- more information.
      , fromPackageFlag :: Bool
      }

instance Outputable ModuleOrigin where
165
    ppr ModHidden = text "hidden module"
166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181
    ppr (ModOrigin e res rhs f) = sep (punctuate comma (
        (case e of
            Nothing -> []
            Just False -> [text "hidden package"]
            Just True -> [text "exposed package"]) ++
        (if null res
            then []
            else [text "reexport by" <+>
                    sep (map (ppr . packageConfigId) res)]) ++
        (if null rhs
            then []
            else [text "hidden reexport by" <+>
                    sep (map (ppr . packageConfigId) res)]) ++
        (if f then [text "package flag"] else [])
        ))

182 183 184 185
-- | Smart constructor for a module which is in @exposed-modules@.  Takes
-- as an argument whether or not the defining package is exposed.
fromExposedModules :: Bool -> ModuleOrigin
fromExposedModules e = ModOrigin (Just e) [] [] False
186

187 188 189 190 191 192
-- | Smart constructor for a module which is in @reexported-modules@.  Takes
-- as an argument whether or not the reexporting package is expsed, and
-- also its 'PackageConfig'.
fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin
fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
193 194 195 196 197

-- | Smart constructor for a module which was bound by a package flag.
fromFlag :: ModuleOrigin
fromFlag = ModOrigin Nothing [] [] True

198 199 200 201 202 203 204 205 206 207 208 209
#if __GLASGOW_HASKELL__ > 710
instance Semigroup ModuleOrigin where
    ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' =
        ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
      where g (Just b) (Just b')
                | b == b'   = Just b
                | otherwise = panic "ModOrigin: package both exposed/hidden"
            g Nothing x = x
            g x Nothing = x
    _x <> _y = panic "ModOrigin: hidden module redefined"
#endif

210 211 212 213 214 215 216 217 218 219
instance Monoid ModuleOrigin where
    mempty = ModOrigin Nothing [] [] False
    mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') =
        ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
      where g (Just b) (Just b')
                | b == b'   = Just b
                | otherwise = panic "ModOrigin: package both exposed/hidden"
            g Nothing x = x
            g x Nothing = x
    mappend _ _ = panic "ModOrigin: hidden module redefined"
220 221 222

-- | Is the name from the import actually visible? (i.e. does it cause
-- ambiguity, or is it only relevant when we're making suggestions?)
223 224 225 226 227 228 229 230 231
originVisible :: ModuleOrigin -> Bool
originVisible ModHidden = False
originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f

-- | Are there actually no providers for this module?  This will never occur
-- except when we're filtering based on package imports.
originEmpty :: ModuleOrigin -> Bool
originEmpty (ModOrigin Nothing [] [] False) = True
originEmpty _ = False
232

233
-- | 'UniqFM' map from 'UnitId'
niteria's avatar
niteria committed
234
type UnitIdMap = UniqDFM
235

236 237
-- | 'UniqFM' map from 'UnitId' to 'PackageConfig'
type PackageConfigMap = UnitIdMap PackageConfig
238

239
-- | 'UniqFM' map from 'UnitId' to (1) whether or not all modules which
240 241 242 243
-- are exposed should be dumped into scope, (2) any custom renamings that
-- should also be apply, and (3) what package name is associated with the
-- key, if it might be hidden
type VisibilityMap =
244
    UnitIdMap (Bool, [(ModuleName, ModuleName)], FastString)
245

246 247 248 249 250
-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
-- in scope.  The 'PackageConf' is not cached, mostly for convenience reasons
-- (since this is the slow path, we'll just look it up again).
type ModuleToPkgConfAll =
    Map ModuleName (Map Module ModuleOrigin)
251

252
data PackageState = PackageState {
253
  -- | A mapping of 'UnitId' to 'PackageConfig'.  This list is adjusted
254 255 256 257
  -- so that only valid packages are here.  'PackageConfig' reflects
  -- what was stored *on disk*, except for the 'trusted' flag, which
  -- is adjusted at runtime.  (In particular, some packages in this map
  -- may have the 'exposed' flag be 'False'.)
258 259 260 261 262
  pkgIdMap              :: PackageConfigMap,

  -- | 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.
263
  preloadPackages      :: [UnitId],
264

265 266 267 268
  -- | Packages which we explicitly depend on (from a command line flag).
  -- We'll use this to generate version macros.
  explicitPackages      :: [UnitId],

269 270 271
  -- | This is a full map from 'ModuleName' to all modules which may possibly
  -- be providing it.  These providers may be hidden (but we'll still want
  -- to report them in error messages), or it may be an ambiguous import.
272
  moduleToPkgConfAll    :: !ModuleToPkgConfAll,
273 274

  -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility.
275
  pluginModuleToPkgConfAll    :: !ModuleToPkgConfAll
276 277
  }

278 279
emptyPackageState :: PackageState
emptyPackageState = PackageState {
niteria's avatar
niteria committed
280
    pkgIdMap = emptyPackageConfigMap,
281
    preloadPackages = [],
282
    explicitPackages = [],
283 284
    moduleToPkgConfAll = Map.empty,
    pluginModuleToPkgConfAll = Map.empty
285 286
    }

287
type InstalledPackageIndex = Map UnitId PackageConfig
288

289
-- | Empty package configuration map
290
emptyPackageConfigMap :: PackageConfigMap
niteria's avatar
niteria committed
291
emptyPackageConfigMap = emptyUDFM
292

293
-- | Find the package we know about with the given key (e.g. @foo_HASH@), if any
294
lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
295 296
lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))

297
lookupPackage' :: PackageConfigMap -> UnitId -> Maybe PackageConfig
niteria's avatar
niteria committed
298
lookupPackage' = lookupUDFM
299 300

-- | Search for packages with a given package ID (e.g. \"foo-0.1\")
301
searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
302 303
searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
                               (listPackageConfigMap dflags)
304

305
-- | Extends the package configuration map with a list of package configs.
306 307
extendPackageConfigMap
   :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
308
extendPackageConfigMap pkg_map new_pkgs
309
  = foldl add pkg_map new_pkgs
niteria's avatar
niteria committed
310
  where add pkg_map p = addToUDFM pkg_map (packageConfigId p) p
311

312 313
-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
314
getPackageDetails :: DynFlags -> UnitId -> PackageConfig
315 316 317 318
getPackageDetails dflags pid =
    expectJust "getPackageDetails" (lookupPackage dflags pid)

-- | Get a list of entries from the package database.  NB: be careful with
319 320 321
-- this function, although all packages in this map are "visible", this
-- does not imply that the exposed-modules of the package are available
-- (they may have been thinned or renamed).
322
listPackageConfigMap :: DynFlags -> [PackageConfig]
niteria's avatar
niteria committed
323
listPackageConfigMap dflags = eltsUDFM (pkgIdMap (pkgState dflags))
324

325
-- ----------------------------------------------------------------------------
326
-- Loading the package db files and building up the package state
327

328
-- | Call this after 'DynFlags.parseDynFlags'.  It reads the package
329
-- database files, and sets up various internal tables of package
330 331
-- information, according to the package-related flags on the
-- command-line (@-package@, @-hide-package@ etc.)
332 333 334
--
-- 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
335
-- @-package@ flags.
336 337 338
--
-- 'initPackages' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
339
-- 'pkgState' in 'DynFlags' and return a list of packages to
340
-- link in.
341
initPackages :: DynFlags -> IO (DynFlags, [UnitId])
342
initPackages dflags = do
343 344 345 346 347
  pkg_db <-
    case pkgDatabase dflags of
        Nothing -> readPackageConfigs dflags
        Just db -> return $ map (\(p, pkgs)
                                    -> (p, setBatchPackageFlags dflags pkgs)) db
348
  (pkg_state, preload, this_pkg)
349
        <- mkPackageState dflags pkg_db []
350
  return (dflags{ pkgDatabase = Just pkg_db,
351
                  pkgState = pkg_state,
352 353
                  thisPackage = this_pkg },
          preload)
354 355

-- -----------------------------------------------------------------------------
356 357
-- Reading the package database(s)

358
readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])]
359
readPackageConfigs dflags = do
360 361
  conf_refs <- getPackageConfRefs dflags
  confs     <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
362 363
  mapM (readPackageConfig dflags) confs

364 365 366

getPackageConfRefs :: DynFlags -> IO [PkgConfRef]
getPackageConfRefs dflags = do
367
  let system_conf_refs = [UserPkgConf, GlobalPkgConf]
368

369
  e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
370 371 372
  let base_conf_refs = case e_pkg_path of
        Left _ -> system_conf_refs
        Right path
373 374
         | not (null path) && isSearchPathSeparator (last path)
         -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs
375
         | otherwise
376
         -> map PkgConfFile (splitSearchPath path)
377

378
  return $ reverse (extraPkgConfs dflags base_conf_refs)
379 380 381 382 383 384
  -- later packages shadow earlier ones.  extraPkgConfs
  -- is in the opposite order to the flags on the
  -- command line.

resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
385 386 387
-- NB: This logic is reimplemented in Cabal, so if you change it,
-- make sure you update Cabal.  (Or, better yet, dump it in the
-- compiler info so Cabal can use the info.)
388
resolvePackageConfig dflags UserPkgConf = runMaybeT $ do
389
  dir <- versionedAppDir dflags
Edsko de Vries's avatar
Edsko de Vries committed
390
  let pkgconf = dir </> "package.conf.d"
391 392
  exist <- tryMaybeT $ doesDirectoryExist pkgconf
  if exist then return pkgconf else mzero
393
resolvePackageConfig _ (PkgConfFile name) = return $ Just name
394

395
readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig])
396
readPackageConfig dflags conf_file = do
397 398
  isdir <- doesDirectoryExist conf_file

399
  proto_pkg_configs <-
400
    if isdir
401
       then readDirStylePackageConfig conf_file
402
       else do
403
            isfile <- doesFileExist conf_file
404
            if isfile
405 406 407 408 409
               then do
                 mpkgs <- tryReadOldFileStylePackageConfig
                 case mpkgs of
                   Just pkgs -> return pkgs
                   Nothing   -> throwGhcExceptionIO $ InstallationError $
410 411 412 413
                      "ghc no longer supports single-file style package " ++
                      "databases (" ++ conf_file ++
                      ") use 'ghc-pkg init' to create the database with " ++
                      "the correct format."
414 415
               else throwGhcExceptionIO $ InstallationError $
                      "can't find a package database at " ++ conf_file
416

417 418
  let
      top_dir = topDir dflags
419 420
      pkgroot = takeDirectory conf_file
      pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
421
      pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
422
  --
423
  return (conf_file, pkg_configs2)
424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448
  where
    readDirStylePackageConfig conf_dir = do
      let filename = conf_dir </> "package.cache"
      debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
      readPackageDbForGhc filename

    -- Single-file style package dbs have been deprecated for some time, but
    -- it turns out that Cabal was using them in one place. So this is a
    -- workaround to allow older Cabal versions to use this newer ghc.
    -- We check if the file db contains just "[]" and if so, we look for a new
    -- dir-style db in conf_file.d/, ie in a dir next to the given file.
    -- We cannot just replace the file with a new dir style since Cabal still
    -- assumes it's a file and tries to overwrite with 'writeFile'.
    -- ghc-pkg also cooperates with this workaround.
    tryReadOldFileStylePackageConfig = do
      content <- readFile conf_file `catchIO` \_ -> return ""
      if take 2 content == "[]"
        then do
          let conf_dir = conf_file <.> "d"
          direxists <- doesDirectoryExist conf_dir
          if direxists
             then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
                     liftM Just (readDirStylePackageConfig conf_dir)
             else return (Just []) -- ghc-pkg will create it when it's updated
        else return Nothing
449

450
setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
451
setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
452
  where
453
    maybeDistrustAll pkgs'
ian@well-typed.com's avatar
ian@well-typed.com committed
454
      | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
455 456
      | otherwise                           = pkgs'

dterei's avatar
dterei committed
457
    distrust pkg = pkg{ trusted = False }
458

459
-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477
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)
    }
478
  where
479 480 481 482
    munge_paths = map munge_path
    munge_urls  = map munge_url

    munge_path p
483 484 485
      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
      | otherwise                                = p
486 487

    munge_url p
488 489 490
      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
      | otherwise                                   = p
491 492 493

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
494 495 496 497 498 499 500 501 502 503 504 505 506
                 ++ 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
507

508

509
-- -----------------------------------------------------------------------------
510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533
-- Modify our copy of the package database based on trust flags,
-- -trust and -distrust.

applyTrustFlag
   :: DynFlags
   -> UnusablePackages
   -> [PackageConfig]
   -> TrustFlag
   -> IO [PackageConfig]
applyTrustFlag dflags unusable pkgs flag =
  case flag of
    -- 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       -> trustFlagErr dflags 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       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map distrust ps ++ qs)
          where distrust p = p {trusted=False}
534 535

applyPackageFlag
Ian Lynagh's avatar
Ian Lynagh committed
536 537
   :: DynFlags
   -> UnusablePackages
538 539
   -> Bool -- if False, if you expose a package, it implicitly hides
           -- any previously exposed packages with the same name
540 541
   -> [PackageConfig]
   -> VisibilityMap           -- Initially exposed
542
   -> PackageFlag               -- flag to apply
543
   -> IO VisibilityMap        -- Now exposed
544

545
applyPackageFlag dflags unusable no_hide_others pkgs vm flag =
546
  case flag of
547
    ExposePackage _ arg (ModRenaming b rns) ->
548
       case selectPackages (matching arg) pkgs unusable of
549
         Left ps         -> packageFlagErr dflags flag ps
550
         Right (p:_,_) -> return vm'
551 552
          where
           n = fsPackageName p
niteria's avatar
niteria committed
553
           vm' = addToUDFM_C edit vm_cleared (packageConfigId p) (b, rns, n)
554
           edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575
           -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`
           -- (or if p-0.1 was registered in the pkgdb as exposed: True),
           -- the second package flag would override the first one and you
           -- would only see p-0.2 in exposed modules.  This is good for
           -- usability.
           --
           -- However, with thinning and renaming (or Backpack), there might be
           -- situations where you legitimately want to see two versions of a
           -- package at the same time, and this behavior would make it
           -- impossible to do so.  So we decided that if you pass
           -- -hide-all-packages, this should turn OFF the overriding behavior
           -- where an exposed package hides all other packages with the same
           -- name.  This should not affect Cabal at all, which only ever
           -- exposes one package at a time.
           --
           -- NB: Why a variable no_hide_others?  We have to apply this logic to
           -- -plugin-package too, and it's more consistent if the switch in
           -- behavior is based off of
           -- -hide-all-packages/-hide-all-plugin-packages depending on what
           -- flag is in question.
           vm_cleared | no_hide_others = vm
niteria's avatar
niteria committed
576
                      | otherwise = filterUDFM_Directly
577
                            (\k (_,_,n') -> k == getUnique (packageConfigId p)
578
                                                || n /= n') vm
579 580
         _ -> panic "applyPackageFlag"

581 582
    HidePackage str ->
       case selectPackages (matchingStr str) pkgs unusable of
Ian Lynagh's avatar
Ian Lynagh committed
583
         Left ps       -> packageFlagErr dflags flag ps
584
         Right (ps,_) -> return vm'
niteria's avatar
niteria committed
585
          where vm' = delListFromUDFM vm (map packageConfigId ps)
586 587 588 589 590 591

selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
               -> UnusablePackages
               -> Either [(PackageConfig, UnusablePackageReason)]
                  ([PackageConfig], [PackageConfig])
selectPackages matches pkgs unusable
592 593 594
  = let (ps,rest) = partition matches pkgs
    in if null ps
        then Left (filter (matches.fst) (Map.elems unusable))
595 596 597
        -- NB: packages from later package databases are LATER
        -- in the list.  We want to prefer the latest package.
        else Right (sortByVersion (reverse ps), rest)
598 599 600

-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
601 602
matchingStr :: String -> PackageConfig -> Bool
matchingStr str p
603 604
        =  str == sourcePackageIdString p
        || str == packageNameString p
605

606
matchingId :: String -> PackageConfig -> Bool
607
matchingId str p = str == unitIdString (packageConfigId p)
608

609 610
matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg str) = matchingStr str
611
matching (UnitIdArg str)  = matchingId str
612

613 614
sortByVersion :: [PackageConfig] -> [PackageConfig]
sortByVersion = sortBy (flip (comparing packageVersion))
Ian Lynagh's avatar
Ian Lynagh committed
615 616

comparing :: Ord a => (t -> a) -> t -> t -> Ordering
617 618
comparing f a b = f a `compare` f b

Ian Lynagh's avatar
Ian Lynagh committed
619 620
packageFlagErr :: DynFlags
               -> PackageFlag
621 622
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
623 624 625

-- for missing DPH package we emit a more helpful error message, because
-- this may be the result of using -fdph-par or -fdph-seq.
626
packageFlagErr dflags (ExposePackage _ (PackageArg pkg) _) []
627
  | is_dph_package pkg
628
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
629 630 631
  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
632
packageFlagErr dflags flag reasons
633 634 635 636 637 638 639 640 641 642 643 644 645 646
  = packageFlagErr' dflags (pprFlag flag) reasons

trustFlagErr :: DynFlags
             -> TrustFlag
             -> [(PackageConfig, UnusablePackageReason)]
             -> IO a
trustFlagErr dflags flag reasons
  = packageFlagErr' dflags (pprTrustFlag flag) reasons

packageFlagErr' :: DynFlags
               -> SDoc
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
packageFlagErr' dflags flag_doc reasons
647
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
648
  where err = text "cannot satisfy " <> flag_doc <>
649
                (if null reasons then Outputable.empty else text ": ") $$
650 651 652
              nest 4 (ppr_reasons $$
                      text "(use -v for more information)")
        ppr_reasons = vcat (map ppr_reason reasons)
653
        ppr_reason (p, reason) =
654
            pprReason (ppr (unitId p) <+> text "is") reason
655

656 657 658
pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
    HidePackage p   -> text "-hide-package " <> text p
659
    ExposePackage doc _ _ -> text doc
660

661 662 663 664 665
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag flag = case flag of
    TrustPackage p    -> text "-trust " <> text p
    DistrustPackage p -> text "-distrust " <> text p

666 667 668
-- -----------------------------------------------------------------------------
-- Wired-in packages

669
wired_in_pkgids :: [String]
670
wired_in_pkgids = map unitIdString wiredInUnitIds
671

672
type WiredPackagesMap = Map UnitId UnitId
673

674 675 676
findWiredInPackages
   :: DynFlags
   -> [PackageConfig]           -- database
677
   -> VisibilityMap             -- info on what packages are visible
678 679 680
                                -- for wired in selection
   -> IO ([PackageConfig],  -- package database updated for wired in
          WiredPackagesMap) -- map from unit id to wired identity
681

682
findWiredInPackages dflags pkgs vis_map = do
Simon Marlow's avatar
Simon Marlow committed
683 684 685 686 687
  --
  -- Now we must find our wired-in packages, and rename them to
  -- their canonical names (eg. base-1.0 ==> base).
  --
  let
688
        matches :: PackageConfig -> String -> Bool
689
        pc `matches` pid = packageNameString pc == pid
Simon Marlow's avatar
Simon Marlow committed
690

691 692 693 694
        -- 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.
695 696
        --
        -- When choosing which package to map to a wired-in package
697 698 699 700 701 702 703 704 705 706
        -- name, we try to pick the latest version of exposed packages.
        -- However, if there are no exposed wired in packages available
        -- (e.g. -hide-all-packages was used), we can't bail: we *have*
        -- to assign a package for the wired-in package: so we try again
        -- with hidden packages included to (and pick the latest
        -- version).
        --
        -- You can also override the default choice by using -ignore-package:
        -- this works even when there is no exposed wired in package
        -- available.
707
        --
708
        findWiredInPackage :: [PackageConfig] -> String
709
                           -> IO (Maybe PackageConfig)
710
        findWiredInPackage pkgs wired_pkg =
711 712 713
           let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
               all_exposed_ps =
                    [ p | p <- all_ps
niteria's avatar
niteria committed
714
                        , elemUDFM (packageConfigId p) vis_map ] in
715 716 717 718 719
           case all_exposed_ps of
            [] -> case all_ps of
                       []   -> notfound
                       many -> pick (head (sortByVersion many))
            many -> pick (head (sortByVersion many))
720 721
          where
                notfound = do
722
                          debugTraceMsg dflags 2 $
723
                            text "wired-in package "
724
                                 <> text wired_pkg
725
                                 <> text " not found."
726
                          return Nothing
727
                pick :: PackageConfig
728
                     -> IO (Maybe PackageConfig)
729 730
                pick pkg = do
                        debugTraceMsg dflags 2 $
731
                            text "wired-in package "
732
                                 <> text wired_pkg
733
                                 <> text " mapped to "
734
                                 <> ppr (unitId pkg)
735
                        return (Just pkg)
736

Simon Marlow's avatar
Simon Marlow committed
737

738
  mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
739
  let
740
        wired_in_pkgs = catMaybes mb_wired_in_pkgs
741
        wired_in_ids = map unitId wired_in_pkgs
Simon Marlow's avatar
Simon Marlow committed
742

743 744 745 746 747 748 749 750
        -- 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.
        {-
751 752
        deleteOtherWiredInPackages pkgs = filterOut bad pkgs
          where bad p = any (p `matches`) wired_in_pkgids
753 754
                      && package p `notElem` map fst wired_in_ids
        -}
Simon Marlow's avatar
Simon Marlow committed
755

756
        wiredInMap :: Map UnitId UnitId
757 758
        wiredInMap = foldl' add_mapping Map.empty pkgs
          where add_mapping m pkg
759
                  | let key = unitId pkg
760
                  , key `elem` wired_in_ids
761
                  = Map.insert key (stringToUnitId (packageNameString pkg)) m
762 763 764
                  | otherwise = m

        updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
765
          where upd_pkg pkg
766
                  | unitId pkg `elem` wired_in_ids
767
                  = pkg {
768
                      unitId = stringToUnitId (packageNameString pkg)
769
                    }
770
                  | otherwise
771
                  = pkg
772
                upd_deps pkg = pkg {
773 774 775 776
                      depends = map upd_wired_in (depends pkg),
                      exposedModules
                        = map (\(k,v) -> (k, fmap upd_wired_in_mod v))
                              (exposedModules pkg)
777
                    }
778
                upd_wired_in_mod (Module uid m) = Module (upd_wired_in uid) m
779 780 781
                upd_wired_in key
                    | Just key' <- Map.lookup key wiredInMap = key'
                    | otherwise = key
Simon Marlow's avatar
Simon Marlow committed
782

783

784 785 786 787
  return (updateWiredInDependencies pkgs, wiredInMap)

updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap
updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
niteria's avatar
niteria committed
788
  where f vm (from, to) = case lookupUDFM vis_map from of
789
                    Nothing -> vm
niteria's avatar
niteria committed
790
                    Just r -> addToUDFM vm to r
791

792

793 794
-- ----------------------------------------------------------------------------

795
type IsShadowed = Bool
796 797
data UnusablePackageReason
  = IgnoredWithFlag
798
  | MissingDependencies IsShadowed [UnitId]
799

800
type UnusablePackages = Map UnitId
801
                            (PackageConfig, UnusablePackageReason)
802 803 804 805

pprReason :: SDoc -> UnusablePackageReason -> SDoc
pprReason pref reason = case reason of
  IgnoredWithFlag ->
806
      pref <+> text "ignored due to an -ignore-package flag"
807 808 809 810 811
  MissingDependencies is_shadowed deps ->
      pref <+> text "unusable due to"
           <+> (if is_shadowed then text "shadowed"
                               else text "missing or recursive")
           <+> text "dependencies:" $$
812
        nest 2 (hsep (map ppr deps))
813 814

reportUnusable :: DynFlags -> UnusablePackages -> IO ()
815
reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
816
  where
817
    report (ipid, (_, reason)) =
818 819
       debugTraceMsg dflags 2 $
         pprReason