Packages.hs 76.8 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.Char ( toUpper )
87
import Data.List as List
88
import Data.Map (Map)
89
import Data.Set (Set)
Edward Z. Yang's avatar
Edward Z. Yang committed
90 91
import Data.Maybe (mapMaybe)
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 FiniteMap as Map
99
import qualified Data.Set as Set
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
Edward Z. Yang's avatar
Edward Z. Yang committed
473
  (pkg_state, preload)
474
        <- mkPackageState dflags pkg_db []
475
  return (dflags{ pkgDatabase = Just pkg_db,
Edward Z. Yang's avatar
Edward Z. Yang committed
476
                  pkgState = pkg_state },
477
          preload)
478 479

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

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

488 489 490

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

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

502
  return $ reverse (extraPkgConfs dflags base_conf_refs)
503 504 505 506 507 508
  -- 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)
509 510 511
-- 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.)
512
resolvePackageConfig dflags UserPkgConf = runMaybeT $ do
513
  dir <- versionedAppDir dflags
Edsko de Vries's avatar
Edsko de Vries committed
514
  let pkgconf = dir </> "package.conf.d"
515 516
  exist <- tryMaybeT $ doesDirectoryExist pkgconf
  if exist then return pkgconf else mzero
517
resolvePackageConfig _ (PkgConfFile name) = return $ Just name
518

519
readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig])
520
readPackageConfig dflags conf_file = do
521 522
  isdir <- doesDirectoryExist conf_file

523
  proto_pkg_configs <-
524
    if isdir
525
       then readDirStylePackageConfig conf_file
526
       else do
527
            isfile <- doesFileExist conf_file
528
            if isfile
529 530 531 532 533
               then do
                 mpkgs <- tryReadOldFileStylePackageConfig
                 case mpkgs of
                   Just pkgs -> return pkgs
                   Nothing   -> throwGhcExceptionIO $ InstallationError $
534 535 536 537
                      "ghc no longer supports single-file style package " ++
                      "databases (" ++ conf_file ++
                      ") use 'ghc-pkg init' to create the database with " ++
                      "the correct format."
538 539
               else throwGhcExceptionIO $ InstallationError $
                      "can't find a package database at " ++ conf_file
540

541 542
  let
      top_dir = topDir dflags
543
      pkgroot = takeDirectory conf_file
544 545
      pkg_configs1 = map (mungePackageConfig top_dir pkgroot)
                         proto_pkg_configs
546
      pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
547
  --
548
  return (conf_file, pkg_configs2)
549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573
  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
574

575
setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
576
setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
577
  where
578
    maybeDistrustAll pkgs'
ian@well-typed.com's avatar
ian@well-typed.com committed
579
      | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
580 581
      | otherwise                           = pkgs'

dterei's avatar
dterei committed
582
    distrust pkg = pkg{ trusted = False }
583

584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599
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

600
-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
601 602 603 604 605 606 607 608 609 610 611 612 613 614
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),
615
      libraryDynDirs = munge_paths (libraryDynDirs pkg),
616 617 618 619
      frameworkDirs = munge_paths (frameworkDirs pkg),
      haddockInterfaces = munge_paths (haddockInterfaces pkg),
      haddockHTMLs = munge_urls (haddockHTMLs pkg)
    }
620
  where
621 622 623 624
    munge_paths = map munge_path
    munge_urls  = map munge_url

    munge_path p
625 626 627
      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
      | otherwise                                = p
628 629

    munge_url p
630 631 632
      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
      | otherwise                                   = p
633 634 635

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
636 637 638 639 640 641 642 643 644 645 646 647 648
                 ++ 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
649

650

651
-- -----------------------------------------------------------------------------
652 653 654 655 656 657 658 659 660 661 662 663 664 665
-- 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 ->
Edward Z. Yang's avatar
Edward Z. Yang committed
666
       case selectPackages (PackageArg str) pkgs unusable of
667 668 669 670 671
         Left ps       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map trust ps ++ qs)
          where trust p = p {trusted=True}

    DistrustPackage str ->
Edward Z. Yang's avatar
Edward Z. Yang committed
672
       case selectPackages (PackageArg str) pkgs unusable of
673 674 675
         Left ps       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map distrust ps ++ qs)
          where distrust p = p {trusted=False}
676

Edward Z. Yang's avatar
Edward Z. Yang committed
677 678 679 680 681
-- | 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))

682
applyPackageFlag
Ian Lynagh's avatar
Ian Lynagh committed
683
   :: DynFlags
Edward Z. Yang's avatar
Edward Z. Yang committed
684
   -> PackageConfigMap
Ian Lynagh's avatar
Ian Lynagh committed
685
   -> UnusablePackages
686 687
   -> Bool -- if False, if you expose a package, it implicitly hides
           -- any previously exposed packages with the same name
688 689
   -> [PackageConfig]
   -> VisibilityMap           -- Initially exposed
690
   -> PackageFlag               -- flag to apply
691
   -> IO VisibilityMap        -- Now exposed
692

Edward Z. Yang's avatar
Edward Z. Yang committed
693
applyPackageFlag dflags pkg_db unusable no_hide_others pkgs vm flag =
694
  case flag of
695
    ExposePackage _ arg (ModRenaming b rns) ->
Edward Z. Yang's avatar
Edward Z. Yang committed
696
       case findPackages pkg_db arg pkgs unusable of
697
         Left ps         -> packageFlagErr dflags flag ps
Edward Z. Yang's avatar
Edward Z. Yang committed
698
         Right (p:_) -> return vm'
699 700
          where
           n = fsPackageName p
Edward Z. Yang's avatar
Edward Z. Yang committed
701 702 703 704 705 706 707 708 709 710

           -- 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
711 712
                (_, Just indef) ->
                  let local = [ Map.singleton
Edward Z. Yang's avatar
Edward Z. Yang committed
713
                                  (moduleName mod)
714 715
                                  (Set.singleton $ IndefModule indef mod_name)
                              | (mod_name, mod) <- indefUnitIdInsts indef
Edward Z. Yang's avatar
Edward Z. Yang committed
716 717
                              , isHoleModule mod ]
                      recurse = [ collectHoles (moduleUnitId mod)
718
                                | (_, mod) <- indefUnitIdInsts indef ]
Edward Z. Yang's avatar
Edward Z. Yang committed
719 720 721 722 723 724 725 726 727 728 729 730 731
                  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
732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752
           -- 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
753 754 755 756 757
                      -- NB: renamings never clear
                      | (_:_) <- rns = vm
                      | otherwise = Map.filterWithKey
                            (\k uv -> k == packageConfigId p
                                   || First (Just n) /= uv_package_name uv) vm
758 759
         _ -> panic "applyPackageFlag"

760
    HidePackage str ->
Edward Z. Yang's avatar
Edward Z. Yang committed
761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784
       case findPackages pkg_db (PackageArg str) pkgs unusable of
         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.
findPackages :: PackageConfigMap -> PackageArg -> [PackageConfig]
             -> UnusablePackages
             -> Either [(PackageConfig, UnusablePackageReason)]
                [PackageConfig]
findPackages pkg_db arg pkgs unusable
  = 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))
        else Right (sortByVersion (reverse ps))
  where
    finder (PackageArg str) p
      = if str == sourcePackageIdString p || str == packageNameString p
          then Just p
          else Nothing
    finder (UnitIdArg uid) p
785
      = let (iuid, mb_indef) = splitUnitIdInsts uid
786
        in if iuid == installedPackageConfigId p
787
              then Just (case mb_indef of
Edward Z. Yang's avatar
Edward Z. Yang committed
788
                            Nothing    -> p
789
                            Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p)
Edward Z. Yang's avatar
Edward Z. Yang committed
790 791 792
              else Nothing

selectPackages :: PackageArg -> [PackageConfig]
793 794 795
               -> UnusablePackages
               -> Either [(PackageConfig, UnusablePackageReason)]
                  ([PackageConfig], [PackageConfig])
Edward Z. Yang's avatar
Edward Z. Yang committed
796 797 798
selectPackages arg pkgs unusable
  = let matches = matching arg
        (ps,rest) = partition matches pkgs
799 800
    in if null ps
        then Left (filter (matches.fst) (Map.elems unusable))
801 802 803
        -- NB: packages from later package databases are LATER
        -- in the list.  We want to prefer the latest package.
        else Right (sortByVersion (reverse ps), rest)
804

Edward Z. Yang's avatar
Edward Z. Yang committed
805 806 807 808 809
-- | Rename a 'PackageConfig' according to some module instantiation.
renamePackage :: PackageConfigMap -> [(ModuleName, Module)]
              -> PackageConfig -> PackageConfig
renamePackage pkg_map insts conf =
    let hsubst = listToUFM insts
810 811
        smod  = renameHoleModule' pkg_map hsubst
        new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf)
Edward Z. Yang's avatar
Edward Z. Yang committed
812
    in conf {
813
        instantiatedWith = new_insts,
Edward Z. Yang's avatar
Edward Z. Yang committed
814 815 816 817 818
        exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
                             (exposedModules conf)
    }


819 820
-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
821 822
matchingStr :: String -> PackageConfig -> Bool
matchingStr str p
823 824
        =  str == sourcePackageIdString p
        || str == packageNameString p
825

826 827
matchingId :: InstalledUnitId -> PackageConfig -> Bool
matchingId uid p = uid == installedPackageConfigId p
828

829 830
matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg str) = matchingStr str
831 832
matching (UnitIdArg (DefiniteUnitId (DefUnitId uid)))  = matchingId uid
matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case
833

834 835
sortByVersion :: [PackageConfig] -> [PackageConfig]
sortByVersion = sortBy (flip (comparing packageVersion))
Ian Lynagh's avatar
Ian Lynagh committed
836 837

comparing :: Ord a => (t -> a) -> t -> t -> Ordering
838 839
comparing f a b = f a `compare` f b

Ian Lynagh's avatar
Ian Lynagh committed
840 841
packageFlagErr :: DynFlags
               -> PackageFlag
842 843
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
844 845 846

-- for missing DPH package we emit a more helpful error message, because
-- this may be the result of using -fdph-par or -fdph-seq.
847
packageFlagErr dflags (ExposePackage _ (PackageArg pkg) _) []
848
  | is_dph_package pkg
849
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
850 851 852
  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
853
packageFlagErr dflags flag reasons
854 855 856 857 858 859 860 861 862 863 864 865 866 867
  = 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
868
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
869
  where err = text "cannot satisfy " <> flag_doc <>
870
                (if null reasons then Outputable.empty else text ": ") $$
871 872 873
              nest 4 (ppr_reasons $$
                      text "(use -v for more information)")
        ppr_reasons = vcat (map ppr_reason reasons)
874
        ppr_reason (p, reason) =
875
            pprReason (ppr (unitId p) <+> text "is") reason
876

877 878 879
pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
    HidePackage p   -> text "-hide-package " <> text p
880
    ExposePackage doc _ _ -> text doc
881

882 883 884 885 886
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag flag = case flag of
    TrustPackage p    -> text "-trust " <> text p
    DistrustPackage p -> text "-distrust " <> text p

887 888 889
-- -----------------------------------------------------------------------------
-- Wired-in packages

890
wired_in_pkgids :: [String]
891
wired_in_pkgids = map unitIdString wiredInUnitIds
892

893
type WiredPackagesMap = Map WiredUnitId WiredUnitId
894

895 896 897
findWiredInPackages
   :: DynFlags
   -> [PackageConfig]           -- database
898
   -> VisibilityMap             -- info on what packages are visible
899 900 901
                                -- for wired in selection
   -> IO ([PackageConfig],  -- package database updated for wired in
          WiredPackagesMap) -- map from unit id to wired identity
902

903
findWiredInPackages dflags pkgs vis_map = do
Simon Marlow's avatar
Simon Marlow committed
904 905 906 907 908
  --
  -- Now we must find our wired-in packages, and rename them to
  -- their canonical names (eg. base-1.0 ==> base).
  --
  let
909
        matches :: PackageConfig -> String -> Bool
910
        pc `matches` pid = packageNameString pc == pid
Simon Marlow's avatar
Simon Marlow committed
911

912 913 914 915
        -- 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.
916 917
        --
        -- When choosing which package to map to a wired-in package
918 919 920 921 922 923 924 925 926 927
        -- 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.
928
        --
929
        findWiredInPackage :: [PackageConfig] -> String
930
                           -> IO (Maybe PackageConfig)
931
        findWiredInPackage pkgs wired_pkg =
932 933 934
           let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
               all_exposed_ps =
                    [ p | p <- all_ps
Edward Z. Yang's avatar
Edward Z. Yang committed
935
                        , Map.member (packageConfigId p) vis_map ] in
936 937 938 939 940
           case all_exposed_ps of
            [] -> case all_ps of
                       []   -> notfound
                       many -> pick (head (sortByVersion many))
            many -> pick (head (sortByVersion many))
941 942
          where
                notfound = do
943
                          debugTraceMsg dflags 2 $
944
                            text "wired-in package "
945
                                 <> text wired_pkg
946
                                 <> text " not found."
947
                          return Nothing
948
                pick :: PackageConfig
949
                     -> IO (Maybe PackageConfig)
950 951
                pick pkg = do
                        debugTraceMsg dflags 2 $
952
                            text "wired-in package "
953
                                 <> text wired_pkg
954
                                 <> text " mapped to "
955
                                 <> ppr (unitId pkg)
956
                        return (Just pkg)
957

Simon Marlow's avatar
Simon Marlow committed
958

959
  mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
960
  let