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