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

Edward Z. Yang's avatar
Edward Z. Yang committed
3
{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}
4

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

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

        -- * Querying the package config
        lookupPackage,
Edward Z. Yang's avatar
Edward Z. Yang committed
22
        lookupPackage',
23
        lookupInstalledPackage,
Edward Z. Yang's avatar
Edward Z. Yang committed
24 25
        lookupPackageName,
        improveUnitId,
26
        searchPackageId,
27
        getPackageDetails,
28
        getInstalledPackageDetails,
Edward Z. Yang's avatar
Edward Z. Yang committed
29
        componentIdString,
30
        displayInstalledUnitId,
31
        listVisibleModuleNames,
32 33
        lookupModuleInAllPackages,
        lookupModuleWithSuggestions,
34
        lookupPluginModuleWithSuggestions,
35
        LookupResult(..),
36 37
        ModuleSuggestion(..),
        ModuleOrigin(..),
38 39 40 41 42 43 44 45

        -- * Inspecting the set of packages in scope
        getPackageIncludePath,
        getPackageLibraryPath,
        getPackageLinkOpts,
        getPackageExtraCcOpts,
        getPackageFrameworkPath,
        getPackageFrameworks,
Edward Z. Yang's avatar
Edward Z. Yang committed
46
        getPackageConfigMap,
47
        getPreloadPackagesAnd,
48

49
        collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
50
        packageHsLibs,
51

52
        -- * Utils
Edward Z. Yang's avatar
Edward Z. Yang committed
53
        unwireUnitId,
54
        pprFlag,
55 56
        pprPackages,
        pprPackagesSimple,
57
        pprModuleMap,
58
        isDllName
59
    )
60 61 62
where

#include "HsVersions.h"
63

64
import GHC.PackageDb
65
import PackageConfig
66
import DynFlags
67
import Name             ( Name, nameModule_maybe )
68
import UniqFM
niteria's avatar
niteria committed
69
import UniqDFM
70
import UniqSet
71
import Module
72 73 74
import Util
import Panic
import Outputable
75
import Maybes
76

77
import System.Environment ( getEnv )
78
import FastString
Edward Z. Yang's avatar
Edward Z. Yang committed
79
import ErrUtils         ( debugTraceMsg, MsgDoc, printInfoForUser )
80
import Exception
81

Simon Marlow's avatar
Simon Marlow committed
82
import System.Directory
83 84
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
Simon Marlow's avatar
Simon Marlow committed
85
import Control.Monad
86
import Data.Graph (stronglyConnComp, SCC(..))
87
import Data.Char ( toUpper )
88
import Data.List as List
89
import Data.Map (Map)
90
import Data.Set (Set)
Edward Z. Yang's avatar
Edward Z. Yang committed
91
import Data.Monoid (First(..))
92 93 94 95
#if __GLASGOW_HASKELL__ > 710
import Data.Semigroup   ( Semigroup )
import qualified Data.Semigroup as Semigroup
#endif
96
import qualified Data.Map as Map
97
import qualified Data.Map.Strict as MapStrict
98
import qualified Data.Set as Set
99
import Data.Version
Simon Marlow's avatar
Simon Marlow committed
100

101 102 103
-- ---------------------------------------------------------------------------
-- The Package state

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

-- Notes on DLLs
-- ~~~~~~~~~~~~~
142 143 144 145
-- 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
146 147 148
-- When compiling A, we record in B's Module value whether it's
-- in a different DLL, by setting the DLL flag.

149
-- | Given a module name, there may be multiple ways it came into scope,
150 151 152
-- 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!
153
data ModuleOrigin =
154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
    -- | 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
176
    ppr ModHidden = text "hidden module"
177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192
    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 [])
        ))

193 194 195 196
-- | 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
197

198 199 200 201 202 203
-- | 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
204 205 206 207 208

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

209 210 211 212 213 214 215 216 217 218 219 220
#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

221 222 223 224 225 226 227 228 229 230
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"
231 232 233

-- | Is the name from the import actually visible? (i.e. does it cause
-- ambiguity, or is it only relevant when we're making suggestions?)
234 235 236 237 238 239 240 241 242
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
243

244 245 246 247 248 249 250 251 252 253 254 255
-- | 'UniqFM' map from 'InstalledUnitId'
type InstalledUnitIdMap = UniqDFM

-- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus
-- the transitive closure of preload packages.
data PackageConfigMap = PackageConfigMap {
        unPackageConfigMap :: InstalledUnitIdMap PackageConfig,
        -- | The set of transitively reachable packages according
        -- to the explicitly provided command line arguments.
        -- See Note [UnitId to InstalledUnitId improvement]
        preloadClosure :: UniqSet InstalledUnitId
    }
Edward Z. Yang's avatar
Edward Z. Yang committed
256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271

-- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'.
type VisibilityMap = Map UnitId UnitVisibility

-- | 'UnitVisibility' records the various aspects of visibility of a particular
-- 'UnitId'.
data UnitVisibility = UnitVisibility
    { uv_expose_all :: Bool
      --  ^ Should all modules in exposed-modules should be dumped into scope?
    , uv_renamings :: [(ModuleName, ModuleName)]
      -- ^ Any custom renamings that should bring extra 'ModuleName's into
      -- scope.
    , uv_package_name :: First FastString
      -- ^ The package name is associated with the 'UnitId'.  This is used
      -- to implement legacy behavior where @-package foo-0.1@ implicitly
      -- hides any packages named @foo@
272
    , uv_requirements :: Map ModuleName (Set IndefModule)
Edward Z. Yang's avatar
Edward Z. Yang committed
273 274 275 276 277 278 279
      -- ^ The signatures which are contributed to the requirements context
      -- from this unit ID.
    , uv_explicit :: Bool
      -- ^ Whether or not this unit was explicitly brought into scope,
      -- as opposed to implicitly via the 'exposed' fields in the
      -- package database (when @-hide-all-packages@ is not passed.)
    }
280

Edward Z. Yang's avatar
Edward Z. Yang committed
281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304
instance Outputable UnitVisibility where
    ppr (UnitVisibility {
        uv_expose_all = b,
        uv_renamings = rns,
        uv_package_name = First mb_pn,
        uv_requirements = reqs,
        uv_explicit = explicit
    }) = ppr (b, rns, mb_pn, reqs, explicit)
instance Monoid UnitVisibility where
    mempty = UnitVisibility
             { uv_expose_all = False
             , uv_renamings = []
             , uv_package_name = First Nothing
             , uv_requirements = Map.empty
             , uv_explicit = False
             }
    mappend uv1 uv2
        = UnitVisibility
          { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
          , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
          , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
          , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
          , uv_explicit = uv_explicit uv1 || uv_explicit uv2
          }
305

306 307 308
type WiredUnitId = DefUnitId
type PreloadUnitId = InstalledUnitId

309 310 311 312 313
-- | 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)
314

315
data PackageState = PackageState {
316
  -- | A mapping of 'UnitId' to 'PackageConfig'.  This list is adjusted
317 318 319 320
  -- 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'.)
321 322
  pkgIdMap              :: PackageConfigMap,

Edward Z. Yang's avatar
Edward Z. Yang committed
323 324 325 326 327 328
  -- | A mapping of 'PackageName' to 'ComponentId'.  This is used when
  -- users refer to packages in Backpack includes.
  packageNameMap            :: Map PackageName ComponentId,

  -- | A mapping from wired in names to the original names from the
  -- package database.
329
  unwireMap :: Map WiredUnitId WiredUnitId,
Edward Z. Yang's avatar
Edward Z. Yang committed
330

331 332 333
  -- | 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.
334
  preloadPackages      :: [PreloadUnitId],
335

336 337 338 339
  -- | Packages which we explicitly depend on (from a command line flag).
  -- We'll use this to generate version macros.
  explicitPackages      :: [UnitId],

340 341 342
  -- | 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.
343
  moduleToPkgConfAll    :: !ModuleToPkgConfAll,
344 345

  -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility.
Edward Z. Yang's avatar
Edward Z. Yang committed
346 347 348 349 350 351 352 353 354
  pluginModuleToPkgConfAll    :: !ModuleToPkgConfAll,

  -- | A map saying, for each requirement, what interfaces must be merged
  -- together when we use them.  For example, if our dependencies
  -- are @p[A=<A>]@ and @q[A=<A>,B=r[C=<A>]:B]@, then the interfaces
  -- to merge for A are @p[A=<A>]:A@, @q[A=<A>,B=r[C=<A>]:B]:A@
  -- and @r[C=<A>]:C@.
  --
  -- There's an entry in this map for each hole in our home library.
355
  requirementContext :: Map ModuleName [IndefModule]
356 357
  }

358 359
emptyPackageState :: PackageState
emptyPackageState = PackageState {
niteria's avatar
niteria committed
360
    pkgIdMap = emptyPackageConfigMap,
Edward Z. Yang's avatar
Edward Z. Yang committed
361 362
    packageNameMap = Map.empty,
    unwireMap = Map.empty,
363
    preloadPackages = [],
364
    explicitPackages = [],
365
    moduleToPkgConfAll = Map.empty,
Edward Z. Yang's avatar
Edward Z. Yang committed
366 367
    pluginModuleToPkgConfAll = Map.empty,
    requirementContext = Map.empty
368 369
    }

370
type InstalledPackageIndex = Map InstalledUnitId PackageConfig
371

372
-- | Empty package configuration map
373
emptyPackageConfigMap :: PackageConfigMap
374
emptyPackageConfigMap = PackageConfigMap emptyUDFM emptyUniqSet
375

Edward Z. Yang's avatar
Edward Z. Yang committed
376
-- | Find the package we know about with the given unit id, if any
377
lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
Edward Z. Yang's avatar
Edward Z. Yang committed
378 379 380 381 382 383 384
lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags))

-- | A more specialized interface, which takes a boolean specifying
-- whether or not to look for on-the-fly renamed interfaces, and
-- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can
-- be used while we're initializing 'DynFlags'
lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
385 386
lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid
lookupPackage' True m@(PackageConfigMap pkg_map _) uid =
Edward Z. Yang's avatar
Edward Z. Yang committed
387
    case splitUnitIdInsts uid of
388 389
        (iuid, Just indef) ->
            fmap (renamePackage m (indefUnitIdInsts indef))
Edward Z. Yang's avatar
Edward Z. Yang committed
390 391 392
                 (lookupUDFM pkg_map iuid)
        (_, Nothing) -> lookupUDFM pkg_map uid

393
{-
Edward Z. Yang's avatar
Edward Z. Yang committed
394 395 396 397 398 399 400
-- | Find the indefinite package for a given 'ComponentId'.
-- The way this works is just by fiat'ing that every indefinite package's
-- unit key is precisely its component ID; and that they share uniques.
lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig
lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs
  where
    PackageConfigMap pkg_map = pkgIdMap (pkgState dflags)
401
-}
402

Edward Z. Yang's avatar
Edward Z. Yang committed
403 404 405 406
-- | Find the package we know about with the given package name (e.g. @foo@), if any
-- (NB: there might be a locally defined unit name which overrides this)
lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId
lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags))
407 408

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

413
-- | Extends the package configuration map with a list of package configs.
414 415
extendPackageConfigMap
   :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
416 417
extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs
  = PackageConfigMap (foldl add pkg_map new_pkgs) closure
Edward Z. Yang's avatar
Edward Z. Yang committed
418 419 420
    -- We also add the expanded version of the packageConfigId, so that
    -- 'improveUnitId' can find it.
  where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p)
421
                                  (installedPackageConfigId p) p
422

423 424
-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
425
getPackageDetails :: DynFlags -> UnitId -> PackageConfig
426 427 428
getPackageDetails dflags pid =
    expectJust "getPackageDetails" (lookupPackage dflags pid)

429 430 431 432 433 434 435 436 437 438 439
lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid

lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid

getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig
getInstalledPackageDetails dflags uid =
    expectJust "getInstalledPackageDetails" $
        lookupInstalledPackage dflags uid

440
-- | Get a list of entries from the package database.  NB: be careful with
441 442 443
-- 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).
444
listPackageConfigMap :: DynFlags -> [PackageConfig]
Edward Z. Yang's avatar
Edward Z. Yang committed
445 446
listPackageConfigMap dflags = eltsUDFM pkg_map
  where
447
    PackageConfigMap pkg_map _ = pkgIdMap (pkgState dflags)
448

449
-- ----------------------------------------------------------------------------
450
-- Loading the package db files and building up the package state
451

452
-- | Call this after 'DynFlags.parseDynFlags'.  It reads the package
453
-- database files, and sets up various internal tables of package
454 455
-- information, according to the package-related flags on the
-- command-line (@-package@, @-hide-package@ etc.)
456 457 458
--
-- 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
459
-- @-package@ flags.
460 461 462
--
-- 'initPackages' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
463
-- 'pkgState' in 'DynFlags' and return a list of packages to
464
-- link in.
465
initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId])
466 467
initPackages dflags0 = do
  dflags <- interpretPackageEnv dflags0
468 469 470 471 472
  pkg_db <-
    case pkgDatabase dflags of
        Nothing -> readPackageConfigs dflags
        Just db -> return $ map (\(p, pkgs)
                                    -> (p, setBatchPackageFlags dflags pkgs)) db
473
  (pkg_state, preload, insts)
474
        <- mkPackageState dflags pkg_db []
475
  return (dflags{ pkgDatabase = Just pkg_db,
476 477
                  pkgState = pkg_state,
                  thisUnitIdInsts_ = insts },
478
          preload)
479 480

-- -----------------------------------------------------------------------------
481 482
-- Reading the package database(s)

483
readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])]
484
readPackageConfigs dflags = do
485 486
  conf_refs <- getPackageConfRefs dflags
  confs     <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
487 488
  mapM (readPackageConfig dflags) confs

489 490 491

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

494
  e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
495 496 497
  let base_conf_refs = case e_pkg_path of
        Left _ -> system_conf_refs
        Right path
498 499
         | not (null path) && isSearchPathSeparator (last path)
         -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs
500
         | otherwise
501
         -> map PkgConfFile (splitSearchPath path)
502

503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522
  -- Apply the package DB-related flags from the command line to get the
  -- final list of package DBs.
  --
  -- Notes on ordering:
  --  * The list of flags is reversed (later ones first)
  --  * We work with the package DB list in "left shadows right" order
  --  * and finally reverse it at the end, to get "right shadows left"
  --
  return $ reverse (foldr doFlag base_conf_refs (packageDBFlags dflags))
 where
  doFlag (PackageDB p) dbs = p : dbs
  doFlag NoUserPackageDB dbs = filter isNotUser dbs
  doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs
  doFlag ClearPackageDBs _ = []

  isNotUser UserPkgConf = False
  isNotUser _ = True

  isNotGlobal GlobalPkgConf = False
  isNotGlobal _ = True
523 524 525

resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
526 527 528
-- 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.)
529
resolvePackageConfig dflags UserPkgConf = runMaybeT $ do
530
  dir <- versionedAppDir dflags
Edsko de Vries's avatar
Edsko de Vries committed
531
  let pkgconf = dir </> "package.conf.d"
532 533
  exist <- tryMaybeT $ doesDirectoryExist pkgconf
  if exist then return pkgconf else mzero
534
resolvePackageConfig _ (PkgConfFile name) = return $ Just name
535

536
readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig])
537
readPackageConfig dflags conf_file = do
538 539
  isdir <- doesDirectoryExist conf_file

540
  proto_pkg_configs <-
541
    if isdir
542
       then readDirStylePackageConfig conf_file
543
       else do
544
            isfile <- doesFileExist conf_file
545
            if isfile
546 547 548 549 550
               then do
                 mpkgs <- tryReadOldFileStylePackageConfig
                 case mpkgs of
                   Just pkgs -> return pkgs
                   Nothing   -> throwGhcExceptionIO $ InstallationError $
551 552 553 554
                      "ghc no longer supports single-file style package " ++
                      "databases (" ++ conf_file ++
                      ") use 'ghc-pkg init' to create the database with " ++
                      "the correct format."
555 556
               else throwGhcExceptionIO $ InstallationError $
                      "can't find a package database at " ++ conf_file
557

558 559
  let
      top_dir = topDir dflags
560
      pkgroot = takeDirectory conf_file
561 562
      pkg_configs1 = map (mungePackageConfig top_dir pkgroot)
                         proto_pkg_configs
563
      pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
564
  --
565
  return (conf_file, pkg_configs2)
566 567 568
  where
    readDirStylePackageConfig conf_dir = do
      let filename = conf_dir </> "package.cache"
569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595
      cache_exists <- doesFileExist filename
      if cache_exists
        then do
          debugTraceMsg dflags 2 $ text "Using binary package database:"
                                    <+> text filename
          readPackageDbForGhc filename
        else do
          -- If there is no package.cache file, we check if the database is not
          -- empty by inspecting if the directory contains any .conf file. If it
          -- does, something is wrong and we fail. Otherwise we assume that the
          -- database is empty.
          debugTraceMsg dflags 2 $ text "There is no package.cache in"
                               <+> text conf_dir
                                <> text ", checking if the database is empty"
          db_empty <- all (not . isSuffixOf ".conf")
                   <$> getDirectoryContents conf_dir
          if db_empty
            then do
              debugTraceMsg dflags 3 $ text "There are no .conf files in"
                                   <+> text conf_dir <> text ", treating"
                                   <+> text "package database as empty"
              return []
            else do
              throwGhcExceptionIO $ InstallationError $
                "there is no package.cache in " ++ conf_dir ++
                " even though package database is not empty"

596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615

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

617
setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
618
setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
619
  where
620
    maybeDistrustAll pkgs'
ian@well-typed.com's avatar
ian@well-typed.com committed
621
      | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
622 623
      | otherwise                           = pkgs'

dterei's avatar
dterei committed
624
    distrust pkg = pkg{ trusted = False }
625

626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641
mungePackageConfig :: FilePath -> FilePath
                   -> PackageConfig -> PackageConfig
mungePackageConfig top_dir pkgroot =
    mungeDynLibFields
  . mungePackagePaths top_dir pkgroot

mungeDynLibFields :: PackageConfig -> PackageConfig
mungeDynLibFields pkg =
    pkg {
      libraryDynDirs     = libraryDynDirs pkg
                `orIfNull` libraryDirs pkg
    }
  where
    orIfNull [] flags = flags
    orIfNull flags _  = flags

642
-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
643 644 645 646 647 648 649 650 651 652 653 654 655 656
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),
657
      libraryDynDirs = munge_paths (libraryDynDirs pkg),
658 659 660 661
      frameworkDirs = munge_paths (frameworkDirs pkg),
      haddockInterfaces = munge_paths (haddockInterfaces pkg),
      haddockHTMLs = munge_urls (haddockHTMLs pkg)
    }
662
  where
663 664 665 666
    munge_paths = map munge_path
    munge_urls  = map munge_url

    munge_path p
667 668 669
      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
      | otherwise                                = p
670 671

    munge_url p
672 673 674
      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
      | otherwise                                   = p
675 676 677

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
678 679 680 681 682 683 684 685 686 687 688 689 690
                 ++ 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
691

692

693
-- -----------------------------------------------------------------------------
694 695 696 697 698
-- Modify our copy of the package database based on trust flags,
-- -trust and -distrust.

applyTrustFlag
   :: DynFlags
699
   -> PackagePrecedenceIndex
700 701 702 703
   -> UnusablePackages
   -> [PackageConfig]
   -> TrustFlag
   -> IO [PackageConfig]
704
applyTrustFlag dflags prec_map unusable pkgs flag =
705 706 707 708
  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 ->
709
       case selectPackages prec_map (PackageArg str) pkgs unusable of
710 711 712 713 714
         Left ps       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map trust ps ++ qs)
          where trust p = p {trusted=True}

    DistrustPackage str ->
715
       case selectPackages prec_map (PackageArg str) pkgs unusable of
716 717 718
         Left ps       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map distrust ps ++ qs)
          where distrust p = p {trusted=False}
719

Edward Z. Yang's avatar
Edward Z. Yang committed
720 721 722 723 724
-- | A little utility to tell if the 'thisPackage' is indefinite
-- (if it is not, we should never use on-the-fly renaming.)
isIndefinite :: DynFlags -> Bool
isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags))

725
applyPackageFlag
Ian Lynagh's avatar
Ian Lynagh committed
726
   :: DynFlags
727
   -> PackagePrecedenceIndex
Edward Z. Yang's avatar
Edward Z. Yang committed
728
   -> PackageConfigMap
Ian Lynagh's avatar
Ian Lynagh committed
729
   -> UnusablePackages
730 731
   -> Bool -- if False, if you expose a package, it implicitly hides
           -- any previously exposed packages with the same name
732 733
   -> [PackageConfig]
   -> VisibilityMap           -- Initially exposed
734
   -> PackageFlag               -- flag to apply
735
   -> IO VisibilityMap        -- Now exposed
736

737
applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag =
738
  case flag of
739
    ExposePackage _ arg (ModRenaming b rns) ->
740
       case findPackages prec_map pkg_db arg pkgs unusable of
741
         Left ps         -> packageFlagErr dflags flag ps
Edward Z. Yang's avatar
Edward Z. Yang committed
742
         Right (p:_) -> return vm'
743 744
          where
           n = fsPackageName p
Edward Z. Yang's avatar
Edward Z. Yang committed
745 746 747 748 749 750 751 752 753 754

           -- If a user says @-unit-id p[A=<A>]@, this imposes
           -- a requirement on us: whatever our signature A is,
           -- it must fulfill all of p[A=<A>]:A's requirements.
           -- This method is responsible for computing what our
           -- inherited requirements are.
           reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid
                | otherwise                 = Map.empty

           collectHoles uid = case splitUnitIdInsts uid of
755 756
                (_, Just indef) ->
                  let local = [ Map.singleton
Edward Z. Yang's avatar
Edward Z. Yang committed
757
                                  (moduleName mod)
758 759
                                  (Set.singleton $ IndefModule indef mod_name)
                              | (mod_name, mod) <- indefUnitIdInsts indef
Edward Z. Yang's avatar
Edward Z. Yang committed
760 761
                              , isHoleModule mod ]
                      recurse = [ collectHoles (moduleUnitId mod)
762
                                | (_, mod) <- indefUnitIdInsts indef ]
Edward Z. Yang's avatar
Edward Z. Yang committed
763 764 765 766 767 768 769 770 771 772 773 774 775
                  in Map.unionsWith Set.union $ local ++ recurse
                -- Other types of unit identities don't have holes
                (_, Nothing) -> Map.empty


           uv = UnitVisibility
                { uv_expose_all = b
                , uv_renamings = rns
                , uv_package_name = First (Just n)
                , uv_requirements = reqs
                , uv_explicit = True
                }
           vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared
776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796
           -- 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
Edward Z. Yang's avatar
Edward Z. Yang committed
797 798 799 800 801
                      -- NB: renamings never clear
                      | (_:_) <- rns = vm
                      | otherwise = Map.filterWithKey
                            (\k uv -> k == packageConfigId p
                                   || First (Just n) /= uv_package_name uv) vm
802 803
         _ -> panic "applyPackageFlag"

804
    HidePackage str ->
805
       case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of
Edward Z. Yang's avatar
Edward Z. Yang committed
806 807 808 809 810 811 812
         Left ps  -> packageFlagErr dflags flag ps
         Right ps -> return vm'
          where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps)

-- | Like 'selectPackages', but doesn't return a list of unmatched
-- packages.  Furthermore, any packages it returns are *renamed*
-- if the 'UnitArg' has a renaming associated with it.
813 814
findPackages :: PackagePrecedenceIndex
             -> PackageConfigMap -> PackageArg -> [PackageConfig]
Edward Z. Yang's avatar
Edward Z. Yang committed
815 816 817
             -> UnusablePackages
             -> Either [(PackageConfig, UnusablePackageReason)]
                [PackageConfig]
818
findPackages prec_map pkg_db arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
819 820 821 822
  = let ps = mapMaybe (finder arg) pkgs
    in if null ps
        then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))
                            (Map.elems unusable))
823
        else Right (sortByPreference prec_map ps)
Edward Z. Yang's avatar
Edward Z. Yang committed
824 825 826 827 828 829
  where
    finder (PackageArg str) p
      = if str == sourcePackageIdString p || str == packageNameString p
          then Just p
          else Nothing
    finder (UnitIdArg uid) p
830
      = let (iuid, mb_indef) = splitUnitIdInsts uid
831
        in if iuid == installedPackageConfigId p
832
              then Just (case mb_indef of
Edward Z. Yang's avatar
Edward Z. Yang committed
833
                            Nothing    -> p
834
                            Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p)
Edward Z. Yang's avatar
Edward Z. Yang committed
835 836
              else Nothing

837
selectPackages :: PackagePrecedenceIndex -> PackageArg -> [PackageConfig]
838 839 840
               -> UnusablePackages
               -> Either [(PackageConfig, UnusablePackageReason)]
                  ([PackageConfig], [PackageConfig])
841
selectPackages prec_map arg pkgs unusable
Edward Z. Yang's avatar
Edward Z. Yang committed
842 843
  = let matches = matching arg
        (ps,rest) = partition matches pkgs
844 845
    in if null ps
        then Left (filter (matches.fst) (Map.elems unusable))
846
        else Right (sortByPreference prec_map ps, rest)
847

Edward Z. Yang's avatar
Edward Z. Yang committed
848 849 850 851 852
-- | Rename a 'PackageConfig' according to some module instantiation.
renamePackage :: PackageConfigMap -> [(ModuleName, Module)]
              -> PackageConfig -> PackageConfig
renamePackage pkg_map insts conf =
    let hsubst = listToUFM insts
853 854
        smod  = renameHoleModule' pkg_map hsubst
        new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf)
Edward Z. Yang's avatar
Edward Z. Yang committed
855
    in conf {
856
        instantiatedWith = new_insts,
Edward Z. Yang's avatar
Edward Z. Yang committed
857 858 859 860 861
        exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
                             (exposedModules conf)
    }


862 863
-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
864 865
matchingStr :: String -> PackageConfig -> Bool
matchingStr str p
866 867
        =  str == sourcePackageIdString p
        || str == packageNameString p
868

869 870
matchingId :: InstalledUnitId -> PackageConfig -> Bool
matchingId uid p = uid == installedPackageConfigId p
871

872 873
matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg str) = matchingStr str
874 875
matching (UnitIdArg (DefiniteUnitId (DefUnitId uid)))  = matchingId uid
matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case
876

877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908
-- | This sorts a list of packages, putting "preferred" packages first.
-- See 'compareByPreference' for the semantics of "preference".
sortByPreference :: PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig]
sortByPreference prec_map = sortBy (flip (compareByPreference prec_map))

-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking
-- which should be "active".  Here is the order of preference:
--
--      1. First, prefer the latest version
--      2. If the versions are the same, prefer the package that
--      came in the latest package database.
--
-- Pursuant to #12518, we could change this policy to, for example, remove
-- the version preference, meaning that we would always prefer the packages
-- in alter package database.
--
compareByPreference
    :: PackagePrecedenceIndex
    -> PackageConfig
    -> PackageConfig
    -> Ordering
compareByPreference prec_map pkg pkg' =
    case comparing packageVersion pkg pkg' of
        GT -> GT
        EQ | Just prec  <- Map.lookup (unitId pkg)  prec_map
           , Just prec' <- Map.lookup (unitId pkg') prec_map
           -- Prefer the package from the later DB flag (i.e., higher
           -- precedence)
           -> compare prec prec'
           | otherwise
           -> EQ
        LT -> LT
Ian Lynagh's avatar
Ian Lynagh committed
909 910

comparing :: Ord a => (t -> a) -> t -> t -> Ordering
911 912
comparing f a b = f a `compare` f b

Ian Lynagh's avatar
Ian Lynagh committed
913 914
packageFlagErr :: DynFlags
               -> PackageFlag
915 916
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
917 918 919

-- for missing DPH package we emit a more helpful error message, because
-- this may be the result of using -fdph-par or -fdph-seq.
920
packageFlagErr dflags (ExposePackage _ (PackageArg pkg) _) []
921
  | is_dph_package pkg
922
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
923 924 925
  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
926
packageFlagErr dflags flag reasons
927 928 929 930 931 932 933 934 935 936 937 938 939 940
  = 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
941
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
942
  where err = text "cannot satisfy " <> flag_doc <>