Packages.lhs 59.6 KB
 simonpj committed Jun 15, 2001 1 %  batterseapower committed Jul 31, 2008 2 % (c) The University of Glasgow, 2006  simonpj committed Jun 15, 2001 3 4 % \begin{code}  Edward Z. Yang committed Aug 05, 2014 5 {-# LANGUAGE CPP, ScopedTypeVariables #-}  Herbert Valerio Riedel committed May 15, 2014 6   batterseapower committed Jul 31, 2008 7 -- | Package manipulation  simonpj committed Sep 13, 2002 8 module Packages (  Ian Lynagh committed Apr 01, 2012 9 10 11  module PackageConfig, -- * Reading the package config, and processing cmdline args  Edward Z. Yang committed Aug 05, 2014 12  PackageState(preloadPackages),  Ian Lynagh committed Apr 01, 2012 13  initPackages,  Edward Z. Yang committed Aug 05, 2014 14 15 16 17 18  -- * Querying the package config lookupPackage, resolveInstalledPackageId, searchPackageId,  Ian Lynagh committed Apr 01, 2012 19  getPackageDetails,  Edward Z. Yang committed Aug 05, 2014 20  listVisibleModuleNames,  Edward Z. Yang committed Aug 05, 2014 21 22 23  lookupModuleInAllPackages, lookupModuleWithSuggestions, LookupResult(..),  Edward Z. Yang committed Aug 05, 2014 24 25  ModuleSuggestion(..), ModuleOrigin(..),  Ian Lynagh committed Apr 01, 2012 26 27 28 29 30 31 32 33 34  -- * Inspecting the set of packages in scope getPackageIncludePath, getPackageLibraryPath, getPackageLinkOpts, getPackageExtraCcOpts, getPackageFrameworkPath, getPackageFrameworks, getPreloadPackagesAnd,  simonmar committed Nov 26, 2004 35   Simon Marlow committed Jul 24, 2008 36  collectIncludeDirs, collectLibraryPaths, collectLinkOpts,  Simon Marlow committed Sep 01, 2008 37  packageHsLibs,  Edward Z. Yang committed Jul 25, 2014 38  ModuleExport(..),  Simon Marlow committed Jul 24, 2008 39   Ian Lynagh committed Apr 01, 2012 40  -- * Utils  Edward Z. Yang committed Aug 05, 2014 41  packageKeyPackageIdString,  Edward Z. Yang committed Aug 05, 2014 42  pprFlag,  Duncan Coutts committed Aug 29, 2014 43 44  pprPackages, pprPackagesSimple,  Edward Z. Yang committed Aug 05, 2014 45  pprModuleMap,  Ian Lynagh committed Apr 01, 2012 46  isDllName  simonpj committed Sep 13, 2002 47  )  simonpj committed Jun 15, 2001 48 49 50 where #include "HsVersions.h"  simonmar committed Sep 09, 2002 51   Duncan Coutts committed Aug 29, 2014 52 import GHC.PackageDb  Ian Lynagh committed Apr 01, 2012 53 import PackageConfig  Ian Lynagh committed Apr 22, 2011 54 import DynFlags  Ian Lynagh committed Apr 01, 2012 55 56 import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe )  simonmar committed Nov 26, 2004 57 import UniqFM  simonmar committed Jun 21, 2005 58 import Module  simonmar committed Nov 26, 2004 59 60 61 import Util import Panic import Outputable  Simon Marlow committed Aug 20, 2009 62 import Maybes  simonmar committed Nov 26, 2004 63   simonmar committed Nov 04, 2005 64 import System.Environment ( getEnv )  simonpj committed Sep 13, 2002 65 import FastString  Duncan Coutts committed Aug 29, 2014 66 import ErrUtils ( debugTraceMsg, MsgDoc )  Ian Lynagh committed Jul 31, 2008 67 import Exception  Edward Z. Yang committed Aug 05, 2014 68 import Unique  simonmar committed Nov 26, 2004 69   Simon Marlow committed Oct 11, 2006 70 import System.Directory  Duncan Coutts committed May 25, 2011 71 72 import System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix  Simon Marlow committed Oct 11, 2006 73 import Control.Monad  Simon Marlow committed Aug 20, 2009 74 import Data.List as List  Ian Lynagh committed Sep 14, 2010 75 import Data.Map (Map)  Herbert Valerio Riedel committed Sep 21, 2014 76 #if __GLASGOW_HASKELL__ < 709  Edward Z. Yang committed Aug 05, 2014 77 import Data.Monoid hiding ((<>))  Herbert Valerio Riedel committed Sep 21, 2014 78 #endif  Ian Lynagh committed Sep 14, 2010 79 80 import qualified Data.Map as Map import qualified FiniteMap as Map  Simon Marlow committed May 19, 2010 81 import qualified Data.Set as Set  Simon Marlow committed Oct 11, 2006 82   simonmar committed Nov 26, 2004 83 84 85 -- --------------------------------------------------------------------------- -- The Package state  ian@well-typed.com committed Oct 16, 2012 86 -- | Package state is all stored in 'DynFlags', including the details of  simonmar committed Nov 26, 2004 87 88 89 -- all packages, which packages are exposed, and which modules they -- provide. --  batterseapower committed Jul 31, 2008 90 -- The package state is computed by 'initPackages', and kept in DynFlags.  Edward Z. Yang committed Aug 04, 2014 91 -- It is influenced by various package flags:  batterseapower committed Jul 31, 2008 92 --  Edward Z. Yang committed Aug 04, 2014 93 94 95 -- * @-package @ and @-package-id @ cause @@ to become exposed. -- If @-hide-all-packages@ was not specified, these commands also cause -- all other packages with the same name to become hidden.  Ian Lynagh committed Apr 01, 2012 96 --  batterseapower committed Jul 31, 2008 97 -- * @-hide-package @ causes @@ to become hidden.  Ian Lynagh committed Apr 01, 2012 98 --  Edward Z. Yang committed Aug 04, 2014 99 100 101 102 -- * (there are a few more flags, check below for their semantics) -- -- The package state has the following properties. --  Ian Lynagh committed Apr 01, 2012 103 -- * Let @exposedPackages@ be the set of packages thus exposed.  batterseapower committed Jul 31, 2008 104 -- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of  simonmar committed Nov 26, 2004 105 106 -- their dependencies. --  Simon Marlow committed Sep 19, 2006 107 -- * When searching for a module from an preload import declaration,  batterseapower committed Jul 31, 2008 108 -- only the exposed modules in @exposedPackages@ are valid.  simonmar committed Nov 26, 2004 109 110 -- -- * When searching for a module from an implicit import, all modules  batterseapower committed Jul 31, 2008 111 -- from @depExposedPackages@ are valid.  simonmar committed Nov 26, 2004 112 --  batterseapower committed Jul 31, 2008 113 -- * When linking in a compilation manager mode, we link in packages the  simonmar committed Nov 26, 2004 114 115 -- program depends on (the compiler knows this list by the -- time it gets to the link step). Also, we link in all packages  batterseapower committed Jul 31, 2008 116 -- which were mentioned with preload @-package@ flags on the command-line,  Ian Lynagh committed Aug 07, 2008 117 -- or are a transitive dependency of same, or are \"base\"\/\"rts\".  batterseapower committed Jul 31, 2008 118 -- The reason for this is that we might need packages which don't  simonmar committed Nov 26, 2004 119 120 121 122 123 -- contain any Haskell modules, and therefore won't be discovered -- by the normal mechanism of dependency tracking. -- Notes on DLLs -- ~~~~~~~~~~~~~  Ian Lynagh committed Apr 01, 2012 124 125 126 127 -- When compiling module A, which imports module B, we need to -- know whether B will be in the same DLL as A. -- If it's in the same DLL, we refer to B_f_closure -- If it isn't, we refer to _imp__B_f_closure  simonmar committed Nov 26, 2004 128 129 130 -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag.  Edward Z. Yang committed Aug 05, 2014 131 -- | Given a module name, there may be multiple ways it came into scope,  Edward Z. Yang committed Aug 05, 2014 132 133 134 -- possibly simultaneously. This data type tracks all the possible ways -- it could have come into scope. Warning: don't use the record functions, -- they're partial!  Edward Z. Yang committed Aug 05, 2014 135 data ModuleOrigin =  Edward Z. Yang committed Aug 05, 2014 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200  -- | Module is hidden, and thus never will be available for import. -- (But maybe the user didn't realize), so we'll still keep track -- of these modules.) ModHidden -- | Module is public, and could have come from some places. | ModOrigin { -- | @Just False@ means that this module is in -- someone's @exported-modules@ list, but that package is hidden; -- @Just True@ means that it is available; @Nothing@ means neither -- applies. fromOrigPackage :: Maybe Bool -- | Is the module available from a reexport of an exposed package? -- There could be multiple. , fromExposedReexport :: [PackageConfig] -- | Is the module available from a reexport of a hidden package? , fromHiddenReexport :: [PackageConfig] -- | Did the module export come from a package flag? (ToDo: track -- more information. , fromPackageFlag :: Bool } instance Outputable ModuleOrigin where ppr ModHidden = text "hidden module" ppr (ModOrigin e res rhs f) = sep (punctuate comma ( (case e of Nothing -> [] Just False -> [text "hidden package"] Just True -> [text "exposed package"]) ++ (if null res then [] else [text "reexport by" <+> sep (map (ppr . packageConfigId) res)]) ++ (if null rhs then [] else [text "hidden reexport by" <+> sep (map (ppr . packageConfigId) res)]) ++ (if f then [text "package flag"] else []) )) -- | Smart constructor for a module which is in @exposed-modules@. Takes -- as an argument whether or not the defining package is exposed. fromExposedModules :: Bool -> ModuleOrigin fromExposedModules e = ModOrigin (Just e) [] [] False -- | Smart constructor for a module which is in @reexported-modules@. Takes -- as an argument whether or not the reexporting package is expsed, and -- also its 'PackageConfig'. fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False -- | Smart constructor for a module which was bound by a package flag. fromFlag :: ModuleOrigin fromFlag = ModOrigin Nothing [] [] True instance Monoid ModuleOrigin where mempty = ModOrigin Nothing [] [] False mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') = ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') where g (Just b) (Just b') | b == b' = Just b | otherwise = panic "ModOrigin: package both exposed/hidden" g Nothing x = x g x Nothing = x mappend _ _ = panic "ModOrigin: hidden module redefined"  Edward Z. Yang committed Aug 05, 2014 201 202 203  -- | Is the name from the import actually visible? (i.e. does it cause -- ambiguity, or is it only relevant when we're making suggestions?)  Edward Z. Yang committed Aug 05, 2014 204 205 206 207 208 209 210 211 212 originVisible :: ModuleOrigin -> Bool originVisible ModHidden = False originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f -- | Are there actually no providers for this module? This will never occur -- except when we're filtering based on package imports. originEmpty :: ModuleOrigin -> Bool originEmpty (ModOrigin Nothing [] [] False) = True originEmpty _ = False  Edward Z. Yang committed Aug 05, 2014 213 214 215 216 217 218  -- | When we do a plain lookup (e.g. for an import), initially, all we want -- to know is if we can find it or not (and if we do and it's a reexport, -- what the real name is). If the find fails, we'll want to investigate more -- to give a good error message. data SimpleModuleConf =  Edward Z. Yang committed Aug 05, 2014 219  SModConf Module PackageConfig ModuleOrigin  Edward Z. Yang committed Aug 05, 2014 220 221  | SModConfAmbiguous  Edward Z. Yang committed Aug 05, 2014 222 -- | 'UniqFM' map from 'ModuleName'  Edward Z. Yang committed Aug 05, 2014 223 224 type ModuleNameMap = UniqFM  Edward Z. Yang committed Aug 05, 2014 225 -- | 'UniqFM' map from 'PackageKey'  Edward Z. Yang committed Aug 05, 2014 226 227 type PackageKeyMap = UniqFM  Edward Z. Yang committed Aug 05, 2014 228 -- | 'UniqFM' map from 'PackageKey' to 'PackageConfig'  Edward Z. Yang committed Aug 05, 2014 229 type PackageConfigMap = PackageKeyMap PackageConfig  Edward Z. Yang committed Aug 05, 2014 230 231 232 233 234 235 236 237 238 239 240 241 242  -- | 'UniqFM' map from 'PackageKey' to (1) whether or not all modules which -- are exposed should be dumped into scope, (2) any custom renamings that -- should also be apply, and (3) what package name is associated with the -- key, if it might be hidden type VisibilityMap = PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString) -- | Map from 'ModuleName' to 'Module' to all the origins of the bindings -- in scope. The 'PackageConf' is not cached, mostly for convenience reasons -- (since this is the slow path, we'll just look it up again). type ModuleToPkgConfAll = Map ModuleName (Map Module ModuleOrigin)  Edward Z. Yang committed Jul 25, 2014 243   simonmar committed Nov 26, 2004 244 data PackageState = PackageState {  Edward Z. Yang committed Aug 05, 2014 245 246 247 248 249 250 251 252 253  -- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted -- so that only valid packages are here. Currently, we also flip the -- exposed/trusted bits based on package flags; however, the hope is to -- stop doing that. pkgIdMap :: PackageConfigMap, -- | The packages we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a package -- is always mentioned before the packages it depends on.  Edward Z. Yang committed Jul 21, 2014 254  preloadPackages :: [PackageKey],  Edward Z. Yang committed Aug 05, 2014 255 256 257 258 259 260 261 262  -- | This is a simplified map from 'ModuleName' to original 'Module' and -- package configuration providing it. moduleToPkgConf :: ModuleNameMap SimpleModuleConf, -- | This is a full map from 'ModuleName' to all modules which may possibly -- be providing it. These providers may be hidden (but we'll still want -- to report them in error messages), or it may be an ambiguous import.  Edward Z. Yang committed Jul 25, 2014 263  moduleToPkgConfAll :: ModuleToPkgConfAll,  Simon Marlow committed Aug 20, 2009 264   Edward Z. Yang committed Aug 05, 2014 265 266 267  -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC -- internally deals in package keys but the database may refer to installed -- package IDs.  Simon Marlow committed Sep 08, 2009 268  installedPackageIdMap :: InstalledPackageIdMap  simonmar committed Nov 26, 2004 269 270  }  Edward Z. Yang committed Jul 21, 2014 271 type InstalledPackageIdMap = Map InstalledPackageId PackageKey  Ian Lynagh committed Sep 14, 2010 272 type InstalledPackageIndex = Map InstalledPackageId PackageConfig  Simon Marlow committed Sep 17, 2009 273   Edward Z. Yang committed Aug 05, 2014 274 -- | Empty package configuration map  simonmar committed Nov 26, 2004 275 276 277 emptyPackageConfigMap :: PackageConfigMap emptyPackageConfigMap = emptyUFM  Edward Z. Yang committed Aug 05, 2014 278 279 280 281 282 283 284 285 -- | Find the package we know about with the given key (e.g. @foo_HASH@), if any lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags)) lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig lookupPackage' = lookupUFM -- | Search for packages with a given package ID (e.g. \"foo-0.1\")  Duncan Coutts committed Aug 29, 2014 286 searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]  Edward Z. Yang committed Aug 05, 2014 287 288 searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) (listPackageConfigMap dflags)  simonmar committed Nov 26, 2004 289   Edward Z. Yang committed Aug 05, 2014 290 -- | Extends the package configuration map with a list of package configs.  simonmar committed Nov 26, 2004 291 292 extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap  Ian Lynagh committed Apr 01, 2012 293 extendPackageConfigMap pkg_map new_pkgs  simonmar committed Nov 26, 2004 294 295 296  = foldl add pkg_map new_pkgs where add pkg_map p = addToUFM pkg_map (packageConfigId p) p  batterseapower committed Jul 31, 2008 297 298 -- | Looks up the package with the given id in the package state, panicing if it is -- not found  Edward Z. Yang committed Aug 05, 2014 299 300 301 302 303 304 305 306 307 getPackageDetails :: DynFlags -> PackageKey -> PackageConfig getPackageDetails dflags pid = expectJust "getPackageDetails" (lookupPackage dflags pid) -- | Get a list of entries from the package database. NB: be careful with -- this function, it may not do what you expect it to. listPackageConfigMap :: DynFlags -> [PackageConfig] listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags))  Edward Z. Yang committed Aug 05, 2014 308 -- | Looks up a 'PackageKey' given an 'InstalledPackageId'  Edward Z. Yang committed Aug 05, 2014 309 310 311 312 resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey resolveInstalledPackageId dflags ipid = expectJust "resolveInstalledPackageId" (Map.lookup ipid (installedPackageIdMap (pkgState dflags)))  simonmar committed Nov 26, 2004 313 314  -- ----------------------------------------------------------------------------  pcapriotti committed May 15, 2012 315 -- Loading the package db files and building up the package state  simonmar committed Nov 26, 2004 316   Simon Marlow committed Sep 19, 2006 317 -- | Call this after 'DynFlags.parseDynFlags'. It reads the package  pcapriotti committed May 15, 2012 318 -- database files, and sets up various internal tables of package  simonmar committed Apr 08, 2005 319 320 -- information, according to the package-related flags on the -- command-line (@-package@, @-hide-package@ etc.)  Simon Marlow committed Sep 19, 2006 321 322 323 -- -- Returns a list of packages to link in if we're doing dynamic linking. -- This list contains the packages that the user explicitly mentioned with  batterseapower committed Jul 31, 2008 324 -- @-package@ flags.  Simon Marlow committed Sep 19, 2006 325 326 327 -- -- 'initPackages' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the  batterseapower committed Jul 31, 2008 328 -- 'pkgState' in 'DynFlags' and return a list of packages to  Simon Marlow committed Sep 19, 2006 329 -- link in.  Edward Z. Yang committed Jul 21, 2014 330 initPackages :: DynFlags -> IO (DynFlags, [PackageKey])  Ian Lynagh committed Apr 01, 2012 331 initPackages dflags = do  Simon Marlow committed Sep 19, 2006 332 333  pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags  dterei committed Jun 17, 2011 334  Just db -> return $setBatchPackageFlags dflags db  Ian Lynagh committed Apr 01, 2012 335  (pkg_state, preload, this_pkg)  Simon Marlow committed Sep 19, 2006 336  <- mkPackageState dflags pkg_db [] (thisPackage dflags)  Simon Marlow committed Oct 06, 2006 337  return (dflags{ pkgDatabase = Just pkg_db,  Ian Lynagh committed Apr 01, 2012 338  pkgState = pkg_state,  Simon Marlow committed Sep 19, 2006 339 340  thisPackage = this_pkg }, preload)  simonmar committed Dec 18, 2002 341 342  -- -----------------------------------------------------------------------------  simonmar committed Nov 26, 2004 343 344 -- Reading the package database(s)  Simon Marlow committed Sep 08, 2009 345 readPackageConfigs :: DynFlags -> IO [PackageConfig]  simonmar committed Nov 26, 2004 346 readPackageConfigs dflags = do  pcapriotti committed May 15, 2012 347  let system_conf_refs = [UserPkgConf, GlobalPkgConf]  pcapriotti committed May 15, 2012 348 349 350 351 352 353 354 355 356 357 358  e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH") let base_conf_refs = case e_pkg_path of Left _ -> system_conf_refs Right path | null (last cs) -> map PkgConfFile (init cs) ++ system_conf_refs | otherwise -> map PkgConfFile cs where cs = parseSearchPath path -- if the path ends in a separator (eg. "/foo/bar:")  pcapriotti committed May 15, 2012 359  -- then we tack on the system paths.  pcapriotti committed May 15, 2012 360   pcapriotti committed May 15, 2012 361  let conf_refs = reverse (extraPkgConfs dflags base_conf_refs)  pcapriotti committed May 15, 2012 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377  -- later packages shadow earlier ones. extraPkgConfs -- is in the opposite order to the flags on the -- command line. confs <- liftM catMaybes$ mapM (resolvePackageConfig dflags) conf_refs liftM concat $mapM (readPackageConfig dflags) confs resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath) resolvePackageConfig dflags GlobalPkgConf = return$ Just (systemPackageConfig dflags) resolvePackageConfig _ UserPkgConf = handleIO (\_ -> return Nothing) $do appdir <- getAppUserDataDirectory "ghc" let dir = appdir (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) pkgconf = dir "package.conf.d" exist <- doesDirectoryExist pkgconf return$ if exist then Just pkgconf else Nothing resolvePackageConfig _ (PkgConfFile name) = return $Just name  simonmar committed Nov 26, 2004 378   Simon Marlow committed Sep 08, 2009 379 380 readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig] readPackageConfig dflags conf_file = do  Simon Marlow committed Sep 10, 2009 381 382  isdir <- doesDirectoryExist conf_file  Ian Lynagh committed Apr 01, 2012 383  proto_pkg_configs <-  Simon Marlow committed Sep 10, 2009 384 385 386  if isdir then do let filename = conf_file "package.cache" debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)  Duncan Coutts committed Aug 29, 2014 387  readPackageDbForGhc filename  Ian Lynagh committed Apr 01, 2012 388  else do  Simon Marlow committed Sep 10, 2009 389  isfile <- doesFileExist conf_file  Duncan Coutts committed Aug 29, 2014 390 391  if isfile then throwGhcExceptionIO$ InstallationError $ Duncan Coutts committed Aug 29, 2014 392 393 394 395  "ghc no longer supports single-file style package " ++ "databases (" ++ conf_file ++ ") use 'ghc-pkg init' to create the database with " ++ "the correct format."  Duncan Coutts committed Aug 29, 2014 396 397  else throwGhcExceptionIO$ InstallationError $"can't find a package database at " ++ conf_file  Simon Marlow committed Sep 10, 2009 398   Simon Marlow committed Sep 08, 2009 399 400  let top_dir = topDir dflags  Duncan Coutts committed May 25, 2011 401 402  pkgroot = takeDirectory conf_file pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs  dterei committed Jun 17, 2011 403  pkg_configs2 = setBatchPackageFlags dflags pkg_configs1  Simon Marlow committed Sep 08, 2009 404 405  -- return pkg_configs2  simonmar committed Nov 26, 2004 406   dterei committed Jun 17, 2011 407 setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]  Edward Z. Yang committed Aug 05, 2014 408 setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs  simonmar committed Apr 07, 2005 409  where  dterei committed Jun 17, 2011 410  maybeDistrustAll pkgs'  ian@well-typed.com committed Oct 16, 2012 411  | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'  dterei committed Jun 17, 2011 412 413  | otherwise = pkgs'  dterei committed Feb 08, 2012 414  distrust pkg = pkg{ trusted = False }  simonmar committed Nov 26, 2004 415   Ian Lynagh committed Jun 10, 2011 416 -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs  Duncan Coutts committed May 25, 2011 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig -- Perform path/URL variable substitution as per the Cabal${pkgroot} spec -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) -- Paths/URLs can be relative to ${pkgroot} or${pkgrooturl}. -- The "pkgroot" is the directory containing the package database. -- -- Also perform a similar substitution for the older GHC-specific -- "$topdir" variable. The "topdir" is the location of the ghc -- installation (obtained from the -B option). mungePackagePaths top_dir pkgroot pkg = pkg { importDirs = munge_paths (importDirs pkg), includeDirs = munge_paths (includeDirs pkg), libraryDirs = munge_paths (libraryDirs pkg), frameworkDirs = munge_paths (frameworkDirs pkg), haddockInterfaces = munge_paths (haddockInterfaces pkg), haddockHTMLs = munge_urls (haddockHTMLs pkg) }  Ian Lynagh committed Apr 01, 2012 435  where  Duncan Coutts committed May 25, 2011 436 437 438 439  munge_paths = map munge_path munge_urls = map munge_url munge_path p  Ian Lynagh committed Jun 10, 2011 440 441 442  | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' | otherwise = p  Duncan Coutts committed May 25, 2011 443 444  munge_url p  Ian Lynagh committed Jun 10, 2011 445 446 447  | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' | otherwise = p  Duncan Coutts committed May 25, 2011 448 449 450  toUrlPath r p = "file:///" -- URLs always use posix style '/' separators:  Ian Lynagh committed Jun 10, 2011 451 452 453 454 455 456 457 458 459 460 461 462 463  ++ FilePath.Posix.joinPath (r : -- We need to drop a leading "/" or "\\" -- if there is one: dropWhile (all isPathSeparator) (FilePath.splitDirectories p)) -- We could drop the separator here, and then use above. However, -- by leaving it in and using ++ we keep the same path separator -- rather than letting FilePath change it to use \ as the separator stripVarPrefix var path = case stripPrefix var path of Just [] -> Just [] Just cs@(c : _) | isPathSeparator c -> Just cs _ -> Nothing  Ian Lynagh committed Nov 03, 2007 464   simonpj committed Jun 15, 2001 465   simonmar committed Dec 18, 2002 466 -- -----------------------------------------------------------------------------  Simon Marlow committed Sep 19, 2006 467 468 469 -- Modify our copy of the package database based on a package flag -- (-package, -hide-package, -ignore-package).  Edward Z. Yang committed Aug 05, 2014 470 471 472 473 474 475 476 -- | A horrible hack, the problem is the package key we'll turn -- up here is going to get edited when we select the wired in -- packages, so preemptively pick up the right one. Also, this elem -- test is slow. The alternative is to change wired in packages first, but -- then we are no longer able to match against package keys e.g. from when -- a user passes in a package flag. calcKey :: PackageConfig -> PackageKey  Duncan Coutts committed Aug 29, 2014 477 calcKey p | pk <- packageNameString p  Edward Z. Yang committed Aug 05, 2014 478 479 480 481  , pk elem wired_in_pkgids = stringToPackageKey pk | otherwise = packageConfigId p  Simon Marlow committed Sep 19, 2006 482 applyPackageFlag  Ian Lynagh committed Jun 12, 2012 483 484  :: DynFlags -> UnusablePackages  Edward Z. Yang committed Aug 05, 2014 485  -> ([PackageConfig], VisibilityMap) -- Initial database  Simon Marlow committed Sep 19, 2006 486  -> PackageFlag -- flag to apply  Edward Z. Yang committed Aug 05, 2014 487  -> IO ([PackageConfig], VisibilityMap) -- new database  Simon Marlow committed Sep 19, 2006 488   Edward Z. Yang committed Aug 05, 2014 489 490 491 492 493 494 -- ToDo: Unfortunately, we still have to plumb the package config through, -- because Safe Haskell trust is still implemented by modifying the database. -- Eventually, track that separately and then axe @[PackageConfig]@ from -- this fold entirely applyPackageFlag dflags unusable (pkgs, vm) flag =  Simon Marlow committed Sep 19, 2006 495  case flag of  Edward Z. Yang committed Aug 05, 2014 496  ExposePackage arg m_rns ->  Edward Z. Yang committed Aug 05, 2014 497  case selectPackages (matching arg) pkgs unusable of  Edward Z. Yang committed Aug 05, 2014 498  Left ps -> packageFlagErr dflags flag ps  Edward Z. Yang committed Aug 05, 2014 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518  Right (p:_,_) -> return (pkgs, vm') where n = fsPackageName p vm' = addToUFM_C edit vm_cleared (calcKey p) (case m_rns of Nothing -> (True, [], n) Just rns' -> (False, map convRn rns', n)) edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n) convRn (a,b) = (mkModuleName a, mkModuleName b) -- ToDo: ATM, -hide-all-packages implicitly triggers change in -- behavior, maybe eventually make it toggleable with a separate -- flag vm_cleared | gopt Opt_HideAllPackages dflags = vm -- NB: -package foo-0.1 (Foo as Foo1) does NOT hide -- other versions of foo. Presence of renaming means -- user probably wanted both. | Just _ <- m_rns = vm | otherwise = filterUFM_Directly (\k (_,_,n') -> k == getUnique (calcKey p) || n /= n') vm  Edward Z. Yang committed Aug 05, 2014 519 520  _ -> panic "applyPackageFlag"  Simon Marlow committed Sep 08, 2009 521 522  HidePackage str -> case selectPackages (matchingStr str) pkgs unusable of  Ian Lynagh committed Jun 12, 2012 523  Left ps -> packageFlagErr dflags flag ps  Edward Z. Yang committed Aug 05, 2014 524 525  Right (ps,_) -> return (pkgs, vm') where vm' = delListFromUFM vm (map calcKey ps)  Simon Marlow committed Sep 08, 2009 526   dterei committed Jun 17, 2011 527 528 529 530  -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted TrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of  Ian Lynagh committed Jun 12, 2012 531  Left ps -> packageFlagErr dflags flag ps  Edward Z. Yang committed Aug 05, 2014 532  Right (ps,qs) -> return (map trust ps ++ qs, vm)  Ian Lynagh committed Apr 01, 2012 533  where trust p = p {trusted=True}  dterei committed Jun 17, 2011 534 535 536  DistrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of  Ian Lynagh committed Jun 12, 2012 537  Left ps -> packageFlagErr dflags flag ps  Edward Z. Yang committed Aug 05, 2014 538  Right (ps,qs) -> return (map distrust ps ++ qs, vm)  Ian Lynagh committed Apr 01, 2012 539  where distrust p = p {trusted=False}  dterei committed Jun 17, 2011 540   Edward Z. Yang committed Aug 05, 2014 541  IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage"  Simon Marlow committed Sep 08, 2009 542 543 544 545 546 547  selectPackages :: (PackageConfig -> Bool) -> [PackageConfig] -> UnusablePackages -> Either [(PackageConfig, UnusablePackageReason)] ([PackageConfig], [PackageConfig]) selectPackages matches pkgs unusable  Edward Z. Yang committed Aug 05, 2014 548 549 550 551  = let (ps,rest) = partition matches pkgs in if null ps then Left (filter (matches.fst) (Map.elems unusable)) else Right (sortByVersion ps, rest)  batterseapower committed Jul 31, 2008 552 553 554  -- A package named on the command line can either include the -- version, or just the name if it is unambiguous.  Simon Marlow committed Sep 08, 2009 555 556 matchingStr :: String -> PackageConfig -> Bool matchingStr str p  Duncan Coutts committed Aug 29, 2014 557 558  = str == sourcePackageIdString p || str == packageNameString p  simonmar committed Jul 14, 2005 559   Simon Marlow committed Sep 08, 2009 560 matchingId :: String -> PackageConfig -> Bool  Duncan Coutts committed Aug 29, 2014 561 matchingId str p = str == installedPackageIdString p  Simon Marlow committed Sep 19, 2006 562   Edward Z. Yang committed Aug 05, 2014 563 matchingKey :: String -> PackageConfig -> Bool  Duncan Coutts committed Aug 29, 2014 564 matchingKey str p = str == packageKeyString (packageConfigId p)  Edward Z. Yang committed Aug 05, 2014 565   Edward Z. Yang committed Aug 05, 2014 566 567 568 569 570 matching :: PackageArg -> PackageConfig -> Bool matching (PackageArg str) = matchingStr str matching (PackageIdArg str) = matchingId str matching (PackageKeyArg str) = matchingKey str  Duncan Coutts committed Aug 29, 2014 571 572 sortByVersion :: [PackageConfig] -> [PackageConfig] sortByVersion = sortBy (flip (comparing packageVersion))  Ian Lynagh committed Mar 25, 2008 573 574  comparing :: Ord a => (t -> a) -> t -> t -> Ordering  Simon Marlow committed Sep 19, 2006 575 576 comparing f a b = f a compare f b  Ian Lynagh committed Jun 12, 2012 577 578 packageFlagErr :: DynFlags -> PackageFlag  Simon Marlow committed Sep 08, 2009 579 580  -> [(PackageConfig, UnusablePackageReason)] -> IO a  Simon Marlow committed Sep 23, 2010 581 582 583  -- for missing DPH package we emit a more helpful error message, because -- this may be the result of using -fdph-par or -fdph-seq.  Edward Z. Yang committed Aug 05, 2014 584 585 packageFlagErr dflags (ExposePackage (PackageArg pkg) _) [] | is_dph_package pkg  586  = throwGhcExceptionIO (CmdLineError (showSDoc dflags$ dph_err))  Simon Marlow committed Sep 23, 2010 587 588 589  where dph_err = text "the " <> text pkg <> text " package is not installed." $$text "To install it: \"cabal install dph\"." is_dph_package pkg = "dph" isPrefixOf pkg  Ian Lynagh committed Apr 01, 2012 590   591 592 packageFlagErr dflags flag reasons = throwGhcExceptionIO (CmdLineError (showSDoc dflags  err))  Edward Z. Yang committed Aug 05, 2014 593  where err = text "cannot satisfy " <> pprFlag flag <>  Austin Seipp committed Sep 09, 2014 594  (if null reasons then Outputable.empty else text ": ")$$  Simon Marlow committed Sep 08, 2009 595  nest 4 (ppr_reasons $$ Edward Z. Yang committed Aug 05, 2014 596  -- ToDo: this admonition seems a bit dodgy  Simon Marlow committed Sep 08, 2009 597 598  text "(use -v for more information)") ppr_reasons = vcat (map ppr_reason reasons)  Duncan Coutts committed Aug 29, 2014 599 600  ppr_reason (p, reason) = pprReason (ppr (installedPackageId p) <+> text "is") reason  Simon Marlow committed Sep 08, 2009 601   Edward Z. Yang committed Aug 05, 2014 602 603 604 605 606 607 608 609 610 611 612 pprFlag :: PackageFlag -> SDoc pprFlag flag = case flag of IgnorePackage p -> text "-ignore-package " <> text p HidePackage p -> text "-hide-package " <> text p ExposePackage a rns -> ppr_arg a <> ppr_rns rns TrustPackage p -> text "-trust " <> text p DistrustPackage p -> text "-distrust " <> text p where ppr_arg arg = case arg of PackageArg p -> text "-package " <> text p PackageIdArg p -> text "-package-id " <> text p PackageKeyArg p -> text "-package-key " <> text p  Austin Seipp committed Sep 09, 2014 613  ppr_rns Nothing = Outputable.empty  Edward Z. Yang committed Aug 05, 2014 614 615 616 617  ppr_rns (Just rns) = char '(' <> hsep (punctuate comma (map ppr_rn rns)) <> char ')' ppr_rn (orig, new) | orig == new = text orig | otherwise = text orig <+> text "as" <+> text new  simonmar committed Oct 14, 2005 618   Simon Marlow committed Sep 19, 2006 619 620 621 -- ----------------------------------------------------------------------------- -- Wired-in packages  Edward Z. Yang committed Aug 05, 2014 622 623 624 wired_in_pkgids :: [String] wired_in_pkgids = map packageKeyString wiredInPackageKeys  Simon Marlow committed Sep 19, 2006 625 626 627 findWiredInPackages :: DynFlags -> [PackageConfig] -- database  Simon Marlow committed Aug 20, 2009 628  -> IO [PackageConfig]  Simon Marlow committed Sep 19, 2006 629   Simon Marlow committed Aug 20, 2009 630 findWiredInPackages dflags pkgs = do  Simon Marlow committed Jul 25, 2006 631 632 633 634 635  -- -- Now we must find our wired-in packages, and rename them to -- their canonical names (eg. base-1.0 ==> base). -- let  Simon Marlow committed Aug 20, 2009 636  matches :: PackageConfig -> String -> Bool  Duncan Coutts committed Aug 29, 2014 637  pc matches pid = packageNameString pc == pid  Simon Marlow committed Jul 25, 2006 638   Ian Lynagh committed Apr 01, 2012 639 640 641 642  -- find which package corresponds to each wired-in package -- delete any other packages with the same name -- update the package and any dependencies to point to the new -- one.  Simon Marlow committed Jul 27, 2006 643 644  -- -- When choosing which package to map to a wired-in package  Edward Z. Yang committed Aug 05, 2014 645 646 647 648  -- name, we pick the latest version (modern Cabal makes it difficult -- to install multiple versions of wired-in packages, however!) -- To override the default choice, -ignore-package could be used to -- hide newer versions.  Simon Marlow committed Jul 27, 2006 649  --  Ian Lynagh committed Apr 01, 2012 650 651 652  findWiredInPackage :: [PackageConfig] -> String -> IO (Maybe InstalledPackageId) findWiredInPackage pkgs wired_pkg =  Ian Lynagh committed Jun 18, 2008 653  let all_ps = [ p | p <- pkgs, p matches wired_pkg ] in  Ian Lynagh committed Apr 01, 2012 654 655 656  case all_ps of [] -> notfound many -> pick (head (sortByVersion many))  Simon Marlow committed Jul 27, 2006 657 658  where notfound = do  Ian Lynagh committed Apr 01, 2012 659 660 661 662 663  debugTraceMsg dflags 2  ptext (sLit "wired-in package ") <> text wired_pkg <> ptext (sLit " not found.") return Nothing  Duncan Coutts committed Aug 29, 2014 664  pick :: PackageConfig  Simon Marlow committed Aug 20, 2009 665  -> IO (Maybe InstalledPackageId)  Simon Marlow committed Jul 27, 2006 666 667  pick pkg = do debugTraceMsg dflags 2   Ian Lynagh committed Apr 01, 2012 668 669 670  ptext (sLit "wired-in package ") <> text wired_pkg <> ptext (sLit " mapped to ")  Duncan Coutts committed Aug 29, 2014 671  <> ppr (installedPackageId pkg)  Ian Lynagh committed Apr 01, 2012 672  return (Just (installedPackageId pkg))  Simon Marlow committed Jul 27, 2006 673   Simon Marlow committed Jul 25, 2006 674   Ian Lynagh committed Jun 18, 2008 675  mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids  Ian Lynagh committed Apr 01, 2012 676  let  Simon Marlow committed Jul 25, 2006 677 678  wired_in_ids = catMaybes mb_wired_in_ids  Simon Marlow committed Aug 05, 2008 679 680 681 682 683 684 685 686  -- this is old: we used to assume that if there were -- multiple versions of wired-in packages installed that -- they were mutually exclusive. Now we're assuming that -- you have one "main" version of each wired-in package -- (the latest version), and the others are backward-compat -- wrappers that depend on this one. e.g. base-4.0 is the -- latest, base-3.0 is a compat wrapper depending on base-4.0. {-  Ian Lynagh committed Apr 01, 2012 687 688  deleteOtherWiredInPackages pkgs = filterOut bad pkgs where bad p = any (p matches) wired_in_pkgids  Simon Marlow committed Aug 05, 2008 689 690  && package p notElem map fst wired_in_ids -}  Simon Marlow committed Jul 25, 2006 691   Ian Lynagh committed Apr 01, 2012 692  updateWiredInDependencies pkgs = map upd_pkg pkgs  Duncan Coutts committed Aug 29, 2014 693 694  where upd_pkg pkg | installedPackageId pkg elem wired_in_ids  Duncan Coutts committed Aug 29, 2014 695 696 697  = pkg { packageKey = stringToPackageKey (packageNameString pkg) }  Simon Marlow committed Aug 20, 2009 698  | otherwise  Duncan Coutts committed Aug 29, 2014 699  = pkg  Simon Marlow committed Jul 25, 2006 700   Simon Marlow committed Aug 20, 2009 701  return  updateWiredInDependencies pkgs  Simon Marlow committed Sep 19, 2006 702   Simon Marlow committed Sep 08, 2009 703 704 705 706 707 708 709 -- ---------------------------------------------------------------------------- data UnusablePackageReason = IgnoredWithFlag | MissingDependencies [InstalledPackageId] | ShadowedBy InstalledPackageId  Edward Z. Yang committed Aug 05, 2014 710 711 type UnusablePackages = Map InstalledPackageId (PackageConfig, UnusablePackageReason)  Simon Marlow committed Sep 08, 2009 712 713 714 715 716 717 718 719  pprReason :: SDoc -> UnusablePackageReason -> SDoc pprReason pref reason = case reason of IgnoredWithFlag -> pref <+> ptext (sLit "ignored due to an -ignore-package flag") MissingDependencies deps -> pref <+> ptext (sLit "unusable due to missing or recursive dependencies:")$$  Duncan Coutts committed Aug 29, 2014 720  nest 2 (hsep (map ppr deps))  Simon Marlow committed Sep 08, 2009 721  ShadowedBy ipid ->  Duncan Coutts committed Aug 29, 2014 722  pref <+> ptext (sLit "shadowed by package ") <> ppr ipid  Simon Marlow committed Sep 08, 2009 723 724  reportUnusable :: DynFlags -> UnusablePackages -> IO ()  Ian Lynagh committed Sep 14, 2010 725 reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)  Simon Marlow committed Sep 08, 2009 726  where  Edward Z. Yang committed Aug 05, 2014 727  report (ipid, (_, reason)) =  Simon Marlow committed Sep 08, 2009 728 729 730  debugTraceMsg dflags 2 $pprReason (ptext (sLit "package") <+>  Duncan Coutts committed Aug 29, 2014 731  ppr ipid <+> text "is") reason  Simon Marlow committed Sep 08, 2009 732   Simon Marlow committed Jan 23, 2008 733 -- ----------------------------------------------------------------------------  Simon Marlow committed Sep 19, 2006 734 --  Simon Marlow committed Jan 23, 2008 735 736 737 738 739 -- Detect any packages that have missing dependencies, and also any -- mutually-recursive groups of packages (loops in the package graph -- are not allowed). We do this by taking the least fixpoint of the -- dependency graph, repeatedly adding packages whose dependencies are -- satisfied until no more can be added.  Simon Marlow committed Sep 19, 2006 740 --  Simon Marlow committed Sep 08, 2009 741 findBroken :: [PackageConfig] -> UnusablePackages  Ian Lynagh committed Sep 14, 2010 742 findBroken pkgs = go [] Map.empty pkgs  Simon Marlow committed Sep 19, 2006 743  where  Simon Marlow committed Sep 08, 2009 744 745 746  go avail ipids not_avail = case partitionWith (depsAvailable ipids) not_avail of ([], not_avail) ->  Edward Z. Yang committed Aug 05, 2014 747  Map.fromList [ (installedPackageId p, (p, MissingDependencies deps))  Ian Lynagh committed Sep 14, 2010 748  | (p,deps) <- not_avail ]  Simon Marlow committed Sep 08, 2009 749 750  (new_avail, not_avail) -> go (new_avail ++ avail) new_ipids (map fst not_avail)  Ian Lynagh committed Sep 14, 2010 751  where new_ipids = Map.insertList  Simon Marlow committed Sep 08, 2009 752  [ (installedPackageId p, p) | p <- new_avail ]  Ian Lynagh committed Sep 14, 2010 753  ipids  Simon Marlow committed Sep 08, 2009 754   Simon Marlow committed Sep 17, 2009 755  depsAvailable :: InstalledPackageIndex  Simon Marlow committed Sep 08, 2009 756  -> PackageConfig  Simon Marlow committed Aug 20, 2009 757  -> Either PackageConfig (PackageConfig, [InstalledPackageId])  Simon Marlow committed Sep 08, 2009 758  depsAvailable ipids pkg  Simon Marlow committed Jan 23, 2008 759 760  | null dangling = Left pkg | otherwise = Right (pkg, dangling)  Ian Lynagh committed Sep 14, 2010 761  where dangling = filter (not . (Map.member ipids)) (depends pkg)  Simon Marlow committed Jan 23, 2008 762   Simon Marlow committed Sep 08, 2009 763 764 765 766 -- ----------------------------------------------------------------------------- -- Eliminate shadowed packages, giving the user some feedback -- later packages in the list should shadow earlier ones with the same  Simon Marlow committed Sep 17, 2009 767 768 769 -- package name/version. Additionally, a package may be preferred if -- it is in the transitive closure of packages selected using -package-id -- flags.  Edward Z. Yang committed Sep 24, 2014 770 type UnusablePackage = (PackageConfig, UnusablePackageReason)  Simon Marlow committed Sep 17, 2009 771 772 773 shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages shadowPackages pkgs preferred = let (shadowed,_) = foldl check ([],emptyUFM) pkgs  Ian Lynagh committed Sep 14, 2010 774  in Map.fromList shadowed  Simon Marlow committed Sep 08, 2009 775  where  Edward Z. Yang committed Sep 24, 2014 776 777 778  check :: ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig) -> PackageConfig -> ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)  Simon Marlow committed Sep 17, 2009 779  check (shadowed,pkgmap) pkg  Edward Z. Yang committed Aug 05, 2014 780  | Just oldpkg <- lookupUFM pkgmap pkgid  Ian Lynagh committed Dec 03, 2009 781  , let  Simon Marlow committed Oct 06, 2009 782  ipid_new = installedPackageId pkg  Ian Lynagh committed Dec 03, 2009 783  ipid_old = installedPackageId oldpkg  Simon Marlow committed Oct 06, 2009 784  --  Ian Lynagh committed Dec 03, 2009 785  , ipid_old /= ipid_new  Simon Marlow committed Oct 06, 2009 786  = if ipid_old elem preferred  Edward Z. Yang committed Aug 05, 2014 787 788  then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap) else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap')  Simon Marlow committed Sep 08, 2009 789  | otherwise  Simon Marlow committed Sep 17, 2009 790 791  = (shadowed, pkgmap') where  Edward Z. Yang committed Sep 24, 2014 792  pkgid = packageKeyFS (packageKey pkg)  Edward Z. Yang committed Aug 05, 2014 793  pkgmap' = addToUFM pkgmap pkgid pkg  Simon Marlow committed Sep 08, 2009 794 795 796 797  -- ----------------------------------------------------------------------------- ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages  Ian Lynagh committed Sep 14, 2010 798 ignorePackages flags pkgs = Map.fromList (concatMap doit flags)  Simon Marlow committed Sep 08, 2009 799 800 801  where doit (IgnorePackage str) = case partition (matchingStr str) pkgs of  Edward Z. Yang committed Aug 05, 2014 802  (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag))  Simon Marlow committed Sep 08, 2009 803  | p <- ps ]  Ian Lynagh committed Apr 01, 2012 804 805 806  -- missing package is not an error for -ignore-package, -- because a common usage is to -ignore-package P as -- a preventative measure just in case P exists.  Simon Marlow committed Sep 08, 2009 807  doit _ = panic "ignorePackages"  Simon Marlow committed Sep 19, 2006 808   Simon Marlow committed Sep 17, 2009 809 810 811 812 813 -- ----------------------------------------------------------------------------- depClosure :: InstalledPackageIndex -> [InstalledPackageId] -> [InstalledPackageId]  Ian Lynagh committed Sep 14, 2010 814 depClosure index ipids = closure Map.empty ipids  Simon Marlow committed Sep 17, 2009 815  where  Ian Lynagh committed Sep 14, 2010 816  closure set [] = Map.keys set  Simon Marlow committed Sep 17, 2009 817  closure set (ipid : ipids)  Ian Lynagh committed Sep 14, 2010 818  | ipid Map.member set = closure set ipids  Ian Lynagh committed Apr 01, 2012 819  | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set)  Ian Lynagh committed Sep 14, 2010 820  (depends p ++ ipids)  Simon Marlow committed Sep 17, 2009 821 822  | otherwise = closure set ipids  Simon Marlow committed Sep 19, 2006 823 824 825 826 827 828 -- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our package -- settings and populate the package state. mkPackageState :: DynFlags  Simon Marlow committed Sep 08, 2009 829  -> [PackageConfig] -- initial database  Edward Z. Yang committed Jul 21, 2014 830 831  -> [PackageKey] -- preloaded packages -> PackageKey -- this package  Simon Marlow committed Sep 19, 2006 832  -> IO (PackageState,  Edward Z. Yang committed Jul 21, 2014 833 834  [PackageKey], -- new packages to preload PackageKey) -- this package, might be modified if the current  Simon Marlow committed Sep 19, 2006 835 836  -- package is a wired-in package.  Simon Marlow committed Sep 08, 2009 837 838 mkPackageState dflags pkgs0 preload0 this_package = do  Simon Marlow committed Sep 17, 2009 839 840 841 {- Plan.  Ian Lynagh committed Apr 01, 2012 842  1. P = transitive closure of packages selected by -package-id  Simon Marlow committed Sep 17, 2009 843 844  2. Apply shadowing. When there are multiple packages with the same  Edward Z. Yang committed Aug 05, 2014 845  packageKey,  Simon Marlow committed Sep 17, 2009 846 847 848  * if one is in P, use that one * otherwise, use the one highest in the package stack [  Edward Z. Yang committed Aug 05, 2014 849 850  rationale: we cannot use two packages with the same packageKey in the same program, because packageKey is the symbol prefix.  Simon Marlow committed Sep 17, 2009 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876  Hence we must select a consistent set of packages to use. We have a default algorithm for doing this: packages higher in the stack shadow those lower down. This default algorithm can be overriden by giving explicit -package-id flags; then we have to take these preferences into account when selecting which other packages are made available. Our simple algorithm throws away some solutions: there may be other consistent sets that would satisfy the -package flags, but it's not GHC's job to be doing constraint solving. ] 3. remove packages selected by -ignore-package 4. remove any packages with missing dependencies, or mutually recursive dependencies. 5. report (with -v) any packages that were removed by steps 2-4 6. apply flags to set exposed/hidden on the resulting packages - if any flag refers to a package which was removed by 2-4, then we can give an error message explaining why 7. hide any packages which are superseded by later exposed packages -}  Simon Marlow committed Sep 08, 2009 877  let  chak@cse.unsw.edu.au. committed Nov 10, 2011 878  flags = reverse (packageFlags dflags)  Simon Marlow committed Sep 17, 2009 879   Simon Marlow committed Nov 12, 2009 880  -- pkgs0 with duplicate packages filtered out. This is  Simon Marlow committed May 19, 2010 881 882 883  -- important: it is possible for a package in the global package -- DB to have the same IPID as a package in the user DB, and -- we want the latter to take precedence. This is not the same  Simon Marlow committed Nov 12, 2009 884 885  -- as shadowing (below), since in this case the two packages -- have the same ABI and are interchangeable.  Simon Marlow committed May 19, 2010 886 887 888 889 890 891 892 893 894 895  -- -- #4072: note that we must retain the ordering of the list here -- so that shadowing behaves as expected when we apply it later. pkgs0_unique = snd$ foldr del (Set.empty,[]) pkgs0 where del p (s,ps) | pid Set.member s = (s,ps) | otherwise = (Set.insert pid s, p:ps) where pid = installedPackageId p -- XXX this is just a variant of nub  Ian Lynagh committed Sep 14, 2010 896  ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]  Simon Marlow committed Nov 12, 2009 897   Edward Z. Yang committed Aug 05, 2014 898  ipid_selected = depClosure ipid_map  Duncan Coutts committed Aug 29, 2014 899  [ InstalledPackageId (mkFastString i)  Edward Z. Yang committed Aug 05, 2014 900  | ExposePackage (PackageIdArg i) _ <- flags ]  Ian Lynagh committed Apr 01, 2012 901   Simon Marlow committed Sep 08, 2009 902 903 904 905  (ignore_flags, other_flags) = partition is_ignore flags is_ignore IgnorePackage{} = True is_ignore _ = False  Simon Marlow committed Nov 12, 2009 906 907  shadowed = shadowPackages pkgs0_unique ipid_selected ignored = ignorePackages ignore_flags pkgs0_unique  Simon Marlow committed Sep 08, 2009 908   Edward Z. Yang committed Aug 05, 2014 909 910 911  isBroken = (Map.member (Map.union shadowed ignored)).installedPackageId pkgs0' = filter (not . isBroken) pkgs0_unique  Simon Marlow committed Sep 08, 2009 912  broken = findBroken pkgs0'  Edward Z. Yang committed Aug 05, 2014 913   Ian Lynagh committed Sep 14, 2010 914  unusable = shadowed Map.union ignored Map.union broken  Edward Z. Yang committed Aug 05, 2014 915  pkgs1 = filter (not . (Map.member unusable) . installedPackageId) pkgs0'  Simon Marlow committed Sep 08, 2009 916 917 918  reportUnusable dflags unusable  Edward Z. Yang committed Aug 05, 2014 919 920 921 922 923 924  -- -- Calculate the initial set of packages, prior to any package flags. -- This set contains the latest version of all valid (not unusable) packages, -- or is empty if we have -hide-all-packages -- let preferLater pkg pkg' =  Duncan Coutts committed Aug 29, 2014 925  case comparing packageVersion pkg pkg' of  Edward Z. Yang committed Aug 05, 2014 926 927 928 929 930 931 932 933 934 935 936 937 938  GT -> pkg _ -> pkg' calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg initial = if gopt Opt_HideAllPackages dflags then emptyUFM else foldl' calcInitial emptyUFM pkgs1 vis_map0 = foldUFM (\p vm -> if exposed p then addToUFM vm (calcKey p) (True, [], fsPackageName p) else vm) emptyUFM initial  simonmar committed Nov 26, 2004 939  --  Simon Marlow committed Sep 19, 2006 940 941  -- Modify the package database according to the command-line flags -- (-package, -hide-package, -ignore-package, -hide-all-packages).  Edward Z. Yang committed Aug 05, 2014 942 943  -- This needs to know about the unusable packages, since if a user tries -- to enable an unusable package, we should let them know.  simonmar committed Nov 26, 2004 944  --  Edward Z. Yang committed Aug 05, 2014 945 946  (pkgs2, vis_map) <- foldM (applyPackageFlag dflags unusable) (pkgs1, vis_map0) other_flags  Simon Marlow committed Sep 19, 2006 947   Edward Z. Yang committed Aug 05, 2014 948 949 950 951 952 953 954 955  -- -- Sort out which packages are wired in. This has to be done last, since -- it modifies the package keys of wired in packages, but when we process -- package arguments we need to key against the old versions. -- pkgs3 <- findWiredInPackages dflags pkgs2 --  Simon Marlow committed Sep 19, 2006 956 957 958 959 960  -- Here we build up a set of the packages mentioned in -package -- flags on the command line; these are called the "preload" -- packages. we link these packages in eagerly. The preload set -- should contain at least rts & base, which is why we pretend that -- the command line contains -package rts & -package base.  simonmar committed Nov 26, 2004 961  --  Simon Marlow committed Sep 08, 2009 962 963  let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]  Edward Z. Yang committed Aug 05, 2014 964 965 966  get_exposed (ExposePackage a _) = take 1 . sortByVersion . filter (matching a) \$ pkgs2  Edward Z. Yang committed Aug 05, 2014 967  get_exposed _ = []  Simon Marlow committed Sep 19, 2006 968   Edward Z. Yang committed Aug 05, 2014 969  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3  Simon Marlow committed Sep 19, 2006 970   Ian Lynagh committed Sep 14, 2010 971  ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)  Edward Z. Yang committed Aug 05, 2014 972  | p <- pkgs3 ]  Simon Marlow committed Aug 20, 2009