1-- (c) The University of Glasgow, 2006 2 3{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} 4 5-- | Package manipulation 6module Packages ( 7 module PackageConfig, 8 9 -- * Reading the package config, and processing cmdline args 10 PackageState(preloadPackages, explicitPackages, moduleToPkgConfAll, requirementContext), 11 PackageConfigMap, 12 emptyPackageState, 13 initPackages, 14 readPackageConfigs, 15 getPackageConfRefs, 16 resolvePackageConfig, 17 readPackageConfig, 18 listPackageConfigMap, 19 20 -- * Querying the package config 21 lookupPackage, 22 lookupPackage', 23 lookupInstalledPackage, 24 lookupPackageName, 25 improveUnitId, 26 searchPackageId, 27 getPackageDetails, 28 getInstalledPackageDetails, 29 componentIdString, 30 displayInstalledUnitId, 31 listVisibleModuleNames, 32 lookupModuleInAllPackages, 33 lookupModuleWithSuggestions, 34 lookupPluginModuleWithSuggestions, 35 LookupResult(..), 36 ModuleSuggestion(..), 37 ModuleOrigin(..), 38 UnusablePackageReason(..), 39 pprReason, 40 41 -- * Inspecting the set of packages in scope 42 getPackageIncludePath, 43 getPackageLibraryPath, 44 getPackageLinkOpts, 45 getPackageExtraCcOpts, 46 getPackageFrameworkPath, 47 getPackageFrameworks, 48 getPackageConfigMap, 49 getPreloadPackagesAnd, 50 51 collectArchives, 52 collectIncludeDirs, collectLibraryPaths, collectLinkOpts, 53 packageHsLibs, getLibs, 54 55 -- * Utils 56 unwireUnitId, 57 pprFlag, 58 pprPackages, 59 pprPackagesSimple, 60 pprModuleMap, 61 isIndefinite, 62 isDllName 63 ) 64where 65 66#include "GhclibHsVersions.h" 67 68import GhcPrelude 69 70import GHC.PackageDb 71import PackageConfig 72import DynFlags 73import Name ( Name, nameModule_maybe ) 74import UniqFM 75import UniqDFM 76import UniqSet 77import Module 78import Util 79import Panic 80import GHC.Platform 81import Outputable 82import Maybes 83import CmdLineParser 84 85import System.Environment ( getEnv ) 86import FastString 87import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, compilationProgressMsg, 88 withTiming ) 89import Exception 90 91import System.Directory 92import System.FilePath as FilePath 93import qualified System.FilePath.Posix as FilePath.Posix 94import System.IO.Error ( isDoesNotExistError ) 95import Control.Monad 96import Data.Graph (stronglyConnComp, SCC(..)) 97import Data.Char ( toUpper ) 98import Data.List as List 99import Data.Map (Map) 100import Data.Set (Set) 101import Data.Monoid (First(..)) 102import qualified Data.Semigroup as Semigroup 103import qualified Data.Map as Map 104import qualified Data.Map.Strict as MapStrict 105import qualified Data.Set as Set 106import Data.Version 107 108-- --------------------------------------------------------------------------- 109-- The Package state 110 111-- | Package state is all stored in 'DynFlags', including the details of 112-- all packages, which packages are exposed, and which modules they 113-- provide. 114-- 115-- The package state is computed by 'initPackages', and kept in DynFlags. 116-- It is influenced by various package flags: 117-- 118-- * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed. 119-- If @-hide-all-packages@ was not specified, these commands also cause 120-- all other packages with the same name to become hidden. 121-- 122-- * @-hide-package <pkg>@ causes @<pkg>@ to become hidden. 123-- 124-- * (there are a few more flags, check below for their semantics) 125-- 126-- The package state has the following properties. 127-- 128-- * Let @exposedPackages@ be the set of packages thus exposed. 129-- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of 130-- their dependencies. 131-- 132-- * When searching for a module from a preload import declaration, 133-- only the exposed modules in @exposedPackages@ are valid. 134-- 135-- * When searching for a module from an implicit import, all modules 136-- from @depExposedPackages@ are valid. 137-- 138-- * When linking in a compilation manager mode, we link in packages the 139-- program depends on (the compiler knows this list by the 140-- time it gets to the link step). Also, we link in all packages 141-- which were mentioned with preload @-package@ flags on the command-line, 142-- or are a transitive dependency of same, or are \"base\"\/\"rts\". 143-- The reason for this is that we might need packages which don't 144-- contain any Haskell modules, and therefore won't be discovered 145-- by the normal mechanism of dependency tracking. 146 147-- Notes on DLLs 148-- ~~~~~~~~~~~~~ 149-- When compiling module A, which imports module B, we need to 150-- know whether B will be in the same DLL as A. 151-- If it's in the same DLL, we refer to B_f_closure 152-- If it isn't, we refer to _imp__B_f_closure 153-- When compiling A, we record in B's Module value whether it's 154-- in a different DLL, by setting the DLL flag. 155 156-- | Given a module name, there may be multiple ways it came into scope, 157-- possibly simultaneously. This data type tracks all the possible ways 158-- it could have come into scope. Warning: don't use the record functions, 159-- they're partial! 160data ModuleOrigin = 161 -- | Module is hidden, and thus never will be available for import. 162 -- (But maybe the user didn't realize), so we'll still keep track 163 -- of these modules.) 164 ModHidden 165 -- | Module is unavailable because the package is unusable. 166 | ModUnusable UnusablePackageReason 167 -- | Module is public, and could have come from some places. 168 | ModOrigin { 169 -- | @Just False@ means that this module is in 170 -- someone's @exported-modules@ list, but that package is hidden; 171 -- @Just True@ means that it is available; @Nothing@ means neither 172 -- applies. 173 fromOrigPackage :: Maybe Bool 174 -- | Is the module available from a reexport of an exposed package? 175 -- There could be multiple. 176 , fromExposedReexport :: [PackageConfig] 177 -- | Is the module available from a reexport of a hidden package? 178 , fromHiddenReexport :: [PackageConfig] 179 -- | Did the module export come from a package flag? (ToDo: track 180 -- more information. 181 , fromPackageFlag :: Bool 182 } 183 184instance Outputable ModuleOrigin where 185 ppr ModHidden = text "hidden module" 186 ppr (ModUnusable _) = text "unusable module" 187 ppr (ModOrigin e res rhs f) = sep (punctuate comma ( 188 (case e of 189 Nothing -> [] 190 Just False -> [text "hidden package"] 191 Just True -> [text "exposed package"]) ++ 192 (if null res 193 then [] 194 else [text "reexport by" <+> 195 sep (map (ppr . packageConfigId) res)]) ++ 196 (if null rhs 197 then [] 198 else [text "hidden reexport by" <+> 199 sep (map (ppr . packageConfigId) res)]) ++ 200 (if f then [text "package flag"] else []) 201 )) 202 203-- | Smart constructor for a module which is in @exposed-modules@. Takes 204-- as an argument whether or not the defining package is exposed. 205fromExposedModules :: Bool -> ModuleOrigin 206fromExposedModules e = ModOrigin (Just e) [] [] False 207 208-- | Smart constructor for a module which is in @reexported-modules@. Takes 209-- as an argument whether or not the reexporting package is expsed, and 210-- also its 'PackageConfig'. 211fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin 212fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False 213fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False 214 215-- | Smart constructor for a module which was bound by a package flag. 216fromFlag :: ModuleOrigin 217fromFlag = ModOrigin Nothing [] [] True 218 219instance Semigroup ModuleOrigin where 220 ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' = 221 ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') 222 where g (Just b) (Just b') 223 | b == b' = Just b 224 | otherwise = panic "ModOrigin: package both exposed/hidden" 225 g Nothing x = x 226 g x Nothing = x 227 _x <> _y = panic "ModOrigin: hidden module redefined" 228 229instance Monoid ModuleOrigin where 230 mempty = ModOrigin Nothing [] [] False 231 mappend = (Semigroup.<>) 232 233-- | Is the name from the import actually visible? (i.e. does it cause 234-- ambiguity, or is it only relevant when we're making suggestions?) 235originVisible :: ModuleOrigin -> Bool 236originVisible ModHidden = False 237originVisible (ModUnusable _) = False 238originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f 239 240-- | Are there actually no providers for this module? This will never occur 241-- except when we're filtering based on package imports. 242originEmpty :: ModuleOrigin -> Bool 243originEmpty (ModOrigin Nothing [] [] False) = True 244originEmpty _ = False 245 246-- | 'UniqFM' map from 'InstalledUnitId' 247type InstalledUnitIdMap = UniqDFM 248 249-- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus 250-- the transitive closure of preload packages. 251data PackageConfigMap = PackageConfigMap { 252 unPackageConfigMap :: InstalledUnitIdMap PackageConfig, 253 -- | The set of transitively reachable packages according 254 -- to the explicitly provided command line arguments. 255 -- See Note [UnitId to InstalledUnitId improvement] 256 preloadClosure :: UniqSet InstalledUnitId 257 } 258 259-- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'. 260type VisibilityMap = Map UnitId UnitVisibility 261 262-- | 'UnitVisibility' records the various aspects of visibility of a particular 263-- 'UnitId'. 264data UnitVisibility = UnitVisibility 265 { uv_expose_all :: Bool 266 -- ^ Should all modules in exposed-modules should be dumped into scope? 267 , uv_renamings :: [(ModuleName, ModuleName)] 268 -- ^ Any custom renamings that should bring extra 'ModuleName's into 269 -- scope. 270 , uv_package_name :: First FastString 271 -- ^ The package name is associated with the 'UnitId'. This is used 272 -- to implement legacy behavior where @-package foo-0.1@ implicitly 273 -- hides any packages named @foo@ 274 , uv_requirements :: Map ModuleName (Set IndefModule) 275 -- ^ The signatures which are contributed to the requirements context 276 -- from this unit ID. 277 , uv_explicit :: Bool 278 -- ^ Whether or not this unit was explicitly brought into scope, 279 -- as opposed to implicitly via the 'exposed' fields in the 280 -- package database (when @-hide-all-packages@ is not passed.) 281 } 282 283instance Outputable UnitVisibility where 284 ppr (UnitVisibility { 285 uv_expose_all = b, 286 uv_renamings = rns, 287 uv_package_name = First mb_pn, 288 uv_requirements = reqs, 289 uv_explicit = explicit 290 }) = ppr (b, rns, mb_pn, reqs, explicit) 291 292instance Semigroup UnitVisibility where 293 uv1 <> uv2 294 = UnitVisibility 295 { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 296 , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 297 , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) 298 , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2) 299 , uv_explicit = uv_explicit uv1 || uv_explicit uv2 300 } 301 302instance Monoid UnitVisibility where 303 mempty = UnitVisibility 304 { uv_expose_all = False 305 , uv_renamings = [] 306 , uv_package_name = First Nothing 307 , uv_requirements = Map.empty 308 , uv_explicit = False 309 } 310 mappend = (Semigroup.<>) 311 312type WiredUnitId = DefUnitId 313type PreloadUnitId = InstalledUnitId 314 315-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings 316-- in scope. The 'PackageConf' is not cached, mostly for convenience reasons 317-- (since this is the slow path, we'll just look it up again). 318type ModuleToPkgConfAll = 319 Map ModuleName (Map Module ModuleOrigin) 320 321data PackageState = PackageState { 322 -- | A mapping of 'UnitId' to 'PackageConfig'. This list is adjusted 323 -- so that only valid packages are here. 'PackageConfig' reflects 324 -- what was stored *on disk*, except for the 'trusted' flag, which 325 -- is adjusted at runtime. (In particular, some packages in this map 326 -- may have the 'exposed' flag be 'False'.) 327 pkgIdMap :: PackageConfigMap, 328 329 -- | A mapping of 'PackageName' to 'ComponentId'. This is used when 330 -- users refer to packages in Backpack includes. 331 packageNameMap :: Map PackageName ComponentId, 332 333 -- | A mapping from wired in names to the original names from the 334 -- package database. 335 unwireMap :: Map WiredUnitId WiredUnitId, 336 337 -- | The packages we're going to link in eagerly. This list 338 -- should be in reverse dependency order; that is, a package 339 -- is always mentioned before the packages it depends on. 340 preloadPackages :: [PreloadUnitId], 341 342 -- | Packages which we explicitly depend on (from a command line flag). 343 -- We'll use this to generate version macros. 344 explicitPackages :: [UnitId], 345 346 -- | This is a full map from 'ModuleName' to all modules which may possibly 347 -- be providing it. These providers may be hidden (but we'll still want 348 -- to report them in error messages), or it may be an ambiguous import. 349 moduleToPkgConfAll :: !ModuleToPkgConfAll, 350 351 -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility. 352 pluginModuleToPkgConfAll :: !ModuleToPkgConfAll, 353 354 -- | A map saying, for each requirement, what interfaces must be merged 355 -- together when we use them. For example, if our dependencies 356 -- are @p[A=<A>]@ and @q[A=<A>,B=r[C=<A>]:B]@, then the interfaces 357 -- to merge for A are @p[A=<A>]:A@, @q[A=<A>,B=r[C=<A>]:B]:A@ 358 -- and @r[C=<A>]:C@. 359 -- 360 -- There's an entry in this map for each hole in our home library. 361 requirementContext :: Map ModuleName [IndefModule] 362 } 363 364emptyPackageState :: PackageState 365emptyPackageState = PackageState { 366 pkgIdMap = emptyPackageConfigMap, 367 packageNameMap = Map.empty, 368 unwireMap = Map.empty, 369 preloadPackages = [], 370 explicitPackages = [], 371 moduleToPkgConfAll = Map.empty, 372 pluginModuleToPkgConfAll = Map.empty, 373 requirementContext = Map.empty 374 } 375 376type InstalledPackageIndex = Map InstalledUnitId PackageConfig 377 378-- | Empty package configuration map 379emptyPackageConfigMap :: PackageConfigMap 380emptyPackageConfigMap = PackageConfigMap emptyUDFM emptyUniqSet 381 382-- | Find the package we know about with the given unit id, if any 383lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig 384lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags)) 385 386-- | A more specialized interface, which takes a boolean specifying 387-- whether or not to look for on-the-fly renamed interfaces, and 388-- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can 389-- be used while we're initializing 'DynFlags' 390lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig 391lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid 392lookupPackage' True m@(PackageConfigMap pkg_map _) uid = 393 case splitUnitIdInsts uid of 394 (iuid, Just indef) -> 395 fmap (renamePackage m (indefUnitIdInsts indef)) 396 (lookupUDFM pkg_map iuid) 397 (_, Nothing) -> lookupUDFM pkg_map uid 398 399{- 400-- | Find the indefinite package for a given 'ComponentId'. 401-- The way this works is just by fiat'ing that every indefinite package's 402-- unit key is precisely its component ID; and that they share uniques. 403lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig 404lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs 405 where 406 PackageConfigMap pkg_map = pkgIdMap (pkgState dflags) 407-} 408 409-- | Find the package we know about with the given package name (e.g. @foo@), if any 410-- (NB: there might be a locally defined unit name which overrides this) 411lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId 412lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags)) 413 414-- | Search for packages with a given package ID (e.g. \"foo-0.1\") 415searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig] 416searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) 417 (listPackageConfigMap dflags) 418 419-- | Extends the package configuration map with a list of package configs. 420extendPackageConfigMap 421 :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap 422extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs 423 = PackageConfigMap (foldl' add pkg_map new_pkgs) closure 424 -- We also add the expanded version of the packageConfigId, so that 425 -- 'improveUnitId' can find it. 426 where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p) 427 (installedPackageConfigId p) p 428 429-- | Looks up the package with the given id in the package state, panicing if it is 430-- not found 431getPackageDetails :: DynFlags -> UnitId -> PackageConfig 432getPackageDetails dflags pid = case lookupPackage dflags pid of 433 Just c -> c 434 Nothing -> pprPanic "getPackageDetails: couldn't find package" (ppr pid) 435 436lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig 437lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid 438 439lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig 440lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid 441 442getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig 443getInstalledPackageDetails dflags uid = case lookupInstalledPackage dflags uid of 444 Just c -> c 445 Nothing -> pprPanic "getInstalledPackageDetails: couldn't find package" (ppr uid) 446 447-- | Get a list of entries from the package database. NB: be careful with 448-- this function, although all packages in this map are "visible", this 449-- does not imply that the exposed-modules of the package are available 450-- (they may have been thinned or renamed). 451listPackageConfigMap :: DynFlags -> [PackageConfig] 452listPackageConfigMap dflags = eltsUDFM pkg_map 453 where 454 PackageConfigMap pkg_map _ = pkgIdMap (pkgState dflags) 455 456-- ---------------------------------------------------------------------------- 457-- Loading the package db files and building up the package state 458 459-- | Call this after 'DynFlags.parseDynFlags'. It reads the package 460-- database files, and sets up various internal tables of package 461-- information, according to the package-related flags on the 462-- command-line (@-package@, @-hide-package@ etc.) 463-- 464-- Returns a list of packages to link in if we're doing dynamic linking. 465-- This list contains the packages that the user explicitly mentioned with 466-- @-package@ flags. 467-- 468-- 'initPackages' can be called again subsequently after updating the 469-- 'packageFlags' field of the 'DynFlags', and it will update the 470-- 'pkgState' in 'DynFlags' and return a list of packages to 471-- link in. 472initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId]) 473initPackages dflags0 = withTiming dflags0 474 (text "initializing package database") 475 forcePkgDb $ do 476 dflags <- interpretPackageEnv dflags0 477 pkg_db <- 478 case pkgDatabase dflags of 479 Nothing -> readPackageConfigs dflags 480 Just db -> return $ map (\(p, pkgs) 481 -> (p, setBatchPackageFlags dflags pkgs)) db 482 (pkg_state, preload, insts) 483 <- mkPackageState dflags pkg_db [] 484 return (dflags{ pkgDatabase = Just pkg_db, 485 pkgState = pkg_state, 486 thisUnitIdInsts_ = insts }, 487 preload) 488 where 489 forcePkgDb (dflags, _) = pkgIdMap (pkgState dflags) `seq` () 490 491-- ----------------------------------------------------------------------------- 492-- Reading the package database(s) 493 494readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])] 495readPackageConfigs dflags = do 496 conf_refs <- getPackageConfRefs dflags 497 confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs 498 mapM (readPackageConfig dflags) confs 499 500 501getPackageConfRefs :: DynFlags -> IO [PkgConfRef] 502getPackageConfRefs dflags = do 503 let system_conf_refs = [UserPkgConf, GlobalPkgConf] 504 505 e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH") 506 let base_conf_refs = case e_pkg_path of 507 Left _ -> system_conf_refs 508 Right path 509 | not (null path) && isSearchPathSeparator (last path) 510 -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs 511 | otherwise 512 -> map PkgConfFile (splitSearchPath path) 513 514 -- Apply the package DB-related flags from the command line to get the 515 -- final list of package DBs. 516 -- 517 -- Notes on ordering: 518 -- * The list of flags is reversed (later ones first) 519 -- * We work with the package DB list in "left shadows right" order 520 -- * and finally reverse it at the end, to get "right shadows left" 521 -- 522 return $ reverse (foldr doFlag base_conf_refs (packageDBFlags dflags)) 523 where 524 doFlag (PackageDB p) dbs = p : dbs 525 doFlag NoUserPackageDB dbs = filter isNotUser dbs 526 doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs 527 doFlag ClearPackageDBs _ = [] 528 529 isNotUser UserPkgConf = False 530 isNotUser _ = True 531 532 isNotGlobal GlobalPkgConf = False 533 isNotGlobal _ = True 534 535resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath) 536resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags) 537-- NB: This logic is reimplemented in Cabal, so if you change it, 538-- make sure you update Cabal. (Or, better yet, dump it in the 539-- compiler info so Cabal can use the info.) 540resolvePackageConfig dflags UserPkgConf = runMaybeT $ do 541 dir <- versionedAppDir dflags 542 let pkgconf = dir </> "package.conf.d" 543 exist <- tryMaybeT $ doesDirectoryExist pkgconf 544 if exist then return pkgconf else mzero 545resolvePackageConfig _ (PkgConfFile name) = return $ Just name 546 547readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig]) 548readPackageConfig dflags conf_file = do 549 isdir <- doesDirectoryExist conf_file 550 551 proto_pkg_configs <- 552 if isdir 553 then readDirStylePackageConfig conf_file 554 else do 555 isfile <- doesFileExist conf_file 556 if isfile 557 then do 558 mpkgs <- tryReadOldFileStylePackageConfig 559 case mpkgs of 560 Just pkgs -> return pkgs 561 Nothing -> throwGhcExceptionIO $ InstallationError $ 562 "ghc no longer supports single-file style package " ++ 563 "databases (" ++ conf_file ++ 564 ") use 'ghc-pkg init' to create the database with " ++ 565 "the correct format." 566 else throwGhcExceptionIO $ InstallationError $ 567 "can't find a package database at " ++ conf_file 568 569 let 570 -- Fix #16360: remove trailing slash from conf_file before calculting pkgroot 571 conf_file' = dropTrailingPathSeparator conf_file 572 top_dir = topDir dflags 573 pkgroot = takeDirectory conf_file' 574 pkg_configs1 = map (mungePackageConfig top_dir pkgroot) 575 proto_pkg_configs 576 pkg_configs2 = setBatchPackageFlags dflags pkg_configs1 577 -- 578 return (conf_file', pkg_configs2) 579 where 580 readDirStylePackageConfig conf_dir = do 581 let filename = conf_dir </> "package.cache" 582 cache_exists <- doesFileExist filename 583 if cache_exists 584 then do 585 debugTraceMsg dflags 2 $ text "Using binary package database:" 586 <+> text filename 587 readPackageDbForGhc filename 588 else do 589 -- If there is no package.cache file, we check if the database is not 590 -- empty by inspecting if the directory contains any .conf file. If it 591 -- does, something is wrong and we fail. Otherwise we assume that the 592 -- database is empty. 593 debugTraceMsg dflags 2 $ text "There is no package.cache in" 594 <+> text conf_dir 595 <> text ", checking if the database is empty" 596 db_empty <- all (not . isSuffixOf ".conf") 597 <$> getDirectoryContents conf_dir 598 if db_empty 599 then do 600 debugTraceMsg dflags 3 $ text "There are no .conf files in" 601 <+> text conf_dir <> text ", treating" 602 <+> text "package database as empty" 603 return [] 604 else do 605 throwGhcExceptionIO $ InstallationError $ 606 "there is no package.cache in " ++ conf_dir ++ 607 " even though package database is not empty" 608 609 610 -- Single-file style package dbs have been deprecated for some time, but 611 -- it turns out that Cabal was using them in one place. So this is a 612 -- workaround to allow older Cabal versions to use this newer ghc. 613 -- We check if the file db contains just "[]" and if so, we look for a new 614 -- dir-style db in conf_file.d/, ie in a dir next to the given file. 615 -- We cannot just replace the file with a new dir style since Cabal still 616 -- assumes it's a file and tries to overwrite with 'writeFile'. 617 -- ghc-pkg also cooperates with this workaround. 618 tryReadOldFileStylePackageConfig = do 619 content <- readFile conf_file `catchIO` \_ -> return "" 620 if take 2 content == "[]" 621 then do 622 let conf_dir = conf_file <.> "d" 623 direxists <- doesDirectoryExist conf_dir 624 if direxists 625 then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) 626 liftM Just (readDirStylePackageConfig conf_dir) 627 else return (Just []) -- ghc-pkg will create it when it's updated 628 else return Nothing 629 630setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] 631setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs 632 where 633 maybeDistrustAll pkgs' 634 | gopt Opt_DistrustAllPackages dflags = map distrust pkgs' 635 | otherwise = pkgs' 636 637 distrust pkg = pkg{ trusted = False } 638 639mungePackageConfig :: FilePath -> FilePath 640 -> PackageConfig -> PackageConfig 641mungePackageConfig top_dir pkgroot = 642 mungeDynLibFields 643 . mungePackagePaths top_dir pkgroot 644 645mungeDynLibFields :: PackageConfig -> PackageConfig 646mungeDynLibFields pkg = 647 pkg { 648 libraryDynDirs = libraryDynDirs pkg 649 `orIfNull` libraryDirs pkg 650 } 651 where 652 orIfNull [] flags = flags 653 orIfNull flags _ = flags 654 655-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs 656mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig 657-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec 658-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) 659-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. 660-- The "pkgroot" is the directory containing the package database. 661-- 662-- Also perform a similar substitution for the older GHC-specific 663-- "$topdir" variable. The "topdir" is the location of the ghc 664-- installation (obtained from the -B option). 665mungePackagePaths top_dir pkgroot pkg = 666 pkg { 667 importDirs = munge_paths (importDirs pkg), 668 includeDirs = munge_paths (includeDirs pkg), 669 libraryDirs = munge_paths (libraryDirs pkg), 670 libraryDynDirs = munge_paths (libraryDynDirs pkg), 671 frameworkDirs = munge_paths (frameworkDirs pkg), 672 haddockInterfaces = munge_paths (haddockInterfaces pkg), 673 haddockHTMLs = munge_urls (haddockHTMLs pkg) 674 } 675 where 676 munge_paths = map munge_path 677 munge_urls = map munge_url 678 679 munge_path p 680 | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' 681 | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' 682 | otherwise = p 683 684 munge_url p 685 | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' 686 | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' 687 | otherwise = p 688 689 toUrlPath r p = "file:///" 690 -- URLs always use posix style '/' separators: 691 ++ FilePath.Posix.joinPath 692 (r : -- We need to drop a leading "/" or "\\" 693 -- if there is one: 694 dropWhile (all isPathSeparator) 695 (FilePath.splitDirectories p)) 696 697 -- We could drop the separator here, and then use </> above. However, 698 -- by leaving it in and using ++ we keep the same path separator 699 -- rather than letting FilePath change it to use \ as the separator 700 stripVarPrefix var path = case stripPrefix var path of 701 Just [] -> Just [] 702 Just cs@(c : _) | isPathSeparator c -> Just cs 703 _ -> Nothing 704 705 706-- ----------------------------------------------------------------------------- 707-- Modify our copy of the package database based on trust flags, 708-- -trust and -distrust. 709 710applyTrustFlag 711 :: DynFlags 712 -> PackagePrecedenceIndex 713 -> UnusablePackages 714 -> [PackageConfig] 715 -> TrustFlag 716 -> IO [PackageConfig] 717applyTrustFlag dflags prec_map unusable pkgs flag = 718 case flag of 719 -- we trust all matching packages. Maybe should only trust first one? 720 -- and leave others the same or set them untrusted 721 TrustPackage str -> 722 case selectPackages prec_map (PackageArg str) pkgs unusable of 723 Left ps -> trustFlagErr dflags flag ps 724 Right (ps,qs) -> return (map trust ps ++ qs) 725 where trust p = p {trusted=True} 726 727 DistrustPackage str -> 728 case selectPackages prec_map (PackageArg str) pkgs unusable of 729 Left ps -> trustFlagErr dflags flag ps 730 Right (ps,qs) -> return (map distrust ps ++ qs) 731 where distrust p = p {trusted=False} 732 733-- | A little utility to tell if the 'thisPackage' is indefinite 734-- (if it is not, we should never use on-the-fly renaming.) 735isIndefinite :: DynFlags -> Bool 736isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags)) 737 738applyPackageFlag 739 :: DynFlags 740 -> PackagePrecedenceIndex 741 -> PackageConfigMap 742 -> UnusablePackages 743 -> Bool -- if False, if you expose a package, it implicitly hides 744 -- any previously exposed packages with the same name 745 -> [PackageConfig] 746 -> VisibilityMap -- Initially exposed 747 -> PackageFlag -- flag to apply 748 -> IO VisibilityMap -- Now exposed 749 750applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag = 751 case flag of 752 ExposePackage _ arg (ModRenaming b rns) -> 753 case findPackages prec_map pkg_db arg pkgs unusable of 754 Left ps -> packageFlagErr dflags flag ps 755 Right (p:_) -> return vm' 756 where 757 n = fsPackageName p 758 759 -- If a user says @-unit-id p[A=<A>]@, this imposes 760 -- a requirement on us: whatever our signature A is, 761 -- it must fulfill all of p[A=<A>]:A's requirements. 762 -- This method is responsible for computing what our 763 -- inherited requirements are. 764 reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid 765 | otherwise = Map.empty 766 767 collectHoles uid = case splitUnitIdInsts uid of 768 (_, Just indef) -> 769 let local = [ Map.singleton 770 (moduleName mod) 771 (Set.singleton $ IndefModule indef mod_name) 772 | (mod_name, mod) <- indefUnitIdInsts indef 773 , isHoleModule mod ] 774 recurse = [ collectHoles (moduleUnitId mod) 775 | (_, mod) <- indefUnitIdInsts indef ] 776 in Map.unionsWith Set.union $ local ++ recurse 777 -- Other types of unit identities don't have holes 778 (_, Nothing) -> Map.empty 779 780 781 uv = UnitVisibility 782 { uv_expose_all = b 783 , uv_renamings = rns 784 , uv_package_name = First (Just n) 785 , uv_requirements = reqs 786 , uv_explicit = True 787 } 788 vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared 789 -- In the old days, if you said `ghc -package p-0.1 -package p-0.2` 790 -- (or if p-0.1 was registered in the pkgdb as exposed: True), 791 -- the second package flag would override the first one and you 792 -- would only see p-0.2 in exposed modules. This is good for 793 -- usability. 794 -- 795 -- However, with thinning and renaming (or Backpack), there might be 796 -- situations where you legitimately want to see two versions of a 797 -- package at the same time, and this behavior would make it 798 -- impossible to do so. So we decided that if you pass 799 -- -hide-all-packages, this should turn OFF the overriding behavior 800 -- where an exposed package hides all other packages with the same 801 -- name. This should not affect Cabal at all, which only ever 802 -- exposes one package at a time. 803 -- 804 -- NB: Why a variable no_hide_others? We have to apply this logic to 805 -- -plugin-package too, and it's more consistent if the switch in 806 -- behavior is based off of 807 -- -hide-all-packages/-hide-all-plugin-packages depending on what 808 -- flag is in question. 809 vm_cleared | no_hide_others = vm 810 -- NB: renamings never clear 811 | (_:_) <- rns = vm 812 | otherwise = Map.filterWithKey 813 (\k uv -> k == packageConfigId p 814 || First (Just n) /= uv_package_name uv) vm 815 _ -> panic "applyPackageFlag" 816 817 HidePackage str -> 818 case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of 819 Left ps -> packageFlagErr dflags flag ps 820 Right ps -> return vm' 821 where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps) 822 823-- | Like 'selectPackages', but doesn't return a list of unmatched 824-- packages. Furthermore, any packages it returns are *renamed* 825-- if the 'UnitArg' has a renaming associated with it. 826findPackages :: PackagePrecedenceIndex 827 -> PackageConfigMap -> PackageArg -> [PackageConfig] 828 -> UnusablePackages 829 -> Either [(PackageConfig, UnusablePackageReason)] 830 [PackageConfig] 831findPackages prec_map pkg_db arg pkgs unusable 832 = let ps = mapMaybe (finder arg) pkgs 833 in if null ps 834 then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) 835 (Map.elems unusable)) 836 else Right (sortByPreference prec_map ps) 837 where 838 finder (PackageArg str) p 839 = if str == sourcePackageIdString p || str == packageNameString p 840 then Just p 841 else Nothing 842 finder (UnitIdArg uid) p 843 = let (iuid, mb_indef) = splitUnitIdInsts uid 844 in if iuid == installedPackageConfigId p 845 then Just (case mb_indef of 846 Nothing -> p 847 Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p) 848 else Nothing 849 850selectPackages :: PackagePrecedenceIndex -> PackageArg -> [PackageConfig] 851 -> UnusablePackages 852 -> Either [(PackageConfig, UnusablePackageReason)] 853 ([PackageConfig], [PackageConfig]) 854selectPackages prec_map arg pkgs unusable 855 = let matches = matching arg 856 (ps,rest) = partition matches pkgs 857 in if null ps 858 then Left (filter (matches.fst) (Map.elems unusable)) 859 else Right (sortByPreference prec_map ps, rest) 860 861-- | Rename a 'PackageConfig' according to some module instantiation. 862renamePackage :: PackageConfigMap -> [(ModuleName, Module)] 863 -> PackageConfig -> PackageConfig 864renamePackage pkg_map insts conf = 865 let hsubst = listToUFM insts 866 smod = renameHoleModule' pkg_map hsubst 867 new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf) 868 in conf { 869 instantiatedWith = new_insts, 870 exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) 871 (exposedModules conf) 872 } 873 874 875-- A package named on the command line can either include the 876-- version, or just the name if it is unambiguous. 877matchingStr :: String -> PackageConfig -> Bool 878matchingStr str p 879 = str == sourcePackageIdString p 880 || str == packageNameString p 881 882matchingId :: InstalledUnitId -> PackageConfig -> Bool 883matchingId uid p = uid == installedPackageConfigId p 884 885matching :: PackageArg -> PackageConfig -> Bool 886matching (PackageArg str) = matchingStr str 887matching (UnitIdArg (DefiniteUnitId (DefUnitId uid))) = matchingId uid 888matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case 889 890-- | This sorts a list of packages, putting "preferred" packages first. 891-- See 'compareByPreference' for the semantics of "preference". 892sortByPreference :: PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig] 893sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) 894 895-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking 896-- which should be "active". Here is the order of preference: 897-- 898-- 1. First, prefer the latest version 899-- 2. If the versions are the same, prefer the package that 900-- came in the latest package database. 901-- 902-- Pursuant to #12518, we could change this policy to, for example, remove 903-- the version preference, meaning that we would always prefer the packages 904-- in later package database. 905-- 906-- Instead, we use that preference based policy only when one of the packages 907-- is integer-gmp and the other is integer-simple. 908-- This currently only happens when we're looking up which concrete 909-- package to use in place of @integer-wired-in@ and that two different 910-- package databases supply a different integer library. For more about 911-- the fake @integer-wired-in@ package, see Note [The integer library] 912-- in the @PrelNames@ module. 913compareByPreference 914 :: PackagePrecedenceIndex 915 -> PackageConfig 916 -> PackageConfig 917 -> Ordering 918compareByPreference prec_map pkg pkg' 919 | Just prec <- Map.lookup (unitId pkg) prec_map 920 , Just prec' <- Map.lookup (unitId pkg') prec_map 921 , differentIntegerPkgs pkg pkg' 922 = compare prec prec' 923 924 | otherwise 925 = case comparing packageVersion pkg pkg' of 926 GT -> GT 927 EQ | Just prec <- Map.lookup (unitId pkg) prec_map 928 , Just prec' <- Map.lookup (unitId pkg') prec_map 929 -- Prefer the package from the later DB flag (i.e., higher 930 -- precedence) 931 -> compare prec prec' 932 | otherwise 933 -> EQ 934 LT -> LT 935 936 where isIntegerPkg p = packageNameString p `elem` 937 ["integer-simple", "integer-gmp"] 938 differentIntegerPkgs p p' = 939 isIntegerPkg p && isIntegerPkg p' && 940 (packageName p /= packageName p') 941 942comparing :: Ord a => (t -> a) -> t -> t -> Ordering 943comparing f a b = f a `compare` f b 944 945packageFlagErr :: DynFlags 946 -> PackageFlag 947 -> [(PackageConfig, UnusablePackageReason)] 948 -> IO a 949packageFlagErr dflags flag reasons 950 = packageFlagErr' dflags (pprFlag flag) reasons 951 952trustFlagErr :: DynFlags 953 -> TrustFlag 954 -> [(PackageConfig, UnusablePackageReason)] 955 -> IO a 956trustFlagErr dflags flag reasons 957 = packageFlagErr' dflags (pprTrustFlag flag) reasons 958 959packageFlagErr' :: DynFlags 960 -> SDoc 961 -> [(PackageConfig, UnusablePackageReason)] 962 -> IO a 963packageFlagErr' dflags flag_doc reasons 964 = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err)) 965 where err = text "cannot satisfy " <> flag_doc <> 966 (if null reasons then Outputable.empty else text ": ") $$ 967 nest 4 (ppr_reasons $$ 968 text "(use -v for more information)") 969 ppr_reasons = vcat (map ppr_reason reasons) 970 ppr_reason (p, reason) = 971 pprReason (ppr (unitId p) <+> text "is") reason 972 973pprFlag :: PackageFlag -> SDoc 974pprFlag flag = case flag of 975 HidePackage p -> text "-hide-package " <> text p 976 ExposePackage doc _ _ -> text doc 977 978pprTrustFlag :: TrustFlag -> SDoc 979pprTrustFlag flag = case flag of 980 TrustPackage p -> text "-trust " <> text p 981 DistrustPackage p -> text "-distrust " <> text p 982 983-- ----------------------------------------------------------------------------- 984-- Wired-in packages 985-- 986-- See Note [Wired-in packages] in Module 987 988type WiredInUnitId = String 989type WiredPackagesMap = Map WiredUnitId WiredUnitId 990 991wired_in_pkgids :: [WiredInUnitId] 992wired_in_pkgids = map unitIdString wiredInUnitIds 993 994findWiredInPackages 995 :: DynFlags 996 -> PackagePrecedenceIndex 997 -> [PackageConfig] -- database 998 -> VisibilityMap -- info on what packages are visible 999 -- for wired in selection 1000 -> IO ([PackageConfig], -- package database updated for wired in 1001 WiredPackagesMap) -- map from unit id to wired identity 1002 1003findWiredInPackages dflags prec_map pkgs vis_map = do 1004 -- Now we must find our wired-in packages, and rename them to 1005 -- their canonical names (eg. base-1.0 ==> base), as described 1006 -- in Note [Wired-in packages] in Module 1007 let 1008 matches :: PackageConfig -> WiredInUnitId -> Bool 1009 pc `matches` pid 1010 -- See Note [The integer library] in PrelNames 1011 | pid == unitIdString integerUnitId 1012 = packageNameString pc `elem` ["integer-gmp", "integer-simple"] 1013 pc `matches` pid = packageNameString pc == pid 1014 1015 -- find which package corresponds to each wired-in package 1016 -- delete any other packages with the same name 1017 -- update the package and any dependencies to point to the new 1018 -- one. 1019 -- 1020 -- When choosing which package to map to a wired-in package 1021 -- name, we try to pick the latest version of exposed packages. 1022 -- However, if there are no exposed wired in packages available 1023 -- (e.g. -hide-all-packages was used), we can't bail: we *have* 1024 -- to assign a package for the wired-in package: so we try again 1025 -- with hidden packages included to (and pick the latest 1026 -- version). 1027 -- 1028 -- You can also override the default choice by using -ignore-package: 1029 -- this works even when there is no exposed wired in package 1030 -- available. 1031 -- 1032 findWiredInPackage :: [PackageConfig] -> WiredInUnitId 1033 -> IO (Maybe (WiredInUnitId, PackageConfig)) 1034 findWiredInPackage pkgs wired_pkg = 1035 let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] 1036 all_exposed_ps = 1037 [ p | p <- all_ps 1038 , Map.member (packageConfigId p) vis_map ] in 1039 case all_exposed_ps of 1040 [] -> case all_ps of 1041 [] -> notfound 1042 many -> pick (head (sortByPreference prec_map many)) 1043 many -> pick (head (sortByPreference prec_map many)) 1044 where 1045 notfound = do 1046 debugTraceMsg dflags 2 $ 1047 text "wired-in package " 1048 <> text wired_pkg 1049 <> text " not found." 1050 return Nothing 1051 pick :: PackageConfig 1052 -> IO (Maybe (WiredInUnitId, PackageConfig)) 1053 pick pkg = do 1054 debugTraceMsg dflags 2 $ 1055 text "wired-in package " 1056 <> text wired_pkg 1057 <> text " mapped to " 1058 <> ppr (unitId pkg) 1059 return (Just (wired_pkg, pkg)) 1060 1061 1062 mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids 1063 let 1064 wired_in_pkgs = catMaybes mb_wired_in_pkgs 1065 1066 -- this is old: we used to assume that if there were 1067 -- multiple versions of wired-in packages installed that 1068 -- they were mutually exclusive. Now we're assuming that 1069 -- you have one "main" version of each wired-in package 1070 -- (the latest version), and the others are backward-compat 1071 -- wrappers that depend on this one. e.g. base-4.0 is the 1072 -- latest, base-3.0 is a compat wrapper depending on base-4.0. 1073 {- 1074 deleteOtherWiredInPackages pkgs = filterOut bad pkgs 1075 where bad p = any (p `matches`) wired_in_pkgids 1076 && package p `notElem` map fst wired_in_ids 1077 -} 1078 1079 wiredInMap :: Map WiredUnitId WiredUnitId 1080 wiredInMap = Map.fromList 1081 [ (key, DefUnitId (stringToInstalledUnitId wiredInUnitId)) 1082 | (wiredInUnitId, pkg) <- wired_in_pkgs 1083 , Just key <- pure $ definitePackageConfigId pkg 1084 ] 1085 1086 updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs 1087 where upd_pkg pkg 1088 | Just def_uid <- definitePackageConfigId pkg 1089 , Just wiredInUnitId <- Map.lookup def_uid wiredInMap 1090 = let fs = installedUnitIdFS (unDefUnitId wiredInUnitId) 1091 in pkg { 1092 unitId = fsToInstalledUnitId fs, 1093 componentId = ComponentId fs 1094 } 1095 | otherwise 1096 = pkg 1097 upd_deps pkg = pkg { 1098 -- temporary harmless DefUnitId invariant violation 1099 depends = map (unDefUnitId . upd_wired_in wiredInMap . DefUnitId) (depends pkg), 1100 exposedModules 1101 = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) 1102 (exposedModules pkg) 1103 } 1104 1105 1106 return (updateWiredInDependencies pkgs, wiredInMap) 1107 1108-- Helper functions for rewiring Module and UnitId. These 1109-- rewrite UnitIds of modules in wired-in packages to the form known to the 1110-- compiler, as described in Note [Wired-in packages] in Module. 1111-- 1112-- For instance, base-4.9.0.0 will be rewritten to just base, to match 1113-- what appears in PrelNames. 1114 1115upd_wired_in_mod :: WiredPackagesMap -> Module -> Module 1116upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m 1117 1118upd_wired_in_uid :: WiredPackagesMap -> UnitId -> UnitId 1119upd_wired_in_uid wiredInMap (DefiniteUnitId def_uid) = 1120 DefiniteUnitId (upd_wired_in wiredInMap def_uid) 1121upd_wired_in_uid wiredInMap (IndefiniteUnitId indef_uid) = 1122 IndefiniteUnitId $ newIndefUnitId 1123 (indefUnitIdComponentId indef_uid) 1124 (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (indefUnitIdInsts indef_uid)) 1125 1126upd_wired_in :: WiredPackagesMap -> DefUnitId -> DefUnitId 1127upd_wired_in wiredInMap key 1128 | Just key' <- Map.lookup key wiredInMap = key' 1129 | otherwise = key 1130 1131updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap 1132updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) 1133 where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of 1134 Nothing -> vm 1135 Just r -> Map.insert (DefiniteUnitId to) r 1136 (Map.delete (DefiniteUnitId from) vm) 1137 1138 1139-- ---------------------------------------------------------------------------- 1140 1141-- | The reason why a package is unusable. 1142data UnusablePackageReason 1143 = -- | We ignored it explicitly using @-ignore-package@. 1144 IgnoredWithFlag 1145 -- | This package transitively depends on a package that was never present 1146 -- in any of the provided databases. 1147 | BrokenDependencies [InstalledUnitId] 1148 -- | This package transitively depends on a package involved in a cycle. 1149 -- Note that the list of 'InstalledUnitId' reports the direct dependencies 1150 -- of this package that (transitively) depended on the cycle, and not 1151 -- the actual cycle itself (which we report separately at high verbosity.) 1152 | CyclicDependencies [InstalledUnitId] 1153 -- | This package transitively depends on a package which was ignored. 1154 | IgnoredDependencies [InstalledUnitId] 1155 -- | This package transitively depends on a package which was 1156 -- shadowed by an ABI-incompatible package. 1157 | ShadowedDependencies [InstalledUnitId] 1158 1159instance Outputable UnusablePackageReason where 1160 ppr IgnoredWithFlag = text "[ignored with flag]" 1161 ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) 1162 ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) 1163 ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) 1164 ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) 1165 1166type UnusablePackages = Map InstalledUnitId 1167 (PackageConfig, UnusablePackageReason) 1168 1169pprReason :: SDoc -> UnusablePackageReason -> SDoc 1170pprReason pref reason = case reason of 1171 IgnoredWithFlag -> 1172 pref <+> text "ignored due to an -ignore-package flag" 1173 BrokenDependencies deps -> 1174 pref <+> text "unusable due to missing dependencies:" $$ 1175 nest 2 (hsep (map ppr deps)) 1176 CyclicDependencies deps -> 1177 pref <+> text "unusable due to cyclic dependencies:" $$ 1178 nest 2 (hsep (map ppr deps)) 1179 IgnoredDependencies deps -> 1180 pref <+> text ("unusable because the -ignore-package flag was used to " ++ 1181 "ignore at least one of its dependencies:") $$ 1182 nest 2 (hsep (map ppr deps)) 1183 ShadowedDependencies deps -> 1184 pref <+> text "unusable due to shadowed dependencies:" $$ 1185 nest 2 (hsep (map ppr deps)) 1186 1187reportCycles :: DynFlags -> [SCC PackageConfig] -> IO () 1188reportCycles dflags sccs = mapM_ report sccs 1189 where 1190 report (AcyclicSCC _) = return () 1191 report (CyclicSCC vs) = 1192 debugTraceMsg dflags 2 $ 1193 text "these packages are involved in a cycle:" $$ 1194 nest 2 (hsep (map (ppr . unitId) vs)) 1195 1196reportUnusable :: DynFlags -> UnusablePackages -> IO () 1197reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) 1198 where 1199 report (ipid, (_, reason)) = 1200 debugTraceMsg dflags 2 $ 1201 pprReason 1202 (text "package" <+> ppr ipid <+> text "is") reason 1203 1204-- ---------------------------------------------------------------------------- 1205-- 1206-- Utilities on the database 1207-- 1208 1209-- | A reverse dependency index, mapping an 'InstalledUnitId' to 1210-- the 'InstalledUnitId's which have a dependency on it. 1211type RevIndex = Map InstalledUnitId [InstalledUnitId] 1212 1213-- | Compute the reverse dependency index of a package database. 1214reverseDeps :: InstalledPackageIndex -> RevIndex 1215reverseDeps db = Map.foldl' go Map.empty db 1216 where 1217 go r pkg = foldl' (go' (unitId pkg)) r (depends pkg) 1218 go' from r to = Map.insertWith (++) to [from] r 1219 1220-- | Given a list of 'InstalledUnitId's to remove, a database, 1221-- and a reverse dependency index (as computed by 'reverseDeps'), 1222-- remove those packages, plus any packages which depend on them. 1223-- Returns the pruned database, as well as a list of 'PackageConfig's 1224-- that was removed. 1225removePackages :: [InstalledUnitId] -> RevIndex 1226 -> InstalledPackageIndex 1227 -> (InstalledPackageIndex, [PackageConfig]) 1228removePackages uids index m = go uids (m,[]) 1229 where 1230 go [] (m,pkgs) = (m,pkgs) 1231 go (uid:uids) (m,pkgs) 1232 | Just pkg <- Map.lookup uid m 1233 = case Map.lookup uid index of 1234 Nothing -> go uids (Map.delete uid m, pkg:pkgs) 1235 Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs) 1236 | otherwise 1237 = go uids (m,pkgs) 1238 1239-- | Given a 'PackageConfig' from some 'InstalledPackageIndex', 1240-- return all entries in 'depends' which correspond to packages 1241-- that do not exist in the index. 1242depsNotAvailable :: InstalledPackageIndex 1243 -> PackageConfig 1244 -> [InstalledUnitId] 1245depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (depends pkg) 1246 1247-- | Given a 'PackageConfig' from some 'InstalledPackageIndex' 1248-- return all entries in 'abiDepends' which correspond to packages 1249-- that do not exist, OR have mismatching ABIs. 1250depsAbiMismatch :: InstalledPackageIndex 1251 -> PackageConfig 1252 -> [InstalledUnitId] 1253depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ abiDepends pkg 1254 where 1255 abiMatch (dep_uid, abi) 1256 | Just dep_pkg <- Map.lookup dep_uid pkg_map 1257 = abiHash dep_pkg == abi 1258 | otherwise 1259 = False 1260 1261-- ----------------------------------------------------------------------------- 1262-- Ignore packages 1263 1264ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages 1265ignorePackages flags pkgs = Map.fromList (concatMap doit flags) 1266 where 1267 doit (IgnorePackage str) = 1268 case partition (matchingStr str) pkgs of 1269 (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) 1270 | p <- ps ] 1271 -- missing package is not an error for -ignore-package, 1272 -- because a common usage is to -ignore-package P as 1273 -- a preventative measure just in case P exists. 1274 1275-- ---------------------------------------------------------------------------- 1276-- 1277-- Merging databases 1278-- 1279 1280-- | For each package, a mapping from uid -> i indicates that this 1281-- package was brought into GHC by the ith @-package-db@ flag on 1282-- the command line. We use this mapping to make sure we prefer 1283-- packages that were defined later on the command line, if there 1284-- is an ambiguity. 1285type PackagePrecedenceIndex = Map InstalledUnitId Int 1286 1287-- | Given a list of databases, merge them together, where 1288-- packages with the same unit id in later databases override 1289-- earlier ones. This does NOT check if the resulting database 1290-- makes sense (that's done by 'validateDatabase'). 1291mergeDatabases :: DynFlags -> [(FilePath, [PackageConfig])] 1292 -> IO (InstalledPackageIndex, PackagePrecedenceIndex) 1293mergeDatabases dflags = foldM merge (Map.empty, Map.empty) . zip [1..] 1294 where 1295 merge (pkg_map, prec_map) (i, (db_path, db)) = do 1296 debugTraceMsg dflags 2 $ 1297 text "loading package database" <+> text db_path 1298 forM_ (Set.toList override_set) $ \pkg -> 1299 debugTraceMsg dflags 2 $ 1300 text "package" <+> ppr pkg <+> 1301 text "overrides a previously defined package" 1302 return (pkg_map', prec_map') 1303 where 1304 db_map = mk_pkg_map db 1305 mk_pkg_map = Map.fromList . map (\p -> (unitId p, p)) 1306 1307 -- The set of UnitIds which appear in both db and pkgs. These are the 1308 -- ones that get overridden. Compute this just to give some 1309 -- helpful debug messages at -v2 1310 override_set :: Set InstalledUnitId 1311 override_set = Set.intersection (Map.keysSet db_map) 1312 (Map.keysSet pkg_map) 1313 1314 -- Now merge the sets together (NB: in case of duplicate, 1315 -- first argument preferred) 1316 pkg_map' :: InstalledPackageIndex 1317 pkg_map' = Map.union db_map pkg_map 1318 1319 prec_map' :: PackagePrecedenceIndex 1320 prec_map' = Map.union (Map.map (const i) db_map) prec_map 1321 1322-- | Validates a database, removing unusable packages from it 1323-- (this includes removing packages that the user has explicitly 1324-- ignored.) Our general strategy: 1325-- 1326-- 1. Remove all broken packages (dangling dependencies) 1327-- 2. Remove all packages that are cyclic 1328-- 3. Apply ignore flags 1329-- 4. Remove all packages which have deps with mismatching ABIs 1330-- 1331validateDatabase :: DynFlags -> InstalledPackageIndex 1332 -> (InstalledPackageIndex, UnusablePackages, [SCC PackageConfig]) 1333validateDatabase dflags pkg_map1 = 1334 (pkg_map5, unusable, sccs) 1335 where 1336 ignore_flags = reverse (ignorePackageFlags dflags) 1337 1338 -- Compute the reverse dependency index 1339 index = reverseDeps pkg_map1 1340 1341 -- Helper function 1342 mk_unusable mk_err dep_matcher m uids = 1343 Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) 1344 | pkg <- uids ] 1345 1346 -- Find broken packages 1347 directly_broken = filter (not . null . depsNotAvailable pkg_map1) 1348 (Map.elems pkg_map1) 1349 (pkg_map2, broken) = removePackages (map unitId directly_broken) index pkg_map1 1350 unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken 1351 1352 -- Find recursive packages 1353 sccs = stronglyConnComp [ (pkg, unitId pkg, depends pkg) 1354 | pkg <- Map.elems pkg_map2 ] 1355 getCyclicSCC (CyclicSCC vs) = map unitId vs 1356 getCyclicSCC (AcyclicSCC _) = [] 1357 (pkg_map3, cyclic) = removePackages (concatMap getCyclicSCC sccs) index pkg_map2 1358 unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic 1359 1360 -- Apply ignore flags 1361 directly_ignored = ignorePackages ignore_flags (Map.elems pkg_map3) 1362 (pkg_map4, ignored) = removePackages (Map.keys directly_ignored) index pkg_map3 1363 unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored 1364 1365 -- Knock out packages whose dependencies don't agree with ABI 1366 -- (i.e., got invalidated due to shadowing) 1367 directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) 1368 (Map.elems pkg_map4) 1369 (pkg_map5, shadowed) = removePackages (map unitId directly_shadowed) index pkg_map4 1370 unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed 1371 1372 unusable = directly_ignored `Map.union` unusable_ignored 1373 `Map.union` unusable_broken 1374 `Map.union` unusable_cyclic 1375 `Map.union` unusable_shadowed 1376 1377-- ----------------------------------------------------------------------------- 1378-- When all the command-line options are in, we can process our package 1379-- settings and populate the package state. 1380 1381mkPackageState 1382 :: DynFlags 1383 -- initial databases, in the order they were specified on 1384 -- the command line (later databases shadow earlier ones) 1385 -> [(FilePath, [PackageConfig])] 1386 -> [PreloadUnitId] -- preloaded packages 1387 -> IO (PackageState, 1388 [PreloadUnitId], -- new packages to preload 1389 Maybe [(ModuleName, Module)]) 1390 1391mkPackageState dflags dbs preload0 = do 1392{- 1393 Plan. 1394 1395 There are two main steps for making the package state: 1396 1397 1. We want to build a single, unified package database based 1398 on all of the input databases, which upholds the invariant that 1399 there is only one package per any UnitId and there are no 1400 dangling dependencies. We'll do this by merging, and 1401 then successively filtering out bad dependencies. 1402 1403 a) Merge all the databases together. 1404 If an input database defines unit ID that is already in 1405 the unified database, that package SHADOWS the existing 1406 package in the current unified database. Note that 1407 order is important: packages defined later in the list of 1408 command line arguments shadow those defined earlier. 1409 1410 b) Remove all packages with missing dependencies, or 1411 mutually recursive dependencies. 1412 1413 b) Remove packages selected by -ignore-package from input database 1414 1415 c) Remove all packages which depended on packages that are now 1416 shadowed by an ABI-incompatible package 1417 1418 d) report (with -v) any packages that were removed by steps 1-3 1419 1420 2. We want to look at the flags controlling package visibility, 1421 and build a mapping of what module names are in scope and 1422 where they live. 1423 1424 a) on the final, unified database, we apply -trust/-distrust 1425 flags directly, modifying the database so that the 'trusted' 1426 field has the correct value. 1427 1428 b) we use the -package/-hide-package flags to compute a 1429 visibility map, stating what packages are "exposed" for 1430 the purposes of computing the module map. 1431 * if any flag refers to a package which was removed by 1-5, then 1432 we can give an error message explaining why 1433 * if -hide-all-packages what not specified, this step also 1434 hides packages which are superseded by later exposed packages 1435 * this step is done TWICE if -plugin-package/-hide-all-plugin-packages 1436 are used 1437 1438 c) based on the visibility map, we pick wired packages and rewrite 1439 them to have the expected unitId. 1440 1441 d) finally, using the visibility map and the package database, 1442 we build a mapping saying what every in scope module name points to. 1443-} 1444 1445 -- This, and the other reverse's that you will see, are due to the face that 1446 -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order 1447 -- than they are on the command line. 1448 let other_flags = reverse (packageFlags dflags) 1449 debugTraceMsg dflags 2 $ 1450 text "package flags" <+> ppr other_flags 1451 1452 -- Merge databases together, without checking validity 1453 (pkg_map1, prec_map) <- mergeDatabases dflags dbs 1454 1455 -- Now that we've merged everything together, prune out unusable 1456 -- packages. 1457 let (pkg_map2, unusable, sccs) = validateDatabase dflags pkg_map1 1458 1459 reportCycles dflags sccs 1460 reportUnusable dflags unusable 1461 1462 -- Apply trust flags (these flags apply regardless of whether 1463 -- or not packages are visible or not) 1464 pkgs1 <- foldM (applyTrustFlag dflags prec_map unusable) 1465 (Map.elems pkg_map2) (reverse (trustFlags dflags)) 1466 let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1 1467 1468 -- 1469 -- Calculate the initial set of units from package databases, prior to any package flags. 1470 -- 1471 -- Conceptually, we select the latest versions of all valid (not unusable) *packages* 1472 -- (not units). This is empty if we have -hide-all-packages. 1473 -- 1474 -- Then we create an initial visibility map with default visibilities for all 1475 -- exposed, definite units which belong to the latest valid packages. 1476 -- 1477 let preferLater unit unit' = 1478 case compareByPreference prec_map unit unit' of 1479 GT -> unit 1480 _ -> unit' 1481 addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit 1482 -- This is the set of maximally preferable packages. In fact, it is a set of 1483 -- most preferable *units* keyed by package name, which act as stand-ins in 1484 -- for "a package in a database". We use units here because we don't have 1485 -- "a package in a database" as a type currently. 1486 mostPreferablePackageReps = if gopt Opt_HideAllPackages dflags 1487 then emptyUDFM 1488 else foldl' addIfMorePreferable emptyUDFM pkgs1 1489 -- When exposing units, we want to consider all of those in the most preferable 1490 -- packages. We can implement that by looking for units that are equi-preferable 1491 -- with the most preferable unit for package. Being equi-preferable means that 1492 -- they must be in the same database, with the same version, and the same pacakge name. 1493 -- 1494 -- We must take care to consider all these units and not just the most 1495 -- preferable one, otherwise we can end up with problems like #16228. 1496 mostPreferable u = 1497 case lookupUDFM mostPreferablePackageReps (fsPackageName u) of 1498 Nothing -> False 1499 Just u' -> compareByPreference prec_map u u' == EQ 1500 vis_map1 = foldl' (\vm p -> 1501 -- Note: we NEVER expose indefinite packages by 1502 -- default, because it's almost assuredly not 1503 -- what you want (no mix-in linking has occurred). 1504 if exposed p && unitIdIsDefinite (packageConfigId p) && mostPreferable p 1505 then Map.insert (packageConfigId p) 1506 UnitVisibility { 1507 uv_expose_all = True, 1508 uv_renamings = [], 1509 uv_package_name = First (Just (fsPackageName p)), 1510 uv_requirements = Map.empty, 1511 uv_explicit = False 1512 } 1513 vm 1514 else vm) 1515 Map.empty pkgs1 1516 1517 -- 1518 -- Compute a visibility map according to the command-line flags (-package, 1519 -- -hide-package). This needs to know about the unusable packages, since if a 1520 -- user tries to enable an unusable package, we should let them know. 1521 -- 1522 vis_map2 <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable 1523 (gopt Opt_HideAllPackages dflags) pkgs1) 1524 vis_map1 other_flags 1525 1526 -- 1527 -- Sort out which packages are wired in. This has to be done last, since 1528 -- it modifies the unit ids of wired in packages, but when we process 1529 -- package arguments we need to key against the old versions. 1530 -- 1531 (pkgs2, wired_map) <- findWiredInPackages dflags prec_map pkgs1 vis_map2 1532 let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2 1533 1534 -- Update the visibility map, so we treat wired packages as visible. 1535 let vis_map = updateVisibilityMap wired_map vis_map2 1536 1537 let hide_plugin_pkgs = gopt Opt_HideAllPluginPackages dflags 1538 plugin_vis_map <- 1539 case pluginPackageFlags dflags of 1540 -- common case; try to share the old vis_map 1541 [] | not hide_plugin_pkgs -> return vis_map 1542 | otherwise -> return Map.empty 1543 _ -> do let plugin_vis_map1 1544 | hide_plugin_pkgs = Map.empty 1545 -- Use the vis_map PRIOR to wired in, 1546 -- because otherwise applyPackageFlag 1547 -- won't work. 1548 | otherwise = vis_map2 1549 plugin_vis_map2 1550 <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable 1551 (gopt Opt_HideAllPluginPackages dflags) pkgs1) 1552 plugin_vis_map1 1553 (reverse (pluginPackageFlags dflags)) 1554 -- Updating based on wired in packages is mostly 1555 -- good hygiene, because it won't matter: no wired in 1556 -- package has a compiler plugin. 1557 -- TODO: If a wired in package had a compiler plugin, 1558 -- and you tried to pick different wired in packages 1559 -- with the plugin flags and the normal flags... what 1560 -- would happen? I don't know! But this doesn't seem 1561 -- likely to actually happen. 1562 return (updateVisibilityMap wired_map plugin_vis_map2) 1563 1564 -- 1565 -- Here we build up a set of the packages mentioned in -package 1566 -- flags on the command line; these are called the "preload" 1567 -- packages. we link these packages in eagerly. The preload set 1568 -- should contain at least rts & base, which is why we pretend that 1569 -- the command line contains -package rts & -package base. 1570 -- 1571 -- NB: preload IS important even for type-checking, because we 1572 -- need the correct include path to be set. 1573 -- 1574 let preload1 = Map.keys (Map.filter uv_explicit vis_map) 1575 1576 let pkgname_map = foldl' add Map.empty pkgs2 1577 where add pn_map p 1578 = Map.insert (packageName p) (componentId p) pn_map 1579 1580 -- The explicitPackages accurately reflects the set of packages we have turned 1581 -- on; as such, it also is the only way one can come up with requirements. 1582 -- The requirement context is directly based off of this: we simply 1583 -- look for nested unit IDs that are directly fed holes: the requirements 1584 -- of those units are precisely the ones we need to track 1585 let explicit_pkgs = Map.keys vis_map 1586 req_ctx = Map.map (Set.toList) 1587 $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map)) 1588 1589 1590 let preload2 = preload1 1591 1592 let 1593 -- add base & rts to the preload packages 1594 basicLinkedPackages 1595 | gopt Opt_AutoLinkPackages dflags 1596 = filter (flip elemUDFM (unPackageConfigMap pkg_db)) 1597 [baseUnitId, rtsUnitId] 1598 | otherwise = [] 1599 -- but in any case remove the current package from the set of 1600 -- preloaded packages so that base/rts does not end up in the 1601 -- set up preloaded package when we are just building it 1602 -- (NB: since this is only relevant for base/rts it doesn't matter 1603 -- that thisUnitIdInsts_ is not wired yet) 1604 -- 1605 preload3 = ordNub $ filter (/= thisPackage dflags) 1606 $ (basicLinkedPackages ++ preload2) 1607 1608 -- Close the preload packages with their dependencies 1609 dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing)) 1610 let new_dep_preload = filter (`notElem` preload0) dep_preload 1611 1612 let mod_map1 = mkModuleToPkgConfAll dflags pkg_db vis_map 1613 mod_map2 = mkUnusableModuleToPkgConfAll unusable 1614 mod_map = Map.union mod_map1 mod_map2 1615 1616 dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map" 1617 (pprModuleMap mod_map) 1618 1619 -- Force pstate to avoid leaking the dflags0 passed to mkPackageState 1620 let !pstate = PackageState{ 1621 preloadPackages = dep_preload, 1622 explicitPackages = explicit_pkgs, 1623 pkgIdMap = pkg_db, 1624 moduleToPkgConfAll = mod_map, 1625 pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map, 1626 packageNameMap = pkgname_map, 1627 unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ], 1628 requirementContext = req_ctx 1629 } 1630 let new_insts = fmap (map (fmap (upd_wired_in_mod wired_map))) (thisUnitIdInsts_ dflags) 1631 return (pstate, new_dep_preload, new_insts) 1632 1633-- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId' 1634-- that it was recorded as in the package database. 1635unwireUnitId :: DynFlags -> UnitId -> UnitId 1636unwireUnitId dflags uid@(DefiniteUnitId def_uid) = 1637 maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags))) 1638unwireUnitId _ uid = uid 1639 1640-- ----------------------------------------------------------------------------- 1641-- | Makes the mapping from module to package info 1642 1643-- Slight irritation: we proceed by leafing through everything 1644-- in the installed package database, which makes handling indefinite 1645-- packages a bit bothersome. 1646 1647mkModuleToPkgConfAll 1648 :: DynFlags 1649 -> PackageConfigMap 1650 -> VisibilityMap 1651 -> ModuleToPkgConfAll 1652mkModuleToPkgConfAll dflags pkg_db vis_map = 1653 -- What should we fold on? Both situations are awkward: 1654 -- 1655 -- * Folding on the visibility map means that we won't create 1656 -- entries for packages that aren't mentioned in vis_map 1657 -- (e.g., hidden packages, causing #14717) 1658 -- 1659 -- * Folding on pkg_db is awkward because if we have an 1660 -- Backpack instantiation, we need to possibly add a 1661 -- package from pkg_db multiple times to the actual 1662 -- ModuleToPkgConfAll. Also, we don't really want 1663 -- definite package instantiations to show up in the 1664 -- list of possibilities. 1665 -- 1666 -- So what will we do instead? We'll extend vis_map with 1667 -- entries for every definite (for non-Backpack) and 1668 -- indefinite (for Backpack) package, so that we get the 1669 -- hidden entries we need. 1670 Map.foldlWithKey extend_modmap emptyMap vis_map_extended 1671 where 1672 vis_map_extended = Map.union vis_map {- preferred -} default_vis 1673 1674 default_vis = Map.fromList 1675 [ (packageConfigId pkg, mempty) 1676 | pkg <- eltsUDFM (unPackageConfigMap pkg_db) 1677 -- Exclude specific instantiations of an indefinite 1678 -- package 1679 , indefinite pkg || null (instantiatedWith pkg) 1680 ] 1681 1682 emptyMap = Map.empty 1683 setOrigins m os = fmap (const os) m 1684 extend_modmap modmap uid 1685 UnitVisibility { uv_expose_all = b, uv_renamings = rns } 1686 = addListTo modmap theBindings 1687 where 1688 pkg = pkg_lookup uid 1689 1690 theBindings :: [(ModuleName, Map Module ModuleOrigin)] 1691 theBindings = newBindings b rns 1692 1693 newBindings :: Bool 1694 -> [(ModuleName, ModuleName)] 1695 -> [(ModuleName, Map Module ModuleOrigin)] 1696 newBindings e rns = es e ++ hiddens ++ map rnBinding rns 1697 1698 rnBinding :: (ModuleName, ModuleName) 1699 -> (ModuleName, Map Module ModuleOrigin) 1700 rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) 1701 where origEntry = case lookupUFM esmap orig of 1702 Just r -> r 1703 Nothing -> throwGhcException (CmdLineError (showSDoc dflags 1704 (text "package flag: could not find module name" <+> 1705 ppr orig <+> text "in package" <+> ppr pk))) 1706 1707 es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] 1708 es e = do 1709 (m, exposedReexport) <- exposed_mods 1710 let (pk', m', origin') = 1711 case exposedReexport of 1712 Nothing -> (pk, m, fromExposedModules e) 1713 Just (Module pk' m') -> 1714 let pkg' = pkg_lookup pk' 1715 in (pk', m', fromReexportedModules e pkg') 1716 return (m, mkModMap pk' m' origin') 1717 1718 esmap :: UniqFM (Map Module ModuleOrigin) 1719 esmap = listToUFM (es False) -- parameter here doesn't matter, orig will 1720 -- be overwritten 1721 1722 hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] 1723 1724 pk = packageConfigId pkg 1725 pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid 1726 `orElse` pprPanic "pkg_lookup" (ppr uid) 1727 1728 exposed_mods = exposedModules pkg 1729 hidden_mods = hiddenModules pkg 1730 1731-- | Make a 'ModuleToPkgConfAll' covering a set of unusable packages. 1732mkUnusableModuleToPkgConfAll :: UnusablePackages -> ModuleToPkgConfAll 1733mkUnusableModuleToPkgConfAll unusables = 1734 Map.foldl' extend_modmap Map.empty unusables 1735 where 1736 extend_modmap modmap (pkg, reason) = addListTo modmap bindings 1737 where bindings :: [(ModuleName, Map Module ModuleOrigin)] 1738 bindings = exposed ++ hidden 1739 1740 origin = ModUnusable reason 1741 pkg_id = packageConfigId pkg 1742 1743 exposed = map get_exposed exposed_mods 1744 hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods] 1745 1746 get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin) 1747 get_exposed (mod, _) = (mod, mkModMap pkg_id mod origin) 1748 1749 exposed_mods = exposedModules pkg 1750 hidden_mods = hiddenModules pkg 1751 1752-- | Add a list of key/value pairs to a nested map. 1753-- 1754-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks 1755-- when reloading modules in GHCi (see #4029). This ensures that each 1756-- value is forced before installing into the map. 1757addListTo :: (Monoid a, Ord k1, Ord k2) 1758 => Map k1 (Map k2 a) 1759 -> [(k1, Map k2 a)] 1760 -> Map k1 (Map k2 a) 1761addListTo = foldl' merge 1762 where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m 1763 1764-- | Create a singleton module mapping 1765mkModMap :: UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin 1766mkModMap pkg mod = Map.singleton (mkModule pkg mod) 1767 1768-- ----------------------------------------------------------------------------- 1769-- Extracting information from the packages in scope 1770 1771-- Many of these functions take a list of packages: in those cases, 1772-- the list is expected to contain the "dependent packages", 1773-- i.e. those packages that were found to be depended on by the 1774-- current module/program. These can be auto or non-auto packages, it 1775-- doesn't really matter. The list is always combined with the list 1776-- of preload (command-line) packages to determine which packages to 1777-- use. 1778 1779-- | Find all the include directories in these and the preload packages 1780getPackageIncludePath :: DynFlags -> [PreloadUnitId] -> IO [String] 1781getPackageIncludePath dflags pkgs = 1782 collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs 1783 1784collectIncludeDirs :: [PackageConfig] -> [FilePath] 1785collectIncludeDirs ps = ordNub (filter notNull (concatMap includeDirs ps)) 1786 1787-- | Find all the library paths in these and the preload packages 1788getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String] 1789getPackageLibraryPath dflags pkgs = 1790 collectLibraryPaths dflags `fmap` getPreloadPackagesAnd dflags pkgs 1791 1792collectLibraryPaths :: DynFlags -> [PackageConfig] -> [FilePath] 1793collectLibraryPaths dflags = ordNub . filter notNull 1794 . concatMap (libraryDirsForWay dflags) 1795 1796-- | Find all the link options in these and the preload packages, 1797-- returning (package hs lib options, extra library options, other flags) 1798getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String]) 1799getPackageLinkOpts dflags pkgs = 1800 collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs 1801 1802collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String]) 1803collectLinkOpts dflags ps = 1804 ( 1805 concatMap (map ("-l" ++) . packageHsLibs dflags) ps, 1806 concatMap (map ("-l" ++) . extraLibraries) ps, 1807 concatMap ldOptions ps 1808 ) 1809collectArchives :: DynFlags -> PackageConfig -> IO [FilePath] 1810collectArchives dflags pc = 1811 filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a") 1812 | searchPath <- searchPaths 1813 , lib <- libs ] 1814 where searchPaths = ordNub . filter notNull . libraryDirsForWay dflags $ pc 1815 libs = packageHsLibs dflags pc ++ extraLibraries pc 1816 1817getLibs :: DynFlags -> [PreloadUnitId] -> IO [(String,String)] 1818getLibs dflags pkgs = do 1819 ps <- getPreloadPackagesAnd dflags pkgs 1820 fmap concat . forM ps $ \p -> do 1821 let candidates = [ (l </> f, f) | l <- collectLibraryPaths dflags [p] 1822 , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ] 1823 filterM (doesFileExist . fst) candidates 1824 1825packageHsLibs :: DynFlags -> PackageConfig -> [String] 1826packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) 1827 where 1828 ways0 = ways dflags 1829 1830 ways1 = filter (/= WayDyn) ways0 1831 -- the name of a shared library is libHSfoo-ghc<version>.so 1832 -- we leave out the _dyn, because it is superfluous 1833 1834 -- debug and profiled RTSs include support for -eventlog 1835 ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1 1836 = filter (/= WayEventLog) ways1 1837 | otherwise 1838 = ways1 1839 1840 tag = mkBuildTag (filter (not . wayRTSOnly) ways2) 1841 rts_tag = mkBuildTag ways2 1842 1843 mkDynName x 1844 | WayDyn `notElem` ways dflags = x 1845 | "HS" `isPrefixOf` x = 1846 x ++ '-':programName dflags ++ projectVersion dflags 1847 -- For non-Haskell libraries, we use the name "Cfoo". The .a 1848 -- file is libCfoo.a, and the .so is libfoo.so. That way the 1849 -- linker knows what we mean for the vanilla (-lCfoo) and dyn 1850 -- (-lfoo) ways. We therefore need to strip the 'C' off here. 1851 | Just x' <- stripPrefix "C" x = x' 1852 | otherwise 1853 = panic ("Don't understand library name " ++ x) 1854 1855 -- Add _thr and other rts suffixes to packages named 1856 -- `rts` or `rts-1.0`. Why both? Traditionally the rts 1857 -- package is called `rts` only. However the tooling 1858 -- usually expects a package name to have a version. 1859 -- As such we will gradually move towards the `rts-1.0` 1860 -- package name, at which point the `rts` package name 1861 -- will eventually be unused. 1862 -- 1863 -- This change elevates the need to add custom hooks 1864 -- and handling specifically for the `rts` package for 1865 -- example in ghc-cabal. 1866 addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) 1867 addSuffix rts@"HSrts-1.0.1" = rts ++ (expandTag rts_tag) 1868 addSuffix other_lib = other_lib ++ (expandTag tag) 1869 1870 expandTag t | null t = "" 1871 | otherwise = '_':t 1872 1873-- | Either the 'libraryDirs' or 'libraryDynDirs' as appropriate for the way. 1874libraryDirsForWay :: DynFlags -> PackageConfig -> [String] 1875libraryDirsForWay dflags 1876 | WayDyn `elem` ways dflags = libraryDynDirs 1877 | otherwise = libraryDirs 1878 1879-- | Find all the C-compiler options in these and the preload packages 1880getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String] 1881getPackageExtraCcOpts dflags pkgs = do 1882 ps <- getPreloadPackagesAnd dflags pkgs 1883 return (concatMap ccOptions ps) 1884 1885-- | Find all the package framework paths in these and the preload packages 1886getPackageFrameworkPath :: DynFlags -> [PreloadUnitId] -> IO [String] 1887getPackageFrameworkPath dflags pkgs = do 1888 ps <- getPreloadPackagesAnd dflags pkgs 1889 return (ordNub (filter notNull (concatMap frameworkDirs ps))) 1890 1891-- | Find all the package frameworks in these and the preload packages 1892getPackageFrameworks :: DynFlags -> [PreloadUnitId] -> IO [String] 1893getPackageFrameworks dflags pkgs = do 1894 ps <- getPreloadPackagesAnd dflags pkgs 1895 return (concatMap frameworks ps) 1896 1897-- ----------------------------------------------------------------------------- 1898-- Package Utils 1899 1900-- | Takes a 'ModuleName', and if the module is in any package returns 1901-- list of modules which take that name. 1902lookupModuleInAllPackages :: DynFlags 1903 -> ModuleName 1904 -> [(Module, PackageConfig)] 1905lookupModuleInAllPackages dflags m 1906 = case lookupModuleWithSuggestions dflags m Nothing of 1907 LookupFound a b -> [(a,b)] 1908 LookupMultiple rs -> map f rs 1909 where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags 1910 (moduleUnitId m))) 1911 _ -> [] 1912 1913-- | The result of performing a lookup 1914data LookupResult = 1915 -- | Found the module uniquely, nothing else to do 1916 LookupFound Module PackageConfig 1917 -- | Multiple modules with the same name in scope 1918 | LookupMultiple [(Module, ModuleOrigin)] 1919 -- | No modules found, but there were some hidden ones with 1920 -- an exact name match. First is due to package hidden, second 1921 -- is due to module being hidden 1922 | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] 1923 -- | No modules found, but there were some unusable ones with 1924 -- an exact name match 1925 | LookupUnusable [(Module, ModuleOrigin)] 1926 -- | Nothing found, here are some suggested different names 1927 | LookupNotFound [ModuleSuggestion] -- suggestions 1928 1929data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin 1930 | SuggestHidden ModuleName Module ModuleOrigin 1931 1932lookupModuleWithSuggestions :: DynFlags 1933 -> ModuleName 1934 -> Maybe FastString 1935 -> LookupResult 1936lookupModuleWithSuggestions dflags 1937 = lookupModuleWithSuggestions' dflags 1938 (moduleToPkgConfAll (pkgState dflags)) 1939 1940lookupPluginModuleWithSuggestions :: DynFlags 1941 -> ModuleName 1942 -> Maybe FastString 1943 -> LookupResult 1944lookupPluginModuleWithSuggestions dflags 1945 = lookupModuleWithSuggestions' dflags 1946 (pluginModuleToPkgConfAll (pkgState dflags)) 1947 1948lookupModuleWithSuggestions' :: DynFlags 1949 -> ModuleToPkgConfAll 1950 -> ModuleName 1951 -> Maybe FastString 1952 -> LookupResult 1953lookupModuleWithSuggestions' dflags mod_map m mb_pn 1954 = case Map.lookup m mod_map of 1955 Nothing -> LookupNotFound suggestions 1956 Just xs -> 1957 case foldl' classify ([],[],[], []) (Map.toList xs) of 1958 ([], [], [], []) -> LookupNotFound suggestions 1959 (_, _, _, [(m, _)]) -> LookupFound m (mod_pkg m) 1960 (_, _, _, exposed@(_:_)) -> LookupMultiple exposed 1961 ([], [], unusable@(_:_), []) -> LookupUnusable unusable 1962 (hidden_pkg, hidden_mod, _, []) -> 1963 LookupHidden hidden_pkg hidden_mod 1964 where 1965 classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) = 1966 let origin = filterOrigin mb_pn (mod_pkg m) origin0 1967 x = (m, origin) 1968 in case origin of 1969 ModHidden 1970 -> (hidden_pkg, x:hidden_mod, unusable, exposed) 1971 ModUnusable _ 1972 -> (hidden_pkg, hidden_mod, x:unusable, exposed) 1973 _ | originEmpty origin 1974 -> (hidden_pkg, hidden_mod, unusable, exposed) 1975 | originVisible origin 1976 -> (hidden_pkg, hidden_mod, unusable, x:exposed) 1977 | otherwise 1978 -> (x:hidden_pkg, hidden_mod, unusable, exposed) 1979 1980 pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) 1981 mod_pkg = pkg_lookup . moduleUnitId 1982 1983 -- Filters out origins which are not associated with the given package 1984 -- qualifier. No-op if there is no package qualifier. Test if this 1985 -- excluded all origins with 'originEmpty'. 1986 filterOrigin :: Maybe FastString 1987 -> PackageConfig 1988 -> ModuleOrigin 1989 -> ModuleOrigin 1990 filterOrigin Nothing _ o = o 1991 filterOrigin (Just pn) pkg o = 1992 case o of 1993 ModHidden -> if go pkg then ModHidden else mempty 1994 (ModUnusable _) -> if go pkg then o else mempty 1995 ModOrigin { fromOrigPackage = e, fromExposedReexport = res, 1996 fromHiddenReexport = rhs } 1997 -> ModOrigin { 1998 fromOrigPackage = if go pkg then e else Nothing 1999 , fromExposedReexport = filter go res 2000 , fromHiddenReexport = filter go rhs 2001 , fromPackageFlag = False -- always excluded 2002 } 2003 where go pkg = pn == fsPackageName pkg 2004 2005 suggestions 2006 | gopt Opt_HelpfulErrors dflags = 2007 fuzzyLookup (moduleNameString m) all_mods 2008 | otherwise = [] 2009 2010 all_mods :: [(String, ModuleSuggestion)] -- All modules 2011 all_mods = sortBy (comparing fst) $ 2012 [ (moduleNameString m, suggestion) 2013 | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags)) 2014 , suggestion <- map (getSuggestion m) (Map.toList e) 2015 ] 2016 getSuggestion name (mod, origin) = 2017 (if originVisible origin then SuggestVisible else SuggestHidden) 2018 name mod origin 2019 2020listVisibleModuleNames :: DynFlags -> [ModuleName] 2021listVisibleModuleNames dflags = 2022 map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags)))) 2023 where visible (_, ms) = any originVisible (Map.elems ms) 2024 2025-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of 2026-- 'PackageConfig's 2027getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig] 2028getPreloadPackagesAnd dflags pkgids0 = 2029 let 2030 pkgids = pkgids0 ++ 2031 -- An indefinite package will have insts to HOLE, 2032 -- which is not a real package. Don't look it up. 2033 -- Fixes #14525 2034 if isIndefinite dflags 2035 then [] 2036 else map (toInstalledUnitId . moduleUnitId . snd) 2037 (thisUnitIdInsts dflags) 2038 state = pkgState dflags 2039 pkg_map = pkgIdMap state 2040 preload = preloadPackages state 2041 pairs = zip pkgids (repeat Nothing) 2042 in do 2043 all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) 2044 return (map (getInstalledPackageDetails dflags) all_pkgs) 2045 2046-- Takes a list of packages, and returns the list with dependencies included, 2047-- in reverse dependency order (a package appears before those it depends on). 2048closeDeps :: DynFlags 2049 -> PackageConfigMap 2050 -> [(InstalledUnitId, Maybe InstalledUnitId)] 2051 -> IO [InstalledUnitId] 2052closeDeps dflags pkg_map ps 2053 = throwErr dflags (closeDepsErr dflags pkg_map ps) 2054 2055throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a 2056throwErr dflags m 2057 = case m of 2058 Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e)) 2059 Succeeded r -> return r 2060 2061closeDepsErr :: DynFlags 2062 -> PackageConfigMap 2063 -> [(InstalledUnitId,Maybe InstalledUnitId)] 2064 -> MaybeErr MsgDoc [InstalledUnitId] 2065closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps 2066 2067-- internal helper 2068add_package :: DynFlags 2069 -> PackageConfigMap 2070 -> [PreloadUnitId] 2071 -> (PreloadUnitId,Maybe PreloadUnitId) 2072 -> MaybeErr MsgDoc [PreloadUnitId] 2073add_package dflags pkg_db ps (p, mb_parent) 2074 | p `elem` ps = return ps -- Check if we've already added this package 2075 | otherwise = 2076 case lookupInstalledPackage' pkg_db p of 2077 Nothing -> Failed (missingPackageMsg p <> 2078 missingDependencyMsg mb_parent) 2079 Just pkg -> do 2080 -- Add the package's dependents also 2081 ps' <- foldM add_unit_key ps (depends pkg) 2082 return (p : ps') 2083 where 2084 add_unit_key ps key 2085 = add_package dflags pkg_db ps (key, Just p) 2086 2087missingPackageMsg :: Outputable pkgid => pkgid -> SDoc 2088missingPackageMsg p = text "unknown package:" <+> ppr p 2089 2090missingDependencyMsg :: Maybe InstalledUnitId -> SDoc 2091missingDependencyMsg Nothing = Outputable.empty 2092missingDependencyMsg (Just parent) 2093 = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent)) 2094 2095-- ----------------------------------------------------------------------------- 2096 2097componentIdString :: DynFlags -> ComponentId -> Maybe String 2098componentIdString dflags cid = do 2099 conf <- lookupInstalledPackage dflags (componentIdToInstalledUnitId cid) 2100 return $ 2101 case sourceLibName conf of 2102 Nothing -> sourcePackageIdString conf 2103 Just (PackageName libname) -> 2104 packageNameString conf 2105 ++ "-" ++ showVersion (packageVersion conf) 2106 ++ ":" ++ unpackFS libname 2107 2108displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String 2109displayInstalledUnitId dflags uid = 2110 fmap sourcePackageIdString (lookupInstalledPackage dflags uid) 2111 2112-- | Will the 'Name' come from a dynamically linked library? 2113isDllName :: DynFlags -> Module -> Name -> Bool 2114-- Despite the "dll", I think this function just means that 2115-- the symbol comes from another dynamically-linked package, 2116-- and applies on all platforms, not just Windows 2117isDllName dflags this_mod name 2118 | not (gopt Opt_ExternalDynamicRefs dflags) = False 2119 | Just mod <- nameModule_maybe name 2120 -- Issue #8696 - when GHC is dynamically linked, it will attempt 2121 -- to load the dynamic dependencies of object files at compile 2122 -- time for things like QuasiQuotes or 2123 -- TemplateHaskell. Unfortunately, this interacts badly with 2124 -- intra-package linking, because we don't generate indirect 2125 -- (dynamic) symbols for intra-package calls. This means that if a 2126 -- module with an intra-package call is loaded without its 2127 -- dependencies, then GHC fails to link. This is the cause of # 2128 -- 2129 -- In the mean time, always force dynamic indirections to be 2130 -- generated: when the module name isn't the module being 2131 -- compiled, references are dynamic. 2132 = case platformOS $ targetPlatform dflags of 2133 -- On Windows the hack for #8696 makes it unlinkable. 2134 -- As the entire setup of the code from Cmm down to the RTS expects 2135 -- the use of trampolines for the imported functions only when 2136 -- doing intra-package linking, e.g. refering to a symbol defined in the same 2137 -- package should not use a trampoline. 2138 -- I much rather have dynamic TH not supported than the entire Dynamic linking 2139 -- not due to a hack. 2140 -- Also not sure this would break on Windows anyway. 2141 OSMinGW32 -> moduleUnitId mod /= moduleUnitId this_mod 2142 2143 -- For the other platforms, still perform the hack 2144 _ -> mod /= this_mod 2145 2146 | otherwise = False -- no, it is not even an external name 2147 2148-- ----------------------------------------------------------------------------- 2149-- Displaying packages 2150 2151-- | Show (very verbose) package info 2152pprPackages :: DynFlags -> SDoc 2153pprPackages = pprPackagesWith pprPackageConfig 2154 2155pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc 2156pprPackagesWith pprIPI dflags = 2157 vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags))) 2158 2159-- | Show simplified package info. 2160-- 2161-- The idea is to only print package id, and any information that might 2162-- be different from the package databases (exposure, trust) 2163pprPackagesSimple :: DynFlags -> SDoc 2164pprPackagesSimple = pprPackagesWith pprIPI 2165 where pprIPI ipi = let i = installedUnitIdFS (unitId ipi) 2166 e = if exposed ipi then text "E" else text " " 2167 t = if trusted ipi then text "T" else text " " 2168 in e <> t <> text " " <> ftext i 2169 2170-- | Show the mapping of modules to where they come from. 2171pprModuleMap :: ModuleToPkgConfAll -> SDoc 2172pprModuleMap mod_map = 2173 vcat (map pprLine (Map.toList mod_map)) 2174 where 2175 pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) 2176 pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc 2177 pprEntry m (m',o) 2178 | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o) 2179 | otherwise = ppr m' <+> parens (ppr o) 2180 2181fsPackageName :: PackageConfig -> FastString 2182fsPackageName = mkFastString . packageNameString 2183 2184-- | Given a fully instantiated 'UnitId', improve it into a 2185-- 'InstalledUnitId' if we can find it in the package database. 2186improveUnitId :: PackageConfigMap -> UnitId -> UnitId 2187improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit 2188improveUnitId pkg_map uid = 2189 -- Do NOT lookup indefinite ones, they won't be useful! 2190 case lookupPackage' False pkg_map uid of 2191 Nothing -> uid 2192 Just pkg -> 2193 -- Do NOT improve if the indefinite unit id is not 2194 -- part of the closure unique set. See 2195 -- Note [UnitId to InstalledUnitId improvement] 2196 if installedPackageConfigId pkg `elementOfUniqSet` preloadClosure pkg_map 2197 then packageConfigId pkg 2198 else uid 2199 2200-- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used 2201-- in the @hs-boot@ loop-breaker. 2202getPackageConfigMap :: DynFlags -> PackageConfigMap 2203getPackageConfigMap = pkgIdMap . pkgState 2204 2205-- ----------------------------------------------------------------------------- 2206-- | Find the package environment (if one exists) 2207-- 2208-- We interpret the package environment as a set of package flags; to be 2209-- specific, if we find a package environment file like 2210-- 2211-- > clear-package-db 2212-- > global-package-db 2213-- > package-db blah/package.conf.d 2214-- > package-id id1 2215-- > package-id id2 2216-- 2217-- we interpret this as 2218-- 2219-- > [ -hide-all-packages 2220-- > , -clear-package-db 2221-- > , -global-package-db 2222-- > , -package-db blah/package.conf.d 2223-- > , -package-id id1 2224-- > , -package-id id2 2225-- > ] 2226-- 2227-- There's also an older syntax alias for package-id, which is just an 2228-- unadorned package id 2229-- 2230-- > id1 2231-- > id2 2232-- 2233interpretPackageEnv :: DynFlags -> IO DynFlags 2234interpretPackageEnv dflags = do 2235 mPkgEnv <- runMaybeT $ msum $ [ 2236 getCmdLineArg >>= \env -> msum [ 2237 probeNullEnv env 2238 , probeEnvFile env 2239 , probeEnvName env 2240 , cmdLineError env 2241 ] 2242 , getEnvVar >>= \env -> msum [ 2243 probeNullEnv env 2244 , probeEnvFile env 2245 , probeEnvName env 2246 , envError env 2247 ] 2248 , notIfHideAllPackages >> msum [ 2249 findLocalEnvFile >>= probeEnvFile 2250 , probeEnvName defaultEnvName 2251 ] 2252 ] 2253 case mPkgEnv of 2254 Nothing -> 2255 -- No environment found. Leave DynFlags unchanged. 2256 return dflags 2257 Just "-" -> do 2258 -- Explicitly disabled environment file. Leave DynFlags unchanged. 2259 return dflags 2260 Just envfile -> do 2261 content <- readFile envfile 2262 compilationProgressMsg dflags ("Loaded package environment from " ++ envfile) 2263 let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags 2264 2265 return dflags' 2266 where 2267 -- Loading environments (by name or by location) 2268 2269 namedEnvPath :: String -> MaybeT IO FilePath 2270 namedEnvPath name = do 2271 appdir <- versionedAppDir dflags 2272 return $ appdir </> "environments" </> name 2273 2274 probeEnvName :: String -> MaybeT IO FilePath 2275 probeEnvName name = probeEnvFile =<< namedEnvPath name 2276 2277 probeEnvFile :: FilePath -> MaybeT IO FilePath 2278 probeEnvFile path = do 2279 guard =<< liftMaybeT (doesFileExist path) 2280 return path 2281 2282 probeNullEnv :: FilePath -> MaybeT IO FilePath 2283 probeNullEnv "-" = return "-" 2284 probeNullEnv _ = mzero 2285 2286 -- Various ways to define which environment to use 2287 2288 getCmdLineArg :: MaybeT IO String 2289 getCmdLineArg = MaybeT $ return $ packageEnv dflags 2290 2291 getEnvVar :: MaybeT IO String 2292 getEnvVar = do 2293 mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT" 2294 case mvar of 2295 Right var -> return var 2296 Left err -> if isDoesNotExistError err then mzero 2297 else liftMaybeT $ throwIO err 2298 2299 notIfHideAllPackages :: MaybeT IO () 2300 notIfHideAllPackages = 2301 guard (not (gopt Opt_HideAllPackages dflags)) 2302 2303 defaultEnvName :: String 2304 defaultEnvName = "default" 2305 2306 -- e.g. .ghc.environment.x86_64-linux-7.6.3 2307 localEnvFileName :: FilePath 2308 localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags 2309 2310 -- Search for an env file, starting in the current dir and looking upwards. 2311 -- Fail if we get to the users home dir or the filesystem root. That is, 2312 -- we don't look for an env file in the user's home dir. The user-wide 2313 -- env lives in ghc's versionedAppDir/environments/default 2314 findLocalEnvFile :: MaybeT IO FilePath 2315 findLocalEnvFile = do 2316 curdir <- liftMaybeT getCurrentDirectory 2317 homedir <- tryMaybeT getHomeDirectory 2318 let probe dir | isDrive dir || dir == homedir 2319 = mzero 2320 probe dir = do 2321 let file = dir </> localEnvFileName 2322 exists <- liftMaybeT (doesFileExist file) 2323 if exists 2324 then return file 2325 else probe (takeDirectory dir) 2326 probe curdir 2327 2328 -- Error reporting 2329 2330 cmdLineError :: String -> MaybeT IO a 2331 cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ 2332 "Package environment " ++ show env ++ " not found" 2333 2334 envError :: String -> MaybeT IO a 2335 envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ 2336 "Package environment " 2337 ++ show env 2338 ++ " (specified in GHC_ENVIRONMENT) not found" 2339