Allow recursive (undecidable) superclasses
[ghc.git] / compiler / main / Packages.hs
1 -- (c) The University of Glasgow, 2006
2
3 {-# LANGUAGE CPP, ScopedTypeVariables #-}
4
5 -- | Package manipulation
6 module Packages (
7 module PackageConfig,
8
9 -- * Reading the package config, and processing cmdline args
10 PackageState(preloadPackages, explicitPackages),
11 emptyPackageState,
12 initPackages,
13 readPackageConfigs,
14 getPackageConfRefs,
15 resolvePackageConfig,
16 readPackageConfig,
17 listPackageConfigMap,
18
19 -- * Querying the package config
20 lookupPackage,
21 searchPackageId,
22 getPackageDetails,
23 listVisibleModuleNames,
24 lookupModuleInAllPackages,
25 lookupModuleWithSuggestions,
26 LookupResult(..),
27 ModuleSuggestion(..),
28 ModuleOrigin(..),
29
30 -- * Inspecting the set of packages in scope
31 getPackageIncludePath,
32 getPackageLibraryPath,
33 getPackageLinkOpts,
34 getPackageExtraCcOpts,
35 getPackageFrameworkPath,
36 getPackageFrameworks,
37 getPreloadPackagesAnd,
38
39 collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
40 packageHsLibs,
41
42 -- * Utils
43 unitIdPackageIdString,
44 pprFlag,
45 pprPackages,
46 pprPackagesSimple,
47 pprModuleMap,
48 isDllName
49 )
50 where
51
52 #include "HsVersions.h"
53
54 import GHC.PackageDb
55 import PackageConfig
56 import DynFlags
57 import Name ( Name, nameModule_maybe )
58 import UniqFM
59 import Module
60 import Util
61 import Panic
62 import Outputable
63 import Maybes
64
65 import System.Environment ( getEnv )
66 import FastString
67 import ErrUtils ( debugTraceMsg, MsgDoc )
68 import Exception
69 import Unique
70
71 import System.Directory
72 import System.FilePath as FilePath
73 import qualified System.FilePath.Posix as FilePath.Posix
74 import Control.Monad
75 import Data.Char ( toUpper )
76 import Data.List as List
77 import Data.Map (Map)
78 import Data.Set (Set)
79 #if __GLASGOW_HASKELL__ < 709
80 import Data.Monoid hiding ((<>))
81 #endif
82 #if __GLASGOW_HASKELL__ > 710
83 import Data.Semigroup ( Semigroup )
84 import qualified Data.Semigroup as Semigroup
85 #endif
86 import qualified Data.Map as Map
87 import qualified FiniteMap as Map
88 import qualified Data.Set as Set
89
90 -- ---------------------------------------------------------------------------
91 -- The Package state
92
93 -- | Package state is all stored in 'DynFlags', including the details of
94 -- all packages, which packages are exposed, and which modules they
95 -- provide.
96 --
97 -- The package state is computed by 'initPackages', and kept in DynFlags.
98 -- It is influenced by various package flags:
99 --
100 -- * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed.
101 -- If @-hide-all-packages@ was not specified, these commands also cause
102 -- all other packages with the same name to become hidden.
103 --
104 -- * @-hide-package <pkg>@ causes @<pkg>@ to become hidden.
105 --
106 -- * (there are a few more flags, check below for their semantics)
107 --
108 -- The package state has the following properties.
109 --
110 -- * Let @exposedPackages@ be the set of packages thus exposed.
111 -- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of
112 -- their dependencies.
113 --
114 -- * When searching for a module from an preload import declaration,
115 -- only the exposed modules in @exposedPackages@ are valid.
116 --
117 -- * When searching for a module from an implicit import, all modules
118 -- from @depExposedPackages@ are valid.
119 --
120 -- * When linking in a compilation manager mode, we link in packages the
121 -- program depends on (the compiler knows this list by the
122 -- time it gets to the link step). Also, we link in all packages
123 -- which were mentioned with preload @-package@ flags on the command-line,
124 -- or are a transitive dependency of same, or are \"base\"\/\"rts\".
125 -- The reason for this is that we might need packages which don't
126 -- contain any Haskell modules, and therefore won't be discovered
127 -- by the normal mechanism of dependency tracking.
128
129 -- Notes on DLLs
130 -- ~~~~~~~~~~~~~
131 -- When compiling module A, which imports module B, we need to
132 -- know whether B will be in the same DLL as A.
133 -- If it's in the same DLL, we refer to B_f_closure
134 -- If it isn't, we refer to _imp__B_f_closure
135 -- When compiling A, we record in B's Module value whether it's
136 -- in a different DLL, by setting the DLL flag.
137
138 -- | Given a module name, there may be multiple ways it came into scope,
139 -- possibly simultaneously. This data type tracks all the possible ways
140 -- it could have come into scope. Warning: don't use the record functions,
141 -- they're partial!
142 data ModuleOrigin =
143 -- | Module is hidden, and thus never will be available for import.
144 -- (But maybe the user didn't realize), so we'll still keep track
145 -- of these modules.)
146 ModHidden
147 -- | Module is public, and could have come from some places.
148 | ModOrigin {
149 -- | @Just False@ means that this module is in
150 -- someone's @exported-modules@ list, but that package is hidden;
151 -- @Just True@ means that it is available; @Nothing@ means neither
152 -- applies.
153 fromOrigPackage :: Maybe Bool
154 -- | Is the module available from a reexport of an exposed package?
155 -- There could be multiple.
156 , fromExposedReexport :: [PackageConfig]
157 -- | Is the module available from a reexport of a hidden package?
158 , fromHiddenReexport :: [PackageConfig]
159 -- | Did the module export come from a package flag? (ToDo: track
160 -- more information.
161 , fromPackageFlag :: Bool
162 }
163
164 instance Outputable ModuleOrigin where
165 ppr ModHidden = text "hidden module"
166 ppr (ModOrigin e res rhs f) = sep (punctuate comma (
167 (case e of
168 Nothing -> []
169 Just False -> [text "hidden package"]
170 Just True -> [text "exposed package"]) ++
171 (if null res
172 then []
173 else [text "reexport by" <+>
174 sep (map (ppr . packageConfigId) res)]) ++
175 (if null rhs
176 then []
177 else [text "hidden reexport by" <+>
178 sep (map (ppr . packageConfigId) res)]) ++
179 (if f then [text "package flag"] else [])
180 ))
181
182 -- | Smart constructor for a module which is in @exposed-modules@. Takes
183 -- as an argument whether or not the defining package is exposed.
184 fromExposedModules :: Bool -> ModuleOrigin
185 fromExposedModules e = ModOrigin (Just e) [] [] False
186
187 -- | Smart constructor for a module which is in @reexported-modules@. Takes
188 -- as an argument whether or not the reexporting package is expsed, and
189 -- also its 'PackageConfig'.
190 fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin
191 fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
192 fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
193
194 -- | Smart constructor for a module which was bound by a package flag.
195 fromFlag :: ModuleOrigin
196 fromFlag = ModOrigin Nothing [] [] True
197
198 #if __GLASGOW_HASKELL__ > 710
199 instance Semigroup ModuleOrigin where
200 ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' =
201 ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
202 where g (Just b) (Just b')
203 | b == b' = Just b
204 | otherwise = panic "ModOrigin: package both exposed/hidden"
205 g Nothing x = x
206 g x Nothing = x
207 _x <> _y = panic "ModOrigin: hidden module redefined"
208 #endif
209
210 instance Monoid ModuleOrigin where
211 mempty = ModOrigin Nothing [] [] False
212 mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') =
213 ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
214 where g (Just b) (Just b')
215 | b == b' = Just b
216 | otherwise = panic "ModOrigin: package both exposed/hidden"
217 g Nothing x = x
218 g x Nothing = x
219 mappend _ _ = panic "ModOrigin: hidden module redefined"
220
221 -- | Is the name from the import actually visible? (i.e. does it cause
222 -- ambiguity, or is it only relevant when we're making suggestions?)
223 originVisible :: ModuleOrigin -> Bool
224 originVisible ModHidden = False
225 originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f
226
227 -- | Are there actually no providers for this module? This will never occur
228 -- except when we're filtering based on package imports.
229 originEmpty :: ModuleOrigin -> Bool
230 originEmpty (ModOrigin Nothing [] [] False) = True
231 originEmpty _ = False
232
233 -- | 'UniqFM' map from 'UnitId'
234 type UnitIdMap = UniqFM
235
236 -- | 'UniqFM' map from 'UnitId' to 'PackageConfig'
237 type PackageConfigMap = UnitIdMap PackageConfig
238
239 -- | 'UniqFM' map from 'UnitId' to (1) whether or not all modules which
240 -- are exposed should be dumped into scope, (2) any custom renamings that
241 -- should also be apply, and (3) what package name is associated with the
242 -- key, if it might be hidden
243 type VisibilityMap =
244 UnitIdMap (Bool, [(ModuleName, ModuleName)], FastString)
245
246 -- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
247 -- in scope. The 'PackageConf' is not cached, mostly for convenience reasons
248 -- (since this is the slow path, we'll just look it up again).
249 type ModuleToPkgConfAll =
250 Map ModuleName (Map Module ModuleOrigin)
251
252 data PackageState = PackageState {
253 -- | A mapping of 'UnitId' to 'PackageConfig'. This list is adjusted
254 -- so that only valid packages are here. 'PackageConfig' reflects
255 -- what was stored *on disk*, except for the 'trusted' flag, which
256 -- is adjusted at runtime. (In particular, some packages in this map
257 -- may have the 'exposed' flag be 'False'.)
258 pkgIdMap :: PackageConfigMap,
259
260 -- | The packages we're going to link in eagerly. This list
261 -- should be in reverse dependency order; that is, a package
262 -- is always mentioned before the packages it depends on.
263 preloadPackages :: [UnitId],
264
265 -- | Packages which we explicitly depend on (from a command line flag).
266 -- We'll use this to generate version macros.
267 explicitPackages :: [UnitId],
268
269 -- | This is a full map from 'ModuleName' to all modules which may possibly
270 -- be providing it. These providers may be hidden (but we'll still want
271 -- to report them in error messages), or it may be an ambiguous import.
272 moduleToPkgConfAll :: ModuleToPkgConfAll
273 }
274
275 emptyPackageState :: PackageState
276 emptyPackageState = PackageState {
277 pkgIdMap = emptyUFM,
278 preloadPackages = [],
279 explicitPackages = [],
280 moduleToPkgConfAll = Map.empty
281 }
282
283 type InstalledPackageIndex = Map UnitId PackageConfig
284
285 -- | Empty package configuration map
286 emptyPackageConfigMap :: PackageConfigMap
287 emptyPackageConfigMap = emptyUFM
288
289 -- | Find the package we know about with the given key (e.g. @foo_HASH@), if any
290 lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
291 lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))
292
293 lookupPackage' :: PackageConfigMap -> UnitId -> Maybe PackageConfig
294 lookupPackage' = lookupUFM
295
296 -- | Search for packages with a given package ID (e.g. \"foo-0.1\")
297 searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
298 searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
299 (listPackageConfigMap dflags)
300
301 -- | Extends the package configuration map with a list of package configs.
302 extendPackageConfigMap
303 :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
304 extendPackageConfigMap pkg_map new_pkgs
305 = foldl add pkg_map new_pkgs
306 where add pkg_map p = addToUFM pkg_map (packageConfigId p) p
307
308 -- | Looks up the package with the given id in the package state, panicing if it is
309 -- not found
310 getPackageDetails :: DynFlags -> UnitId -> PackageConfig
311 getPackageDetails dflags pid =
312 expectJust "getPackageDetails" (lookupPackage dflags pid)
313
314 -- | Get a list of entries from the package database. NB: be careful with
315 -- this function, although all packages in this map are "visible", this
316 -- does not imply that the exposed-modules of the package are available
317 -- (they may have been thinned or renamed).
318 listPackageConfigMap :: DynFlags -> [PackageConfig]
319 listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags))
320
321 -- ----------------------------------------------------------------------------
322 -- Loading the package db files and building up the package state
323
324 -- | Call this after 'DynFlags.parseDynFlags'. It reads the package
325 -- database files, and sets up various internal tables of package
326 -- information, according to the package-related flags on the
327 -- command-line (@-package@, @-hide-package@ etc.)
328 --
329 -- Returns a list of packages to link in if we're doing dynamic linking.
330 -- This list contains the packages that the user explicitly mentioned with
331 -- @-package@ flags.
332 --
333 -- 'initPackages' can be called again subsequently after updating the
334 -- 'packageFlags' field of the 'DynFlags', and it will update the
335 -- 'pkgState' in 'DynFlags' and return a list of packages to
336 -- link in.
337 initPackages :: DynFlags -> IO (DynFlags, [UnitId])
338 initPackages dflags = do
339 pkg_db <-
340 case pkgDatabase dflags of
341 Nothing -> readPackageConfigs dflags
342 Just db -> return $ map (\(p, pkgs)
343 -> (p, setBatchPackageFlags dflags pkgs)) db
344 (pkg_state, preload, this_pkg)
345 <- mkPackageState dflags pkg_db []
346 return (dflags{ pkgDatabase = Just pkg_db,
347 pkgState = pkg_state,
348 thisPackage = this_pkg },
349 preload)
350
351 -- -----------------------------------------------------------------------------
352 -- Reading the package database(s)
353
354 readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])]
355 readPackageConfigs dflags = do
356 conf_refs <- getPackageConfRefs dflags
357 confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
358 mapM (readPackageConfig dflags) confs
359
360
361 getPackageConfRefs :: DynFlags -> IO [PkgConfRef]
362 getPackageConfRefs dflags = do
363 let system_conf_refs = [UserPkgConf, GlobalPkgConf]
364
365 e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
366 let base_conf_refs = case e_pkg_path of
367 Left _ -> system_conf_refs
368 Right path
369 | not (null path) && isSearchPathSeparator (last path)
370 -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs
371 | otherwise
372 -> map PkgConfFile (splitSearchPath path)
373
374 return $ reverse (extraPkgConfs dflags base_conf_refs)
375 -- later packages shadow earlier ones. extraPkgConfs
376 -- is in the opposite order to the flags on the
377 -- command line.
378
379 resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
380 resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
381 resolvePackageConfig dflags UserPkgConf = handleIO (\_ -> return Nothing) $ do
382 dir <- versionedAppDir dflags
383 let pkgconf = dir </> "package.conf.d"
384 exist <- doesDirectoryExist pkgconf
385 return $ if exist then Just pkgconf else Nothing
386 resolvePackageConfig _ (PkgConfFile name) = return $ Just name
387
388 readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig])
389 readPackageConfig dflags conf_file = do
390 isdir <- doesDirectoryExist conf_file
391
392 proto_pkg_configs <-
393 if isdir
394 then readDirStylePackageConfig conf_file
395 else do
396 isfile <- doesFileExist conf_file
397 if isfile
398 then do
399 mpkgs <- tryReadOldFileStylePackageConfig
400 case mpkgs of
401 Just pkgs -> return pkgs
402 Nothing -> throwGhcExceptionIO $ InstallationError $
403 "ghc no longer supports single-file style package " ++
404 "databases (" ++ conf_file ++
405 ") use 'ghc-pkg init' to create the database with " ++
406 "the correct format."
407 else throwGhcExceptionIO $ InstallationError $
408 "can't find a package database at " ++ conf_file
409
410 let
411 top_dir = topDir dflags
412 pkgroot = takeDirectory conf_file
413 pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
414 pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
415 --
416 return (conf_file, pkg_configs2)
417 where
418 readDirStylePackageConfig conf_dir = do
419 let filename = conf_dir </> "package.cache"
420 debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
421 readPackageDbForGhc filename
422
423 -- Single-file style package dbs have been deprecated for some time, but
424 -- it turns out that Cabal was using them in one place. So this is a
425 -- workaround to allow older Cabal versions to use this newer ghc.
426 -- We check if the file db contains just "[]" and if so, we look for a new
427 -- dir-style db in conf_file.d/, ie in a dir next to the given file.
428 -- We cannot just replace the file with a new dir style since Cabal still
429 -- assumes it's a file and tries to overwrite with 'writeFile'.
430 -- ghc-pkg also cooperates with this workaround.
431 tryReadOldFileStylePackageConfig = do
432 content <- readFile conf_file `catchIO` \_ -> return ""
433 if take 2 content == "[]"
434 then do
435 let conf_dir = conf_file <.> "d"
436 direxists <- doesDirectoryExist conf_dir
437 if direxists
438 then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
439 liftM Just (readDirStylePackageConfig conf_dir)
440 else return (Just []) -- ghc-pkg will create it when it's updated
441 else return Nothing
442
443 setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
444 setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
445 where
446 maybeDistrustAll pkgs'
447 | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
448 | otherwise = pkgs'
449
450 distrust pkg = pkg{ trusted = False }
451
452 -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
453 mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
454 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
455 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
456 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
457 -- The "pkgroot" is the directory containing the package database.
458 --
459 -- Also perform a similar substitution for the older GHC-specific
460 -- "$topdir" variable. The "topdir" is the location of the ghc
461 -- installation (obtained from the -B option).
462 mungePackagePaths top_dir pkgroot pkg =
463 pkg {
464 importDirs = munge_paths (importDirs pkg),
465 includeDirs = munge_paths (includeDirs pkg),
466 libraryDirs = munge_paths (libraryDirs pkg),
467 frameworkDirs = munge_paths (frameworkDirs pkg),
468 haddockInterfaces = munge_paths (haddockInterfaces pkg),
469 haddockHTMLs = munge_urls (haddockHTMLs pkg)
470 }
471 where
472 munge_paths = map munge_path
473 munge_urls = map munge_url
474
475 munge_path p
476 | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
477 | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
478 | otherwise = p
479
480 munge_url p
481 | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
482 | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
483 | otherwise = p
484
485 toUrlPath r p = "file:///"
486 -- URLs always use posix style '/' separators:
487 ++ FilePath.Posix.joinPath
488 (r : -- We need to drop a leading "/" or "\\"
489 -- if there is one:
490 dropWhile (all isPathSeparator)
491 (FilePath.splitDirectories p))
492
493 -- We could drop the separator here, and then use </> above. However,
494 -- by leaving it in and using ++ we keep the same path separator
495 -- rather than letting FilePath change it to use \ as the separator
496 stripVarPrefix var path = case stripPrefix var path of
497 Just [] -> Just []
498 Just cs@(c : _) | isPathSeparator c -> Just cs
499 _ -> Nothing
500
501
502 -- -----------------------------------------------------------------------------
503 -- Modify our copy of the package database based on a package flag
504 -- (-package, -hide-package, -ignore-package).
505
506 applyPackageFlag
507 :: DynFlags
508 -> UnusablePackages
509 -> ([PackageConfig], VisibilityMap) -- Initial database
510 -> PackageFlag -- flag to apply
511 -> IO ([PackageConfig], VisibilityMap) -- new database
512
513 -- ToDo: Unfortunately, we still have to plumb the package config through,
514 -- because Safe Haskell trust is still implemented by modifying the database.
515 -- Eventually, track that separately and then axe @[PackageConfig]@ from
516 -- this fold entirely
517
518 applyPackageFlag dflags unusable (pkgs, vm) flag =
519 case flag of
520 ExposePackage arg (ModRenaming b rns) ->
521 case selectPackages (matching arg) pkgs unusable of
522 Left ps -> packageFlagErr dflags flag ps
523 Right (p:_,_) -> return (pkgs, vm')
524 where
525 n = fsPackageName p
526 vm' = addToUFM_C edit vm_cleared (packageConfigId p) (b, rns, n)
527 edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
528 -- ToDo: ATM, -hide-all-packages implicitly triggers change in
529 -- behavior, maybe eventually make it toggleable with a separate
530 -- flag
531 vm_cleared | gopt Opt_HideAllPackages dflags = vm
532 | otherwise = filterUFM_Directly
533 (\k (_,_,n') -> k == getUnique (packageConfigId p)
534 || n /= n') vm
535 _ -> panic "applyPackageFlag"
536
537 HidePackage str ->
538 case selectPackages (matchingStr str) pkgs unusable of
539 Left ps -> packageFlagErr dflags flag ps
540 Right (ps,_) -> return (pkgs, vm')
541 where vm' = delListFromUFM vm (map packageConfigId ps)
542
543 -- we trust all matching packages. Maybe should only trust first one?
544 -- and leave others the same or set them untrusted
545 TrustPackage str ->
546 case selectPackages (matchingStr str) pkgs unusable of
547 Left ps -> packageFlagErr dflags flag ps
548 Right (ps,qs) -> return (map trust ps ++ qs, vm)
549 where trust p = p {trusted=True}
550
551 DistrustPackage str ->
552 case selectPackages (matchingStr str) pkgs unusable of
553 Left ps -> packageFlagErr dflags flag ps
554 Right (ps,qs) -> return (map distrust ps ++ qs, vm)
555 where distrust p = p {trusted=False}
556
557 IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage"
558
559 selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
560 -> UnusablePackages
561 -> Either [(PackageConfig, UnusablePackageReason)]
562 ([PackageConfig], [PackageConfig])
563 selectPackages matches pkgs unusable
564 = let (ps,rest) = partition matches pkgs
565 in if null ps
566 then Left (filter (matches.fst) (Map.elems unusable))
567 else Right (sortByVersion ps, rest)
568
569 -- A package named on the command line can either include the
570 -- version, or just the name if it is unambiguous.
571 matchingStr :: String -> PackageConfig -> Bool
572 matchingStr str p
573 = str == sourcePackageIdString p
574 || str == packageNameString p
575
576 matchingId :: String -> PackageConfig -> Bool
577 matchingId str p = str == componentIdString p
578
579 matchingKey :: String -> PackageConfig -> Bool
580 matchingKey str p = str == unitIdString (packageConfigId p)
581
582 matching :: PackageArg -> PackageConfig -> Bool
583 matching (PackageArg str) = matchingStr str
584 matching (PackageIdArg str) = matchingId str
585 matching (UnitIdArg str) = matchingKey str
586
587 sortByVersion :: [PackageConfig] -> [PackageConfig]
588 sortByVersion = sortBy (flip (comparing packageVersion))
589
590 comparing :: Ord a => (t -> a) -> t -> t -> Ordering
591 comparing f a b = f a `compare` f b
592
593 packageFlagErr :: DynFlags
594 -> PackageFlag
595 -> [(PackageConfig, UnusablePackageReason)]
596 -> IO a
597
598 -- for missing DPH package we emit a more helpful error message, because
599 -- this may be the result of using -fdph-par or -fdph-seq.
600 packageFlagErr dflags (ExposePackage (PackageArg pkg) _) []
601 | is_dph_package pkg
602 = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
603 where dph_err = text "the " <> text pkg <> text " package is not installed."
604 $$ text "To install it: \"cabal install dph\"."
605 is_dph_package pkg = "dph" `isPrefixOf` pkg
606
607 packageFlagErr dflags flag reasons
608 = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
609 where err = text "cannot satisfy " <> pprFlag flag <>
610 (if null reasons then Outputable.empty else text ": ") $$
611 nest 4 (ppr_reasons $$
612 text "(use -v for more information)")
613 ppr_reasons = vcat (map ppr_reason reasons)
614 ppr_reason (p, reason) =
615 pprReason (ppr (unitId p) <+> text "is") reason
616
617 pprFlag :: PackageFlag -> SDoc
618 pprFlag flag = case flag of
619 IgnorePackage p -> text "-ignore-package " <> text p
620 HidePackage p -> text "-hide-package " <> text p
621 ExposePackage a rns -> ppr_arg a <> ppr_rns rns
622 TrustPackage p -> text "-trust " <> text p
623 DistrustPackage p -> text "-distrust " <> text p
624 where ppr_arg arg = case arg of
625 PackageArg p -> text "-package " <> text p
626 PackageIdArg p -> text "-package-id " <> text p
627 UnitIdArg p -> text "-package-key " <> text p
628 ppr_rns (ModRenaming True []) = Outputable.empty
629 ppr_rns (ModRenaming b rns) =
630 if b then text "with" else Outputable.empty <+>
631 char '(' <> hsep (punctuate comma (map ppr_rn rns)) <> char ')'
632 ppr_rn (orig, new) | orig == new = ppr orig
633 | otherwise = ppr orig <+> text "as" <+> ppr new
634
635 -- -----------------------------------------------------------------------------
636 -- Wired-in packages
637
638 wired_in_pkgids :: [String]
639 wired_in_pkgids = map unitIdString wiredInUnitIds
640
641 type WiredPackagesMap = Map UnitId UnitId
642
643 findWiredInPackages
644 :: DynFlags
645 -> [PackageConfig] -- database
646 -> VisibilityMap -- info on what packages are visible
647 -> IO ([PackageConfig], VisibilityMap, WiredPackagesMap)
648
649 findWiredInPackages dflags pkgs vis_map = do
650 --
651 -- Now we must find our wired-in packages, and rename them to
652 -- their canonical names (eg. base-1.0 ==> base).
653 --
654 let
655 matches :: PackageConfig -> String -> Bool
656 pc `matches` pid = packageNameString pc == pid
657
658 -- find which package corresponds to each wired-in package
659 -- delete any other packages with the same name
660 -- update the package and any dependencies to point to the new
661 -- one.
662 --
663 -- When choosing which package to map to a wired-in package
664 -- name, we try to pick the latest version of exposed packages.
665 -- However, if there are no exposed wired in packages available
666 -- (e.g. -hide-all-packages was used), we can't bail: we *have*
667 -- to assign a package for the wired-in package: so we try again
668 -- with hidden packages included to (and pick the latest
669 -- version).
670 --
671 -- You can also override the default choice by using -ignore-package:
672 -- this works even when there is no exposed wired in package
673 -- available.
674 --
675 findWiredInPackage :: [PackageConfig] -> String
676 -> IO (Maybe PackageConfig)
677 findWiredInPackage pkgs wired_pkg =
678 let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
679 all_exposed_ps =
680 [ p | p <- all_ps
681 , elemUFM (packageConfigId p) vis_map ] in
682 case all_exposed_ps of
683 [] -> case all_ps of
684 [] -> notfound
685 many -> pick (head (sortByVersion many))
686 many -> pick (head (sortByVersion many))
687 where
688 notfound = do
689 debugTraceMsg dflags 2 $
690 ptext (sLit "wired-in package ")
691 <> text wired_pkg
692 <> ptext (sLit " not found.")
693 return Nothing
694 pick :: PackageConfig
695 -> IO (Maybe PackageConfig)
696 pick pkg = do
697 debugTraceMsg dflags 2 $
698 ptext (sLit "wired-in package ")
699 <> text wired_pkg
700 <> ptext (sLit " mapped to ")
701 <> ppr (unitId pkg)
702 return (Just pkg)
703
704
705 mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
706 let
707 wired_in_pkgs = catMaybes mb_wired_in_pkgs
708 wired_in_ids = map unitId wired_in_pkgs
709
710 -- this is old: we used to assume that if there were
711 -- multiple versions of wired-in packages installed that
712 -- they were mutually exclusive. Now we're assuming that
713 -- you have one "main" version of each wired-in package
714 -- (the latest version), and the others are backward-compat
715 -- wrappers that depend on this one. e.g. base-4.0 is the
716 -- latest, base-3.0 is a compat wrapper depending on base-4.0.
717 {-
718 deleteOtherWiredInPackages pkgs = filterOut bad pkgs
719 where bad p = any (p `matches`) wired_in_pkgids
720 && package p `notElem` map fst wired_in_ids
721 -}
722
723 wiredInMap :: Map UnitId UnitId
724 wiredInMap = foldl' add_mapping Map.empty pkgs
725 where add_mapping m pkg
726 | let key = unitId pkg
727 , key `elem` wired_in_ids
728 = Map.insert key (stringToUnitId (packageNameString pkg)) m
729 | otherwise = m
730
731 updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
732 where upd_pkg pkg
733 | unitId pkg `elem` wired_in_ids
734 = pkg {
735 unitId = stringToUnitId (packageNameString pkg)
736 }
737 | otherwise
738 = pkg
739 upd_deps pkg = pkg {
740 depends = map upd_wired_in (depends pkg)
741 }
742 upd_wired_in key
743 | Just key' <- Map.lookup key wiredInMap = key'
744 | otherwise = key
745
746 updateVisibilityMap vis_map = foldl' f vis_map wired_in_pkgs
747 where f vm p = case lookupUFM vis_map (packageConfigId p) of
748 Nothing -> vm
749 Just r -> addToUFM vm (stringToUnitId
750 (packageNameString p)) r
751
752
753 return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map, wiredInMap)
754
755 -- ----------------------------------------------------------------------------
756
757 type IsShadowed = Bool
758 data UnusablePackageReason
759 = IgnoredWithFlag
760 | MissingDependencies IsShadowed [UnitId]
761
762 type UnusablePackages = Map UnitId
763 (PackageConfig, UnusablePackageReason)
764
765 pprReason :: SDoc -> UnusablePackageReason -> SDoc
766 pprReason pref reason = case reason of
767 IgnoredWithFlag ->
768 pref <+> ptext (sLit "ignored due to an -ignore-package flag")
769 MissingDependencies is_shadowed deps ->
770 pref <+> text "unusable due to"
771 <+> (if is_shadowed then text "shadowed"
772 else text "missing or recursive")
773 <+> text "dependencies:" $$
774 nest 2 (hsep (map ppr deps))
775
776 reportUnusable :: DynFlags -> UnusablePackages -> IO ()
777 reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
778 where
779 report (ipid, (_, reason)) =
780 debugTraceMsg dflags 2 $
781 pprReason
782 (ptext (sLit "package") <+> ppr ipid <+> text "is") reason
783
784 -- ----------------------------------------------------------------------------
785 --
786 -- Detect any packages that have missing dependencies, and also any
787 -- mutually-recursive groups of packages (loops in the package graph
788 -- are not allowed). We do this by taking the least fixpoint of the
789 -- dependency graph, repeatedly adding packages whose dependencies are
790 -- satisfied until no more can be added.
791 --
792 findBroken :: IsShadowed
793 -> [PackageConfig]
794 -> Map UnitId PackageConfig
795 -> UnusablePackages
796 findBroken is_shadowed pkgs pkg_map0 = go [] pkg_map0 pkgs
797 where
798 go avail pkg_map not_avail =
799 case partitionWith (depsAvailable pkg_map) not_avail of
800 ([], not_avail) ->
801 Map.fromList [ (unitId p, (p, MissingDependencies is_shadowed deps))
802 | (p,deps) <- not_avail ]
803 (new_avail, not_avail) ->
804 go (new_avail ++ avail) pkg_map' (map fst not_avail)
805 where pkg_map' = Map.insertList
806 [ (unitId p, p) | p <- new_avail ]
807 pkg_map
808
809 depsAvailable :: InstalledPackageIndex
810 -> PackageConfig
811 -> Either PackageConfig (PackageConfig, [UnitId])
812 depsAvailable pkg_map pkg
813 | null dangling = Left pkg
814 | otherwise = Right (pkg, dangling)
815 where dangling = filter (not . (`Map.member` pkg_map)) (depends pkg)
816
817 -- -----------------------------------------------------------------------------
818 -- Ignore packages
819
820 ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
821 ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
822 where
823 doit (IgnorePackage str) =
824 case partition (matchingStr str) pkgs of
825 (ps, _) -> [ (unitId p, (p, IgnoredWithFlag))
826 | p <- ps ]
827 -- missing package is not an error for -ignore-package,
828 -- because a common usage is to -ignore-package P as
829 -- a preventative measure just in case P exists.
830 doit _ = panic "ignorePackages"
831
832 -- -----------------------------------------------------------------------------
833 -- When all the command-line options are in, we can process our package
834 -- settings and populate the package state.
835
836 mkPackageState
837 :: DynFlags
838 -> [(FilePath, [PackageConfig])] -- initial databases
839 -> [UnitId] -- preloaded packages
840 -> IO (PackageState,
841 [UnitId], -- new packages to preload
842 UnitId) -- this package, might be modified if the current
843 -- package is a wired-in package.
844
845 mkPackageState dflags0 dbs preload0 = do
846 dflags <- interpretPackageEnv dflags0
847
848 -- Compute the unit id
849 let this_package = thisPackage dflags
850
851 {-
852 Plan.
853
854 The goal is to build a single, unified package database based
855 on all of the input databases, which upholds the invariant that
856 there is only one package per any UnitId, and that there are no
857 dangling dependencies. We'll do this by successively merging
858 each input database into this unified database:
859
860 1. if an input database defines unit ID that is already in
861 the unified database, that package SHADOWS the existing
862 package in the unit database
863 * for every such shadowed package, we remove it and any
864 packages which transitively depend on it from the
865 unified datbase
866
867 2. remove packages selected by -ignore-package from input database
868
869 3. remove any packages with missing dependencies or mutually recursive
870 dependencies from the input database
871
872 4. report (with -v) any packages that were removed by steps 1-3
873
874 5. merge the input database into the unified database
875
876 Once this is all done, on the final unified database we:
877
878 1. apply flags to set exposed/hidden on the resulting packages
879 - if any flag refers to a package which was removed by 1-5, then
880 we can give an error message explaining why
881
882 2. hide any packages which are superseded by later exposed packages
883 -}
884
885 let flags = reverse (packageFlags dflags)
886 (ignore_flags, other_flags) = partition is_ignore flags
887 is_ignore IgnorePackage{} = True
888 is_ignore _ = False
889
890 let merge (pkg_map, prev_unusable) (db_path, db) = do
891 debugTraceMsg dflags 2 $
892 text "loading package database" <+> text db_path
893 forM_ (Set.toList shadow_set) $ \pkg ->
894 debugTraceMsg dflags 2 $
895 text "package" <+> ppr pkg <+>
896 text "shadows a previously defined package"
897 reportUnusable dflags unusable
898 -- NB: an unusable unit ID can become usable again
899 -- if it's validly specified in a later package stack.
900 -- Keep unusable up-to-date!
901 return (pkg_map', (prev_unusable `Map.difference` pkg_map')
902 `Map.union` unusable)
903 where -- The set of UnitIds which appear in both
904 -- db and pkgs (to be shadowed from pkgs)
905 shadow_set :: Set UnitId
906 shadow_set = foldr ins Set.empty db
907 where ins pkg s
908 -- If the package from the upper database is
909 -- in the lower database, and the ABIs don't
910 -- match...
911 | Just old_pkg <- Map.lookup (unitId pkg) pkg_map
912 , abiHash old_pkg /= abiHash pkg
913 -- ...add this unit ID to the set of unit IDs
914 -- which (transitively) should be shadowed from
915 -- the lower database.
916 = Set.insert (unitId pkg) s
917 | otherwise
918 = s
919 -- Remove shadow_set from pkg_map...
920 shadowed_pkgs0 :: [PackageConfig]
921 shadowed_pkgs0 = filter (not . (`Set.member` shadow_set) . unitId)
922 (Map.elems pkg_map)
923 -- ...and then remove anything transitively broken
924 -- this way.
925 shadowed = findBroken True shadowed_pkgs0 Map.empty
926 shadowed_pkgs :: [PackageConfig]
927 shadowed_pkgs = filter (not . (`Map.member` shadowed) . unitId)
928 shadowed_pkgs0
929
930 -- Apply ignore flags to db (TODO: could extend command line
931 -- flag format to support per-database ignore now! More useful
932 -- than what we have now.)
933 ignored = ignorePackages ignore_flags db
934 db2 = filter (not . (`Map.member` ignored) . unitId) db
935
936 -- Look for broken packages (either from ignore, or possibly
937 -- because the db was broken to begin with)
938 mk_pkg_map = Map.fromList . map (\p -> (unitId p, p))
939 broken = findBroken False db2 (mk_pkg_map shadowed_pkgs)
940 db3 = filter (not . (`Map.member` broken) . unitId) db2
941
942 unusable = shadowed `Map.union` ignored
943 `Map.union` broken
944
945 -- Now merge the sets together (NB: later overrides
946 -- earlier!)
947 pkg_map' :: Map UnitId PackageConfig
948 pkg_map' = mk_pkg_map (shadowed_pkgs ++ db3)
949
950 (pkg_map1, unusable) <- foldM merge (Map.empty, Map.empty) dbs
951 let pkgs1 = Map.elems pkg_map1
952
953 --
954 -- Calculate the initial set of packages, prior to any package flags.
955 -- This set contains the latest version of all valid (not unusable) packages,
956 -- or is empty if we have -hide-all-packages
957 --
958 let preferLater pkg pkg' =
959 case comparing packageVersion pkg pkg' of
960 GT -> pkg
961 _ -> pkg'
962 calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg
963 initial = if gopt Opt_HideAllPackages dflags
964 then emptyUFM
965 else foldl' calcInitial emptyUFM pkgs1
966 vis_map1 = foldUFM (\p vm ->
967 if exposed p
968 then addToUFM vm (packageConfigId p)
969 (True, [], fsPackageName p)
970 else vm)
971 emptyUFM initial
972
973 --
974 -- Modify the package database according to the command-line flags
975 -- (-package, -hide-package, -ignore-package, -hide-all-packages).
976 -- This needs to know about the unusable packages, since if a user tries
977 -- to enable an unusable package, we should let them know.
978 --
979 (pkgs2, vis_map2) <- foldM (applyPackageFlag dflags unusable)
980 (pkgs1, vis_map1) other_flags
981
982 --
983 -- Sort out which packages are wired in. This has to be done last, since
984 -- it modifies the unit ids of wired in packages, but when we process
985 -- package arguments we need to key against the old versions. We also
986 -- have to update the visibility map in the process.
987 --
988 (pkgs3, vis_map, wired_map) <- findWiredInPackages dflags pkgs2 vis_map2
989
990 --
991 -- Here we build up a set of the packages mentioned in -package
992 -- flags on the command line; these are called the "preload"
993 -- packages. we link these packages in eagerly. The preload set
994 -- should contain at least rts & base, which is why we pretend that
995 -- the command line contains -package rts & -package base.
996 --
997 let preload1 = [ let key = unitId p
998 in fromMaybe key (Map.lookup key wired_map)
999 | f <- flags, p <- get_exposed f ]
1000
1001 get_exposed (ExposePackage a _) = take 1 . sortByVersion
1002 . filter (matching a)
1003 $ pkgs2
1004 get_exposed _ = []
1005
1006 let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3
1007
1008 let preload2 = preload1
1009
1010 let
1011 -- add base & rts to the preload packages
1012 basicLinkedPackages
1013 | gopt Opt_AutoLinkPackages dflags
1014 = filter (flip elemUFM pkg_db)
1015 [baseUnitId, rtsUnitId]
1016 | otherwise = []
1017 -- but in any case remove the current package from the set of
1018 -- preloaded packages so that base/rts does not end up in the
1019 -- set up preloaded package when we are just building it
1020 preload3 = nub $ filter (/= this_package)
1021 $ (basicLinkedPackages ++ preload2)
1022
1023 -- Close the preload packages with their dependencies
1024 dep_preload <- closeDeps dflags pkg_db (zip preload3 (repeat Nothing))
1025 let new_dep_preload = filter (`notElem` preload0) dep_preload
1026
1027 let pstate = PackageState{
1028 preloadPackages = dep_preload,
1029 explicitPackages = foldUFM (\pkg xs ->
1030 if elemUFM (packageConfigId pkg) vis_map
1031 then packageConfigId pkg : xs
1032 else xs) [] pkg_db,
1033 pkgIdMap = pkg_db,
1034 moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db vis_map
1035 }
1036 return (pstate, new_dep_preload, this_package)
1037
1038
1039 -- -----------------------------------------------------------------------------
1040 -- | Makes the mapping from module to package info
1041
1042 mkModuleToPkgConfAll
1043 :: DynFlags
1044 -> PackageConfigMap
1045 -> VisibilityMap
1046 -> ModuleToPkgConfAll
1047 mkModuleToPkgConfAll dflags pkg_db vis_map =
1048 foldl' extend_modmap emptyMap (eltsUFM pkg_db)
1049 where
1050 emptyMap = Map.empty
1051 sing pk m _ = Map.singleton (mkModule pk m)
1052 addListTo = foldl' merge
1053 merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m
1054 setOrigins m os = fmap (const os) m
1055 extend_modmap modmap pkg = addListTo modmap theBindings
1056 where
1057 theBindings :: [(ModuleName, Map Module ModuleOrigin)]
1058 theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg)
1059 = newBindings b rns
1060 | otherwise = newBindings False []
1061
1062 newBindings :: Bool
1063 -> [(ModuleName, ModuleName)]
1064 -> [(ModuleName, Map Module ModuleOrigin)]
1065 newBindings e rns = es e ++ hiddens ++ map rnBinding rns
1066
1067 rnBinding :: (ModuleName, ModuleName)
1068 -> (ModuleName, Map Module ModuleOrigin)
1069 rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
1070 where origEntry = case lookupUFM esmap orig of
1071 Just r -> r
1072 Nothing -> throwGhcException (CmdLineError (showSDoc dflags
1073 (text "package flag: could not find module name" <+>
1074 ppr orig <+> text "in package" <+> ppr pk)))
1075
1076 es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
1077 es e = do
1078 -- TODO: signature support
1079 ExposedModule m exposedReexport _exposedSignature <- exposed_mods
1080 let (pk', m', pkg', origin') =
1081 case exposedReexport of
1082 Nothing -> (pk, m, pkg, fromExposedModules e)
1083 Just (OriginalModule pk' m') ->
1084 let pkg' = pkg_lookup pk'
1085 in (pk', m', pkg', fromReexportedModules e pkg')
1086 return (m, sing pk' m' pkg' origin')
1087
1088 esmap :: UniqFM (Map Module ModuleOrigin)
1089 esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
1090 -- be overwritten
1091
1092 hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
1093
1094 pk = packageConfigId pkg
1095 pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
1096
1097 exposed_mods = exposedModules pkg
1098 hidden_mods = hiddenModules pkg
1099
1100 -- -----------------------------------------------------------------------------
1101 -- Extracting information from the packages in scope
1102
1103 -- Many of these functions take a list of packages: in those cases,
1104 -- the list is expected to contain the "dependent packages",
1105 -- i.e. those packages that were found to be depended on by the
1106 -- current module/program. These can be auto or non-auto packages, it
1107 -- doesn't really matter. The list is always combined with the list
1108 -- of preload (command-line) packages to determine which packages to
1109 -- use.
1110
1111 -- | Find all the include directories in these and the preload packages
1112 getPackageIncludePath :: DynFlags -> [UnitId] -> IO [String]
1113 getPackageIncludePath dflags pkgs =
1114 collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
1115
1116 collectIncludeDirs :: [PackageConfig] -> [FilePath]
1117 collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
1118
1119 -- | Find all the library paths in these and the preload packages
1120 getPackageLibraryPath :: DynFlags -> [UnitId] -> IO [String]
1121 getPackageLibraryPath dflags pkgs =
1122 collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
1123
1124 collectLibraryPaths :: [PackageConfig] -> [FilePath]
1125 collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
1126
1127 -- | Find all the link options in these and the preload packages,
1128 -- returning (package hs lib options, extra library options, other flags)
1129 getPackageLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])
1130 getPackageLinkOpts dflags pkgs =
1131 collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
1132
1133 collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String])
1134 collectLinkOpts dflags ps =
1135 (
1136 concatMap (map ("-l" ++) . packageHsLibs dflags) ps,
1137 concatMap (map ("-l" ++) . extraLibraries) ps,
1138 concatMap ldOptions ps
1139 )
1140
1141 packageHsLibs :: DynFlags -> PackageConfig -> [String]
1142 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
1143 where
1144 ways0 = ways dflags
1145
1146 ways1 = filter (/= WayDyn) ways0
1147 -- the name of a shared library is libHSfoo-ghc<version>.so
1148 -- we leave out the _dyn, because it is superfluous
1149
1150 -- debug RTS includes support for -eventlog
1151 ways2 | WayDebug `elem` ways1
1152 = filter (/= WayEventLog) ways1
1153 | otherwise
1154 = ways1
1155
1156 tag = mkBuildTag (filter (not . wayRTSOnly) ways2)
1157 rts_tag = mkBuildTag ways2
1158
1159 mkDynName x
1160 | WayDyn `notElem` ways dflags = x
1161 | "HS" `isPrefixOf` x =
1162 x ++ '-':programName dflags ++ projectVersion dflags
1163 -- For non-Haskell libraries, we use the name "Cfoo". The .a
1164 -- file is libCfoo.a, and the .so is libfoo.so. That way the
1165 -- linker knows what we mean for the vanilla (-lCfoo) and dyn
1166 -- (-lfoo) ways. We therefore need to strip the 'C' off here.
1167 | Just x' <- stripPrefix "C" x = x'
1168 | otherwise
1169 = panic ("Don't understand library name " ++ x)
1170
1171 addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
1172 addSuffix other_lib = other_lib ++ (expandTag tag)
1173
1174 expandTag t | null t = ""
1175 | otherwise = '_':t
1176
1177 -- | Find all the C-compiler options in these and the preload packages
1178 getPackageExtraCcOpts :: DynFlags -> [UnitId] -> IO [String]
1179 getPackageExtraCcOpts dflags pkgs = do
1180 ps <- getPreloadPackagesAnd dflags pkgs
1181 return (concatMap ccOptions ps)
1182
1183 -- | Find all the package framework paths in these and the preload packages
1184 getPackageFrameworkPath :: DynFlags -> [UnitId] -> IO [String]
1185 getPackageFrameworkPath dflags pkgs = do
1186 ps <- getPreloadPackagesAnd dflags pkgs
1187 return (nub (filter notNull (concatMap frameworkDirs ps)))
1188
1189 -- | Find all the package frameworks in these and the preload packages
1190 getPackageFrameworks :: DynFlags -> [UnitId] -> IO [String]
1191 getPackageFrameworks dflags pkgs = do
1192 ps <- getPreloadPackagesAnd dflags pkgs
1193 return (concatMap frameworks ps)
1194
1195 -- -----------------------------------------------------------------------------
1196 -- Package Utils
1197
1198 -- | Takes a 'ModuleName', and if the module is in any package returns
1199 -- list of modules which take that name.
1200 lookupModuleInAllPackages :: DynFlags
1201 -> ModuleName
1202 -> [(Module, PackageConfig)]
1203 lookupModuleInAllPackages dflags m
1204 = case lookupModuleWithSuggestions dflags m Nothing of
1205 LookupFound a b -> [(a,b)]
1206 LookupMultiple rs -> map f rs
1207 where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags
1208 (moduleUnitId m)))
1209 _ -> []
1210
1211 -- | The result of performing a lookup
1212 data LookupResult =
1213 -- | Found the module uniquely, nothing else to do
1214 LookupFound Module PackageConfig
1215 -- | Multiple modules with the same name in scope
1216 | LookupMultiple [(Module, ModuleOrigin)]
1217 -- | No modules found, but there were some hidden ones with
1218 -- an exact name match. First is due to package hidden, second
1219 -- is due to module being hidden
1220 | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
1221 -- | Nothing found, here are some suggested different names
1222 | LookupNotFound [ModuleSuggestion] -- suggestions
1223
1224 data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
1225 | SuggestHidden ModuleName Module ModuleOrigin
1226
1227 lookupModuleWithSuggestions :: DynFlags
1228 -> ModuleName
1229 -> Maybe FastString
1230 -> LookupResult
1231 lookupModuleWithSuggestions dflags m mb_pn
1232 = case Map.lookup m (moduleToPkgConfAll pkg_state) of
1233 Nothing -> LookupNotFound suggestions
1234 Just xs ->
1235 case foldl' classify ([],[],[]) (Map.toList xs) of
1236 ([], [], []) -> LookupNotFound suggestions
1237 (_, _, [(m, _)]) -> LookupFound m (mod_pkg m)
1238 (_, _, exposed@(_:_)) -> LookupMultiple exposed
1239 (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
1240 where
1241 classify (hidden_pkg, hidden_mod, exposed) (m, origin0) =
1242 let origin = filterOrigin mb_pn (mod_pkg m) origin0
1243 x = (m, origin)
1244 in case origin of
1245 ModHidden -> (hidden_pkg, x:hidden_mod, exposed)
1246 _ | originEmpty origin -> (hidden_pkg, hidden_mod, exposed)
1247 | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed)
1248 | otherwise -> (x:hidden_pkg, hidden_mod, exposed)
1249
1250 pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags
1251 pkg_state = pkgState dflags
1252 mod_pkg = pkg_lookup . moduleUnitId
1253
1254 -- Filters out origins which are not associated with the given package
1255 -- qualifier. No-op if there is no package qualifier. Test if this
1256 -- excluded all origins with 'originEmpty'.
1257 filterOrigin :: Maybe FastString
1258 -> PackageConfig
1259 -> ModuleOrigin
1260 -> ModuleOrigin
1261 filterOrigin Nothing _ o = o
1262 filterOrigin (Just pn) pkg o =
1263 case o of
1264 ModHidden -> if go pkg then ModHidden else mempty
1265 ModOrigin { fromOrigPackage = e, fromExposedReexport = res,
1266 fromHiddenReexport = rhs }
1267 -> ModOrigin {
1268 fromOrigPackage = if go pkg then e else Nothing
1269 , fromExposedReexport = filter go res
1270 , fromHiddenReexport = filter go rhs
1271 , fromPackageFlag = False -- always excluded
1272 }
1273 where go pkg = pn == fsPackageName pkg
1274
1275 suggestions
1276 | gopt Opt_HelpfulErrors dflags =
1277 fuzzyLookup (moduleNameString m) all_mods
1278 | otherwise = []
1279
1280 all_mods :: [(String, ModuleSuggestion)] -- All modules
1281 all_mods = sortBy (comparing fst) $
1282 [ (moduleNameString m, suggestion)
1283 | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags))
1284 , suggestion <- map (getSuggestion m) (Map.toList e)
1285 ]
1286 getSuggestion name (mod, origin) =
1287 (if originVisible origin then SuggestVisible else SuggestHidden)
1288 name mod origin
1289
1290 listVisibleModuleNames :: DynFlags -> [ModuleName]
1291 listVisibleModuleNames dflags =
1292 map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags))))
1293 where visible (_, ms) = any originVisible (Map.elems ms)
1294
1295 -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
1296 -- 'PackageConfig's
1297 getPreloadPackagesAnd :: DynFlags -> [UnitId] -> IO [PackageConfig]
1298 getPreloadPackagesAnd dflags pkgids =
1299 let
1300 state = pkgState dflags
1301 pkg_map = pkgIdMap state
1302 preload = preloadPackages state
1303 pairs = zip pkgids (repeat Nothing)
1304 in do
1305 all_pkgs <- throwErr dflags (foldM (add_package pkg_map) preload pairs)
1306 return (map (getPackageDetails dflags) all_pkgs)
1307
1308 -- Takes a list of packages, and returns the list with dependencies included,
1309 -- in reverse dependency order (a package appears before those it depends on).
1310 closeDeps :: DynFlags
1311 -> PackageConfigMap
1312 -> [(UnitId, Maybe UnitId)]
1313 -> IO [UnitId]
1314 closeDeps dflags pkg_map ps
1315 = throwErr dflags (closeDepsErr pkg_map ps)
1316
1317 throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
1318 throwErr dflags m
1319 = case m of
1320 Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
1321 Succeeded r -> return r
1322
1323 closeDepsErr :: PackageConfigMap
1324 -> [(UnitId,Maybe UnitId)]
1325 -> MaybeErr MsgDoc [UnitId]
1326 closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
1327
1328 -- internal helper
1329 add_package :: PackageConfigMap
1330 -> [UnitId]
1331 -> (UnitId,Maybe UnitId)
1332 -> MaybeErr MsgDoc [UnitId]
1333 add_package pkg_db ps (p, mb_parent)
1334 | p `elem` ps = return ps -- Check if we've already added this package
1335 | otherwise =
1336 case lookupPackage' pkg_db p of
1337 Nothing -> Failed (missingPackageMsg p <>
1338 missingDependencyMsg mb_parent)
1339 Just pkg -> do
1340 -- Add the package's dependents also
1341 ps' <- foldM add_unit_key ps (depends pkg)
1342 return (p : ps')
1343 where
1344 add_unit_key ps key
1345 = add_package pkg_db ps (key, Just p)
1346
1347 missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
1348 missingPackageMsg p = ptext (sLit "unknown package:") <+> ppr p
1349
1350 missingDependencyMsg :: Maybe UnitId -> SDoc
1351 missingDependencyMsg Nothing = Outputable.empty
1352 missingDependencyMsg (Just parent)
1353 = space <> parens (ptext (sLit "dependency of") <+> ftext (unitIdFS parent))
1354
1355 -- -----------------------------------------------------------------------------
1356
1357 unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String
1358 unitIdPackageIdString dflags pkg_key
1359 | pkg_key == mainUnitId = Just "main"
1360 | otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key)
1361
1362 -- | Will the 'Name' come from a dynamically linked library?
1363 isDllName :: DynFlags -> UnitId -> Module -> Name -> Bool
1364 -- Despite the "dll", I think this function just means that
1365 -- the symbol comes from another dynamically-linked package,
1366 -- and applies on all platforms, not just Windows
1367 isDllName dflags _this_pkg this_mod name
1368 | WayDyn `notElem` ways dflags = False
1369 | Just mod <- nameModule_maybe name
1370 -- Issue #8696 - when GHC is dynamically linked, it will attempt
1371 -- to load the dynamic dependencies of object files at compile
1372 -- time for things like QuasiQuotes or
1373 -- TemplateHaskell. Unfortunately, this interacts badly with
1374 -- intra-package linking, because we don't generate indirect
1375 -- (dynamic) symbols for intra-package calls. This means that if a
1376 -- module with an intra-package call is loaded without its
1377 -- dependencies, then GHC fails to link. This is the cause of #
1378 --
1379 -- In the mean time, always force dynamic indirections to be
1380 -- generated: when the module name isn't the module being
1381 -- compiled, references are dynamic.
1382 = if mod /= this_mod
1383 then True
1384 else case dllSplit dflags of
1385 Nothing -> False
1386 Just ss ->
1387 let findMod m = let modStr = moduleNameString (moduleName m)
1388 in case find (modStr `Set.member`) ss of
1389 Just i -> i
1390 Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split")
1391 in findMod mod /= findMod this_mod
1392
1393 | otherwise = False -- no, it is not even an external name
1394
1395 -- -----------------------------------------------------------------------------
1396 -- Displaying packages
1397
1398 -- | Show (very verbose) package info
1399 pprPackages :: DynFlags -> SDoc
1400 pprPackages = pprPackagesWith pprPackageConfig
1401
1402 pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc
1403 pprPackagesWith pprIPI dflags =
1404 vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags)))
1405
1406 -- | Show simplified package info.
1407 --
1408 -- The idea is to only print package id, and any information that might
1409 -- be different from the package databases (exposure, trust)
1410 pprPackagesSimple :: DynFlags -> SDoc
1411 pprPackagesSimple = pprPackagesWith pprIPI
1412 where pprIPI ipi = let i = unitIdFS (unitId ipi)
1413 e = if exposed ipi then text "E" else text " "
1414 t = if trusted ipi then text "T" else text " "
1415 in e <> t <> text " " <> ftext i
1416
1417 -- | Show the mapping of modules to where they come from.
1418 pprModuleMap :: DynFlags -> SDoc
1419 pprModuleMap dflags =
1420 vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags))))
1421 where
1422 pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
1423 pprEntry m (m',o)
1424 | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o)
1425 | otherwise = ppr m' <+> parens (ppr o)
1426
1427 fsPackageName :: PackageConfig -> FastString
1428 fsPackageName = mkFastString . packageNameString