Packages.lhs 59.6 KB
Newer Older
1
%
2
% (c) The University of Glasgow, 2006
3 4
%
\begin{code}
5
{-# LANGUAGE CPP, ScopedTypeVariables #-}
6

7
-- | Package manipulation
8
module Packages (
9 10 11
        module PackageConfig,

        -- * Reading the package config, and processing cmdline args
12
        PackageState(preloadPackages),
13
        initPackages,
14 15 16 17 18

        -- * Querying the package config
        lookupPackage,
        resolveInstalledPackageId,
        searchPackageId,
19
        getPackageDetails,
20
        listVisibleModuleNames,
21 22 23
        lookupModuleInAllPackages,
        lookupModuleWithSuggestions,
        LookupResult(..),
24 25
        ModuleSuggestion(..),
        ModuleOrigin(..),
26 27 28 29 30 31 32 33 34

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

36
        collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
37
        packageHsLibs,
38
        ModuleExport(..),
39

40
        -- * Utils
41
        packageKeyPackageIdString,
42
        pprFlag,
43 44
        pprPackages,
        pprPackagesSimple,
45
        pprModuleMap,
46
        isDllName
47
    )
48 49 50
where

#include "HsVersions.h"
51

52
import GHC.PackageDb
53
import PackageConfig
54
import DynFlags
55 56
import Config           ( cProjectVersion )
import Name             ( Name, nameModule_maybe )
57
import UniqFM
58
import Module
59 60 61
import Util
import Panic
import Outputable
62
import Maybes
63

64
import System.Environment ( getEnv )
65
import FastString
66
import ErrUtils         ( debugTraceMsg, MsgDoc )
67
import Exception
68
import Unique
69

Simon Marlow's avatar
Simon Marlow committed
70
import System.Directory
71 72
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
Simon Marlow's avatar
Simon Marlow committed
73
import Control.Monad
74
import Data.List as List
75
import Data.Map (Map)
76
#if __GLASGOW_HASKELL__ < 709
77
import Data.Monoid hiding ((<>))
78
#endif
79 80
import qualified Data.Map as Map
import qualified FiniteMap as Map
81
import qualified Data.Set as Set
Simon Marlow's avatar
Simon Marlow committed
82

83 84 85
-- ---------------------------------------------------------------------------
-- The Package state

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

-- Notes on DLLs
-- ~~~~~~~~~~~~~
124 125 126 127
-- 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
128 129 130
-- When compiling A, we record in B's Module value whether it's
-- in a different DLL, by setting the DLL flag.

131
-- | Given a module name, there may be multiple ways it came into scope,
132 133 134
-- 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!
135
data ModuleOrigin =
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200
    -- | 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
    ppr ModHidden = text "hidden module"
    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 [])
        ))

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

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

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

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"
201 202 203

-- | Is the name from the import actually visible? (i.e. does it cause
-- ambiguity, or is it only relevant when we're making suggestions?)
204 205 206 207 208 209 210 211 212
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
213 214 215 216 217 218

-- | When we do a plain lookup (e.g. for an import), initially, all we want
-- to know is if we can find it or not (and if we do and it's a reexport,
-- what the real name is).  If the find fails, we'll want to investigate more
-- to give a good error message.
data SimpleModuleConf =
219
    SModConf Module PackageConfig ModuleOrigin
220 221
  | SModConfAmbiguous

222
-- | 'UniqFM' map from 'ModuleName'
223 224
type ModuleNameMap = UniqFM

225
-- | 'UniqFM' map from 'PackageKey'
226 227
type PackageKeyMap = UniqFM

228
-- | 'UniqFM' map from 'PackageKey' to 'PackageConfig'
229
type PackageConfigMap = PackageKeyMap PackageConfig
230 231 232 233 234 235 236 237 238 239 240 241 242

-- | 'UniqFM' map from 'PackageKey' to (1) whether or not all modules which
-- 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 =
    PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString)

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

244
data PackageState = PackageState {
245 246 247 248 249 250 251 252 253
  -- | A mapping of 'PackageKey' to 'PackageConfig'.  This list is adjusted
  -- so that only valid packages are here.  Currently, we also flip the
  -- exposed/trusted bits based on package flags; however, the hope is to
  -- stop doing that.
  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.
254
  preloadPackages      :: [PackageKey],
255 256 257 258 259 260 261 262

  -- | This is a simplified map from 'ModuleName' to original 'Module' and
  -- package configuration providing it.
  moduleToPkgConf       :: ModuleNameMap SimpleModuleConf,

  -- | 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.
263
  moduleToPkgConfAll    :: ModuleToPkgConfAll,
264

265 266 267
  -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC
  -- internally deals in package keys but the database may refer to installed
  -- package IDs.
268
  installedPackageIdMap :: InstalledPackageIdMap
269 270
  }

271
type InstalledPackageIdMap = Map InstalledPackageId PackageKey
272
type InstalledPackageIndex = Map InstalledPackageId PackageConfig
273

274
-- | Empty package configuration map
275 276 277
emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap = emptyUFM

278 279 280 281 282 283 284 285
-- | Find the package we know about with the given key (e.g. @foo_HASH@), if any
lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig
lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))

lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig
lookupPackage' = lookupUFM

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

290
-- | Extends the package configuration map with a list of package configs.
291 292
extendPackageConfigMap
   :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
293
extendPackageConfigMap pkg_map new_pkgs
294 295 296
  = foldl add pkg_map new_pkgs
  where add pkg_map p = addToUFM pkg_map (packageConfigId p) p

297 298
-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
299 300 301 302 303 304 305 306 307
getPackageDetails :: DynFlags -> PackageKey -> PackageConfig
getPackageDetails dflags pid =
    expectJust "getPackageDetails" (lookupPackage dflags pid)

-- | Get a list of entries from the package database.  NB: be careful with
-- this function, it may not do what you expect it to.
listPackageConfigMap :: DynFlags -> [PackageConfig]
listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags))

308
-- | Looks up a 'PackageKey' given an 'InstalledPackageId'
309 310 311 312
resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey
resolveInstalledPackageId dflags ipid =
    expectJust "resolveInstalledPackageId"
        (Map.lookup ipid (installedPackageIdMap (pkgState dflags)))
313 314

-- ----------------------------------------------------------------------------
315
-- Loading the package db files and building up the package state
316

317
-- | Call this after 'DynFlags.parseDynFlags'.  It reads the package
318
-- database files, and sets up various internal tables of package
319 320
-- information, according to the package-related flags on the
-- command-line (@-package@, @-hide-package@ etc.)
321 322 323
--
-- 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
324
-- @-package@ flags.
325 326 327
--
-- 'initPackages' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
328
-- 'pkgState' in 'DynFlags' and return a list of packages to
329
-- link in.
330
initPackages :: DynFlags -> IO (DynFlags, [PackageKey])
331
initPackages dflags = do
332 333
  pkg_db <- case pkgDatabase dflags of
                Nothing -> readPackageConfigs dflags
334
                Just db -> return $ setBatchPackageFlags dflags db
335
  (pkg_state, preload, this_pkg)
336
        <- mkPackageState dflags pkg_db [] (thisPackage dflags)
337
  return (dflags{ pkgDatabase = Just pkg_db,
338
                  pkgState = pkg_state,
339 340
                  thisPackage = this_pkg },
          preload)
341 342

-- -----------------------------------------------------------------------------
343 344
-- Reading the package database(s)

345
readPackageConfigs :: DynFlags -> IO [PackageConfig]
346
readPackageConfigs dflags = do
347
  let system_conf_refs = [UserPkgConf, GlobalPkgConf]
348 349 350 351 352 353 354 355 356 357 358

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

361
  let conf_refs = reverse (extraPkgConfs dflags base_conf_refs)
362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377
  -- 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
378

379 380
readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
readPackageConfig dflags conf_file = do
381 382
  isdir <- doesDirectoryExist conf_file

383
  proto_pkg_configs <-
384 385 386
    if isdir
       then do let filename = conf_file </> "package.cache"
               debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
387
               readPackageDbForGhc filename
388
       else do
389
            isfile <- doesFileExist conf_file
390 391
            if isfile
               then throwGhcExceptionIO $ InstallationError $
392 393 394 395
                      "ghc no longer supports single-file style package " ++
                      "databases (" ++ conf_file ++
                      ") use 'ghc-pkg init' to create the database with " ++
                      "the correct format."
396 397
               else throwGhcExceptionIO $ InstallationError $
                      "can't find a package database at " ++ conf_file
398

399 400
  let
      top_dir = topDir dflags
401 402
      pkgroot = takeDirectory conf_file
      pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
403
      pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
404 405
  --
  return pkg_configs2
406

407
setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
408
setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
409
  where
410
    maybeDistrustAll pkgs'
ian@well-typed.com's avatar
ian@well-typed.com committed
411
      | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
412 413
      | otherwise                           = pkgs'

dterei's avatar
dterei committed
414
    distrust pkg = pkg{ trusted = False }
415

416
-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434
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)
    }
435
  where
436 437 438 439
    munge_paths = map munge_path
    munge_urls  = map munge_url

    munge_path p
440 441 442
      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
      | otherwise                                = p
443 444

    munge_url p
445 446 447
      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
      | otherwise                                   = p
448 449 450

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
451 452 453 454 455 456 457 458 459 460 461 462 463
                 ++ 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
464

465

466
-- -----------------------------------------------------------------------------
467 468 469
-- Modify our copy of the package database based on a package flag
-- (-package, -hide-package, -ignore-package).

470 471 472 473 474 475 476
-- | A horrible hack, the problem is the package key we'll turn
-- up here is going to get edited when we select the wired in
-- packages, so preemptively pick up the right one.  Also, this elem
-- test is slow.  The alternative is to change wired in packages first, but
-- then we are no longer able to match against package keys e.g. from when
-- a user passes in a package flag.
calcKey :: PackageConfig -> PackageKey
477
calcKey p | pk <- packageNameString p
478 479 480 481
          , pk `elem` wired_in_pkgids
                      = stringToPackageKey pk
          | otherwise = packageConfigId p

482
applyPackageFlag
Ian Lynagh's avatar
Ian Lynagh committed
483 484
   :: DynFlags
   -> UnusablePackages
485
   -> ([PackageConfig], VisibilityMap)           -- Initial database
486
   -> PackageFlag               -- flag to apply
487
   -> IO ([PackageConfig], VisibilityMap)        -- new database
488

489 490 491 492 493 494
-- ToDo: Unfortunately, we still have to plumb the package config through,
-- because Safe Haskell trust is still implemented by modifying the database.
-- Eventually, track that separately and then axe @[PackageConfig]@ from
-- this fold entirely

applyPackageFlag dflags unusable (pkgs, vm) flag =
495
  case flag of
496
    ExposePackage arg m_rns ->
497
       case selectPackages (matching arg) pkgs unusable of
498
         Left ps         -> packageFlagErr dflags flag ps
499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518
         Right (p:_,_) -> return (pkgs, vm')
          where
           n = fsPackageName p
           vm' = addToUFM_C edit vm_cleared (calcKey p)
                              (case m_rns of
                                   Nothing   -> (True, [], n)
                                   Just rns' -> (False, map convRn rns', n))
           edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
           convRn (a,b) = (mkModuleName a, mkModuleName b)
           -- ToDo: ATM, -hide-all-packages implicitly triggers change in
           -- behavior, maybe eventually make it toggleable with a separate
           -- flag
           vm_cleared | gopt Opt_HideAllPackages dflags = vm
                      -- NB: -package foo-0.1 (Foo as Foo1) does NOT hide
                      -- other versions of foo. Presence of renaming means
                      -- user probably wanted both.
                      | Just _ <- m_rns = vm
                      | otherwise = filterUFM_Directly
                            (\k (_,_,n') -> k == getUnique (calcKey p)
                                                || n /= n') vm
519 520
         _ -> panic "applyPackageFlag"

521 522
    HidePackage str ->
       case selectPackages (matchingStr str) pkgs unusable of
Ian Lynagh's avatar
Ian Lynagh committed
523
         Left ps       -> packageFlagErr dflags flag ps
524 525
         Right (ps,_) -> return (pkgs, vm')
          where vm' = delListFromUFM vm (map calcKey ps)
526

527 528 529 530
    -- 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
531
         Left ps       -> packageFlagErr dflags flag ps
532
         Right (ps,qs) -> return (map trust ps ++ qs, vm)
533
          where trust p = p {trusted=True}
534 535 536

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

541
    IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage"
542 543 544 545 546 547

selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
               -> UnusablePackages
               -> Either [(PackageConfig, UnusablePackageReason)]
                  ([PackageConfig], [PackageConfig])
selectPackages matches pkgs unusable
548 549 550 551
  = let (ps,rest) = partition matches pkgs
    in if null ps
        then Left (filter (matches.fst) (Map.elems unusable))
        else Right (sortByVersion ps, rest)
552 553 554

-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
555 556
matchingStr :: String -> PackageConfig -> Bool
matchingStr str p
557 558
        =  str == sourcePackageIdString p
        || str == packageNameString p
559

560
matchingId :: String -> PackageConfig -> Bool
561
matchingId str p =  str == installedPackageIdString p
562

563
matchingKey :: String -> PackageConfig -> Bool
564
matchingKey str p = str == packageKeyString (packageConfigId p)
565

566 567 568 569 570
matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg str) = matchingStr str
matching (PackageIdArg str) = matchingId str
matching (PackageKeyArg str) = matchingKey str

571 572
sortByVersion :: [PackageConfig] -> [PackageConfig]
sortByVersion = sortBy (flip (comparing packageVersion))
Ian Lynagh's avatar
Ian Lynagh committed
573 574

comparing :: Ord a => (t -> a) -> t -> t -> Ordering
575 576
comparing f a b = f a `compare` f b

Ian Lynagh's avatar
Ian Lynagh committed
577 578
packageFlagErr :: DynFlags
               -> PackageFlag
579 580
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
581 582 583

-- for missing DPH package we emit a more helpful error message, because
-- this may be the result of using -fdph-par or -fdph-seq.
584 585
packageFlagErr dflags (ExposePackage (PackageArg pkg) _) []
  | is_dph_package pkg
586
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
587 588 589
  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
590

591 592
packageFlagErr dflags flag reasons
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
593
  where err = text "cannot satisfy " <> pprFlag flag <>
594
                (if null reasons then Outputable.empty else text ": ") $$
595
              nest 4 (ppr_reasons $$
596
                      -- ToDo: this admonition seems a bit dodgy
597 598
                      text "(use -v for more information)")
        ppr_reasons = vcat (map ppr_reason reasons)
599 600
        ppr_reason (p, reason) =
            pprReason (ppr (installedPackageId p) <+> text "is") reason
601

602 603 604 605 606 607 608 609 610 611 612
pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
    IgnorePackage p -> text "-ignore-package " <> text p
    HidePackage p   -> text "-hide-package " <> text p
    ExposePackage a rns -> ppr_arg a <> ppr_rns rns
    TrustPackage p    -> text "-trust " <> text p
    DistrustPackage p -> text "-distrust " <> text p
  where ppr_arg arg = case arg of
                     PackageArg    p -> text "-package " <> text p
                     PackageIdArg  p -> text "-package-id " <> text p
                     PackageKeyArg p -> text "-package-key " <> text p
613
        ppr_rns Nothing = Outputable.empty
614 615 616 617
        ppr_rns (Just rns) = char '(' <> hsep (punctuate comma (map ppr_rn rns))
                                      <> char ')'
        ppr_rn (orig, new) | orig == new = text orig
                           | otherwise = text orig <+> text "as" <+> text new
618

619 620 621
-- -----------------------------------------------------------------------------
-- Wired-in packages

622 623 624
wired_in_pkgids :: [String]
wired_in_pkgids = map packageKeyString wiredInPackageKeys

625 626 627
findWiredInPackages
   :: DynFlags
   -> [PackageConfig]           -- database
628
   -> IO [PackageConfig]
629

630
findWiredInPackages dflags pkgs = do
Simon Marlow's avatar
Simon Marlow committed
631 632 633 634 635
  --
  -- Now we must find our wired-in packages, and rename them to
  -- their canonical names (eg. base-1.0 ==> base).
  --
  let
636
        matches :: PackageConfig -> String -> Bool
637
        pc `matches` pid = packageNameString pc == pid
Simon Marlow's avatar
Simon Marlow committed
638

639 640 641 642
        -- 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.
643 644
        --
        -- When choosing which package to map to a wired-in package
645 646 647 648
        -- name, we pick the latest version (modern Cabal makes it difficult
        -- to install multiple versions of wired-in packages, however!)
        -- To override the default choice, -ignore-package could be used to
        -- hide newer versions.
649
        --
650 651 652
        findWiredInPackage :: [PackageConfig] -> String
                           -> IO (Maybe InstalledPackageId)
        findWiredInPackage pkgs wired_pkg =
653
           let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
654 655 656
           case all_ps of
                []   -> notfound
                many -> pick (head (sortByVersion many))
657 658
          where
                notfound = do
659 660 661 662 663
                          debugTraceMsg dflags 2 $
                            ptext (sLit "wired-in package ")
                                 <> text wired_pkg
                                 <> ptext (sLit " not found.")
                          return Nothing
664
                pick :: PackageConfig
665
                     -> IO (Maybe InstalledPackageId)
666 667
                pick pkg = do
                        debugTraceMsg dflags 2 $
668 669 670
                            ptext (sLit "wired-in package ")
                                 <> text wired_pkg
                                 <> ptext (sLit " mapped to ")
671
                                 <> ppr (installedPackageId pkg)
672
                        return (Just (installedPackageId pkg))
673

Simon Marlow's avatar
Simon Marlow committed
674

675
  mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids
676
  let
Simon Marlow's avatar
Simon Marlow committed
677 678
        wired_in_ids = catMaybes mb_wired_in_ids

679 680 681 682 683 684 685 686
        -- 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.
        {-
687 688
        deleteOtherWiredInPackages pkgs = filterOut bad pkgs
          where bad p = any (p `matches`) wired_in_pkgids
689 690
                      && package p `notElem` map fst wired_in_ids
        -}
Simon Marlow's avatar
Simon Marlow committed
691

692
        updateWiredInDependencies pkgs = map upd_pkg pkgs
693 694
          where upd_pkg pkg
                  | installedPackageId pkg `elem` wired_in_ids
695 696 697
                  = pkg {
                      packageKey = stringToPackageKey (packageNameString pkg)
                    }
698
                  | otherwise
699
                  = pkg
Simon Marlow's avatar
Simon Marlow committed
700

701
  return $ updateWiredInDependencies pkgs
702

703 704 705 706 707 708 709
-- ----------------------------------------------------------------------------

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

710 711
type UnusablePackages = Map InstalledPackageId
                            (PackageConfig, UnusablePackageReason)
712 713 714 715 716 717 718 719

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:") $$
720
        nest 2 (hsep (map ppr deps))
721
  ShadowedBy ipid ->
722
      pref <+> ptext (sLit "shadowed by package ") <> ppr ipid
723 724

reportUnusable :: DynFlags -> UnusablePackages -> IO ()
725
reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
726
  where
727
    report (ipid, (_, reason)) =
728 729 730
       debugTraceMsg dflags 2 $
         pprReason
           (ptext (sLit "package") <+>
731
            ppr ipid <+> text "is") reason
732

733
-- ----------------------------------------------------------------------------
734
--
735 736 737 738 739
-- 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.
740
--
741
findBroken :: [PackageConfig] -> UnusablePackages
742
findBroken pkgs = go [] Map.empty pkgs
743
 where
744 745 746
   go avail ipids not_avail =
     case partitionWith (depsAvailable ipids) not_avail of
        ([], not_avail) ->
747
            Map.fromList [ (installedPackageId p, (p, MissingDependencies deps))
748
                         | (p,deps) <- not_avail ]
749 750
        (new_avail, not_avail) ->
            go (new_avail ++ avail) new_ipids (map fst not_avail)
751
            where new_ipids = Map.insertList
752
                                [ (installedPackageId p, p) | p <- new_avail ]
753
                                ipids
754

755
   depsAvailable :: InstalledPackageIndex
756
                 -> PackageConfig
757
                 -> Either PackageConfig (PackageConfig, [InstalledPackageId])
758
   depsAvailable ipids pkg
759 760
        | null dangling = Left pkg
        | otherwise     = Right (pkg, dangling)
761
        where dangling = filter (not . (`Map.member` ipids)) (depends pkg)
762

763 764 765 766
-- -----------------------------------------------------------------------------
-- Eliminate shadowed packages, giving the user some feedback

-- later packages in the list should shadow earlier ones with the same
767 768 769
-- package name/version.  Additionally, a package may be preferred if
-- it is in the transitive closure of packages selected using -package-id
-- flags.
770
type UnusablePackage = (PackageConfig, UnusablePackageReason)
771 772 773
shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
shadowPackages pkgs preferred
 = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
774
   in  Map.fromList shadowed
775
 where
776 777 778
 check :: ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
       -> PackageConfig
       -> ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
779
 check (shadowed,pkgmap) pkg
780
      | Just oldpkg <- lookupUFM pkgmap pkgid
781
      , let
782
            ipid_new = installedPackageId pkg
783
            ipid_old = installedPackageId oldpkg
784
        --
785
      , ipid_old /= ipid_new
786
      = if ipid_old `elem` preferred
787 788
           then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap)
           else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap')
789
      | otherwise
790 791
      = (shadowed, pkgmap')
      where
792
        pkgid = packageKeyFS (packageKey pkg)
793
        pkgmap' = addToUFM pkgmap pkgid pkg
794 795 796 797

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

ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
798
ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
799 800 801
  where
  doit (IgnorePackage str) =
     case partition (matchingStr str) pkgs of
802
         (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag))
803
                    | p <- ps ]
804 805 806
        -- 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.
807
  doit _ = panic "ignorePackages"
808

809 810 811 812 813
-- -----------------------------------------------------------------------------

depClosure :: InstalledPackageIndex
           -> [InstalledPackageId]
           -> [InstalledPackageId]
814
depClosure index ipids = closure Map.empty ipids
815
  where
816
   closure set [] = Map.keys set
817
   closure set (ipid : ipids)
818
     | ipid `Map.member` set = closure set ipids
819
     | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set)
820
                                                 (depends p ++ ipids)
821 822
     | otherwise = closure set ipids

823 824 825 826 827 828
-- -----------------------------------------------------------------------------
-- When all the command-line options are in, we can process our package
-- settings and populate the package state.

mkPackageState
    :: DynFlags
829
    -> [PackageConfig]          -- initial database
830 831
    -> [PackageKey]              -- preloaded packages
    -> PackageKey                -- this package
832
    -> IO (PackageState,
833 834
           [PackageKey],         -- new packages to preload
           PackageKey) -- this package, might be modified if the current
835 836
                      -- package is a wired-in package.

837 838
mkPackageState dflags pkgs0 preload0 this_package = do

839 840 841
{-
   Plan.

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

   2. Apply shadowing.  When there are multiple packages with the same
845
      packageKey,
846 847 848
        * if one is in P, use that one
        * otherwise, use the one highest in the package stack
      [
849 850
       rationale: we cannot use two packages with the same packageKey
       in the same program, because packageKey is the symbol prefix.
851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876
       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
-}

877
  let
878
      flags = reverse (packageFlags dflags)
879

880
      -- pkgs0 with duplicate packages filtered out.  This is
881 882 883
      -- 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
884 885
      -- as shadowing (below), since in this case the two packages
      -- have the same ABI and are interchangeable.
886 887 888 889 890 891 892 893 894 895
      --
      -- #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

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

898
      ipid_selected = depClosure ipid_map
899
                                 [ InstalledPackageId (mkFastString i)
900
                                 | ExposePackage (PackageIdArg i) _ <- flags ]
901

902 903 904 905
      (ignore_flags, other_flags) = partition is_ignore flags
      is_ignore IgnorePackage{} = True
      is_ignore _ = False

906 907
      shadowed = shadowPackages pkgs0_unique ipid_selected
      ignored  = ignorePackages ignore_flags pkgs0_unique
908

909 910 911
      isBroken = (`Map.member` (Map.union shadowed ignored)).installedPackageId
      pkgs0' = filter (not . isBroken) pkgs0_unique

912
      broken   = findBroken pkgs0'
913

914
      unusable = shadowed `Map.union` ignored `Map.union` broken
915
      pkgs1 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs0'
916 917 918

  reportUnusable dflags unusable

919 920 921 922 923 924
  --
  -- Calculate the initial set of packages, prior to any package flags.
  -- This set contains the latest version of all valid (not unusable) packages,
  -- or is empty if we have -hide-all-packages
  --
  let preferLater pkg pkg' =
925
        case comparing packageVersion pkg pkg' of
926 927 928 929 930 931 932 933 934 935 936 937 938
            GT -> pkg
            _  -> pkg'
      calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg
      initial = if gopt Opt_HideAllPackages dflags
                    then emptyUFM
                    else foldl' calcInitial emptyUFM pkgs1
      vis_map0 = foldUFM (\p vm ->
                            if exposed p
                               then addToUFM vm (calcKey p)
                                             (True, [], fsPackageName p)
                               else vm)
                         emptyUFM initial

939
  --
940 941
  -- Modify the package database according to the command-line flags
  -- (-package, -hide-package, -ignore-package, -hide-all-packages).
942 943
  -- This needs to know about the unusable packages, since if a user tries
  -- to enable an unusable package, we should let them know.
944
  --
945 946
  (pkgs2, vis_map) <- foldM (applyPackageFlag dflags unusable)
                            (pkgs1, vis_map0) other_flags
947

948 949 950 951 952 953 954 955
  --
  -- Sort out which packages are wired in. This has to be done last, since
  -- it modifies the package keys of wired in packages, but when we process
  -- package arguments we need to key against the old versions.
  --
  pkgs3 <- findWiredInPackages dflags pkgs2

  --
956 957 958 959 960
  -- 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.
961
  --
962 963
  let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]

964 965 966
      get_exposed (ExposePackage a _) = take 1 . sortByVersion
                                      . filter (matching a)
                                      $ pkgs2
967
      get_exposed _                 = []
968

969
  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3
970

971
      ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
972
                              | p <- pkgs3 ]