ae2669edcdfde7cc324b9ec62ef5261505039fad
[ghc.git] / compiler / main / Packages.lhs
1 %
2 % (c) The University of Glasgow, 2006
3 %
4 \begin{code}
5 {-# LANGUAGE CPP, ScopedTypeVariables #-}
6
7 -- | Package manipulation
8 module Packages (
9         module PackageConfig,
10
11         -- * Reading the package config, and processing cmdline args
12         PackageState(preloadPackages),
13         initPackages,
14
15         -- * Querying the package config
16         lookupPackage,
17         resolveInstalledPackageId,
18         searchPackageId,
19         dumpPackages,
20         simpleDumpPackages,
21         getPackageDetails,
22         listVisibleModuleNames,
23         lookupModuleInAllPackages,
24         lookupModuleWithSuggestions,
25         LookupResult(..),
26         ModuleSuggestion(..),
27         ModuleOrigin(..),
28
29         -- * Inspecting the set of packages in scope
30         getPackageIncludePath,
31         getPackageLibraryPath,
32         getPackageLinkOpts,
33         getPackageExtraCcOpts,
34         getPackageFrameworkPath,
35         getPackageFrameworks,
36         getPreloadPackagesAnd,
37
38         collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
39         packageHsLibs,
40         ModuleExport(..),
41
42         -- * Utils
43         packageKeyPackageIdString,
44         pprFlag,
45         pprModuleMap,
46         isDllName
47     )
48 where
49
50 #include "HsVersions.h"
51
52 import PackageConfig
53 import DynFlags
54 import Config           ( cProjectVersion )
55 import Name             ( Name, nameModule_maybe )
56 import UniqFM
57 import Module
58 import Util
59 import Panic
60 import Outputable
61 import Maybes
62
63 import System.Environment ( getEnv )
64 import GHC.PackageDb (readPackageDbForGhcPkg)
65 import Distribution.InstalledPackageInfo
66 import Distribution.InstalledPackageInfo.Binary ()
67 import Distribution.Package hiding (depends, PackageKey, mkPackageKey)
68 import Distribution.ModuleExport
69 import FastString
70 import ErrUtils         ( debugTraceMsg, putMsg, MsgDoc )
71 import Exception
72 import Unique
73
74 import System.Directory
75 import System.FilePath as FilePath
76 import qualified System.FilePath.Posix as FilePath.Posix
77 import Control.Monad
78 import Data.List as List
79 import Data.Map (Map)
80 import Data.Monoid hiding ((<>))
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 -- | When we do a plain lookup (e.g. for an import), initially, all we want
217 -- to know is if we can find it or not (and if we do and it's a reexport,
218 -- what the real name is).  If the find fails, we'll want to investigate more
219 -- to give a good error message.
220 data SimpleModuleConf =
221     SModConf Module PackageConfig ModuleOrigin
222   | SModConfAmbiguous
223
224 -- | 'UniqFM' map from 'ModuleName'
225 type ModuleNameMap = UniqFM
226
227 -- | 'UniqFM' map from 'PackageKey'
228 type PackageKeyMap = UniqFM
229
230 -- | 'UniqFM' map from 'PackageKey' to 'PackageConfig'
231 type PackageConfigMap = PackageKeyMap PackageConfig
232
233 -- | 'UniqFM' map from 'PackageKey' to (1) whether or not all modules which
234 -- are exposed should be dumped into scope, (2) any custom renamings that
235 -- should also be apply, and (3) what package name is associated with the
236 -- key, if it might be hidden
237 type VisibilityMap =
238     PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString)
239
240 -- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
241 -- in scope.  The 'PackageConf' is not cached, mostly for convenience reasons
242 -- (since this is the slow path, we'll just look it up again).
243 type ModuleToPkgConfAll =
244     Map ModuleName (Map Module ModuleOrigin)
245
246 data PackageState = PackageState {
247   -- | A mapping of 'PackageKey' to 'PackageConfig'.  This list is adjusted
248   -- so that only valid packages are here.  Currently, we also flip the
249   -- exposed/trusted bits based on package flags; however, the hope is to
250   -- stop doing that.
251   pkgIdMap              :: PackageConfigMap,
252
253   -- | The packages we're going to link in eagerly.  This list
254   -- should be in reverse dependency order; that is, a package
255   -- is always mentioned before the packages it depends on.
256   preloadPackages      :: [PackageKey],
257
258   -- | This is a simplified map from 'ModuleName' to original 'Module' and
259   -- package configuration providing it.
260   moduleToPkgConf       :: ModuleNameMap SimpleModuleConf,
261
262   -- | This is a full map from 'ModuleName' to all modules which may possibly
263   -- be providing it.  These providers may be hidden (but we'll still want
264   -- to report them in error messages), or it may be an ambiguous import.
265   moduleToPkgConfAll    :: ModuleToPkgConfAll,
266
267   -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC
268   -- internally deals in package keys but the database may refer to installed
269   -- package IDs.
270   installedPackageIdMap :: InstalledPackageIdMap
271   }
272
273 type InstalledPackageIdMap = Map InstalledPackageId PackageKey
274 type InstalledPackageIndex = Map InstalledPackageId PackageConfig
275
276 -- | Empty package configuration map
277 emptyPackageConfigMap :: PackageConfigMap
278 emptyPackageConfigMap = emptyUFM
279
280 -- | Find the package we know about with the given key (e.g. @foo_HASH@), if any
281 lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig
282 lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))
283
284 lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig
285 lookupPackage' = lookupUFM
286
287 -- | Search for packages with a given package ID (e.g. \"foo-0.1\")
288 searchPackageId :: DynFlags -> PackageId -> [PackageConfig]
289 searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
290                                (listPackageConfigMap dflags)
291
292 -- | Extends the package configuration map with a list of package configs.
293 extendPackageConfigMap
294    :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
295 extendPackageConfigMap pkg_map new_pkgs
296   = foldl add pkg_map new_pkgs
297   where add pkg_map p = addToUFM pkg_map (packageConfigId p) p
298
299 -- | Looks up the package with the given id in the package state, panicing if it is
300 -- not found
301 getPackageDetails :: DynFlags -> PackageKey -> PackageConfig
302 getPackageDetails dflags pid =
303     expectJust "getPackageDetails" (lookupPackage dflags pid)
304
305 -- | Get a list of entries from the package database.  NB: be careful with
306 -- this function, it may not do what you expect it to.
307 listPackageConfigMap :: DynFlags -> [PackageConfig]
308 listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags))
309
310 -- | Looks up a 'PackageKey' given an 'InstalledPackageId'
311 resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey
312 resolveInstalledPackageId dflags ipid =
313     expectJust "resolveInstalledPackageId"
314         (Map.lookup ipid (installedPackageIdMap (pkgState dflags)))
315
316 -- ----------------------------------------------------------------------------
317 -- Loading the package db files and building up the package state
318
319 -- | Call this after 'DynFlags.parseDynFlags'.  It reads the package
320 -- database files, and sets up various internal tables of package
321 -- information, according to the package-related flags on the
322 -- command-line (@-package@, @-hide-package@ etc.)
323 --
324 -- Returns a list of packages to link in if we're doing dynamic linking.
325 -- This list contains the packages that the user explicitly mentioned with
326 -- @-package@ flags.
327 --
328 -- 'initPackages' can be called again subsequently after updating the
329 -- 'packageFlags' field of the 'DynFlags', and it will update the
330 -- 'pkgState' in 'DynFlags' and return a list of packages to
331 -- link in.
332 initPackages :: DynFlags -> IO (DynFlags, [PackageKey])
333 initPackages dflags = do
334   pkg_db <- case pkgDatabase dflags of
335                 Nothing -> readPackageConfigs dflags
336                 Just db -> return $ setBatchPackageFlags dflags db
337   (pkg_state, preload, this_pkg)
338         <- mkPackageState dflags pkg_db [] (thisPackage dflags)
339   return (dflags{ pkgDatabase = Just pkg_db,
340                   pkgState = pkg_state,
341                   thisPackage = this_pkg },
342           preload)
343
344 -- -----------------------------------------------------------------------------
345 -- Reading the package database(s)
346
347 readPackageConfigs :: DynFlags -> IO [PackageConfig]
348 readPackageConfigs dflags = do
349   let system_conf_refs = [UserPkgConf, GlobalPkgConf]
350
351   e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH")
352   let base_conf_refs = case e_pkg_path of
353         Left _ -> system_conf_refs
354         Right path
355          | null (last cs)
356          -> map PkgConfFile (init cs) ++ system_conf_refs
357          | otherwise
358          -> map PkgConfFile cs
359          where cs = parseSearchPath path
360          -- if the path ends in a separator (eg. "/foo/bar:")
361          -- then we tack on the system paths.
362
363   let conf_refs = reverse (extraPkgConfs dflags base_conf_refs)
364   -- later packages shadow earlier ones.  extraPkgConfs
365   -- is in the opposite order to the flags on the
366   -- command line.
367   confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
368
369   liftM concat $ mapM (readPackageConfig dflags) confs
370
371 resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
372 resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
373 resolvePackageConfig _ UserPkgConf = handleIO (\_ -> return Nothing) $ do
374   appdir <- getAppUserDataDirectory "ghc"
375   let dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
376       pkgconf = dir </> "package.conf.d"
377   exist <- doesDirectoryExist pkgconf
378   return $ if exist then Just pkgconf else Nothing
379 resolvePackageConfig _ (PkgConfFile name) = return $ Just name
380
381 readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
382 readPackageConfig dflags conf_file = do
383   isdir <- doesDirectoryExist conf_file
384
385   proto_pkg_configs <-
386     if isdir
387        then do let filename = conf_file </> "package.cache"
388                debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
389                conf <- readPackageDbForGhcPkg filename
390                -- TODO readPackageDbForGhc ^^ instead
391                return (map installedPackageInfoToPackageConfig conf)
392
393        else do
394             isfile <- doesFileExist conf_file
395             if isfile
396                then throwGhcExceptionIO $ InstallationError $
397                       "ghc no longer supports single-file style package databases (" ++
398                       conf_file ++
399                       ") use 'ghc-pkg init' to create the database with the correct format."
400                else throwGhcExceptionIO $ InstallationError $
401                       "can't find a package database at " ++ conf_file
402
403   let
404       top_dir = topDir dflags
405       pkgroot = takeDirectory conf_file
406       pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
407       pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
408   --
409   return pkg_configs2
410
411 setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
412 setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
413   where
414     maybeDistrustAll pkgs'
415       | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
416       | otherwise                           = pkgs'
417
418     distrust pkg = pkg{ trusted = False }
419
420 -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
421 mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
422 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
423 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
424 -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
425 -- The "pkgroot" is the directory containing the package database.
426 --
427 -- Also perform a similar substitution for the older GHC-specific
428 -- "$topdir" variable. The "topdir" is the location of the ghc
429 -- installation (obtained from the -B option).
430 mungePackagePaths top_dir pkgroot pkg =
431     pkg {
432       importDirs  = munge_paths (importDirs pkg),
433       includeDirs = munge_paths (includeDirs pkg),
434       libraryDirs = munge_paths (libraryDirs pkg),
435       frameworkDirs = munge_paths (frameworkDirs pkg),
436       haddockInterfaces = munge_paths (haddockInterfaces pkg),
437       haddockHTMLs = munge_urls (haddockHTMLs pkg)
438     }
439   where
440     munge_paths = map munge_path
441     munge_urls  = map munge_url
442
443     munge_path p
444       | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
445       | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
446       | otherwise                                = p
447
448     munge_url p
449       | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
450       | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
451       | otherwise                                   = p
452
453     toUrlPath r p = "file:///"
454                  -- URLs always use posix style '/' separators:
455                  ++ FilePath.Posix.joinPath
456                         (r : -- We need to drop a leading "/" or "\\"
457                              -- if there is one:
458                              dropWhile (all isPathSeparator)
459                                        (FilePath.splitDirectories p))
460
461     -- We could drop the separator here, and then use </> above. However,
462     -- by leaving it in and using ++ we keep the same path separator
463     -- rather than letting FilePath change it to use \ as the separator
464     stripVarPrefix var path = case stripPrefix var path of
465                               Just [] -> Just []
466                               Just cs@(c : _) | isPathSeparator c -> Just cs
467                               _ -> Nothing
468
469
470 -- -----------------------------------------------------------------------------
471 -- Modify our copy of the package database based on a package flag
472 -- (-package, -hide-package, -ignore-package).
473
474 -- | A horrible hack, the problem is the package key we'll turn
475 -- up here is going to get edited when we select the wired in
476 -- packages, so preemptively pick up the right one.  Also, this elem
477 -- test is slow.  The alternative is to change wired in packages first, but
478 -- then we are no longer able to match against package keys e.g. from when
479 -- a user passes in a package flag.
480 calcKey :: PackageConfig -> PackageKey
481 calcKey p | pk <- display (pkgName (sourcePackageId p))
482           , pk `elem` wired_in_pkgids
483                       = stringToPackageKey pk
484           | otherwise = packageConfigId p
485
486 applyPackageFlag
487    :: DynFlags
488    -> UnusablePackages
489    -> ([PackageConfig], VisibilityMap)           -- Initial database
490    -> PackageFlag               -- flag to apply
491    -> IO ([PackageConfig], VisibilityMap)        -- new database
492
493 -- ToDo: Unfortunately, we still have to plumb the package config through,
494 -- because Safe Haskell trust is still implemented by modifying the database.
495 -- Eventually, track that separately and then axe @[PackageConfig]@ from
496 -- this fold entirely
497
498 applyPackageFlag dflags unusable (pkgs, vm) flag =
499   case flag of
500     ExposePackage arg m_rns ->
501        case selectPackages (matching arg) pkgs unusable of
502          Left ps         -> packageFlagErr dflags flag ps
503          Right (p:_,_) -> return (pkgs, vm')
504           where
505            n = fsPackageName p
506            vm' = addToUFM_C edit vm_cleared (calcKey p)
507                               (case m_rns of
508                                    Nothing   -> (True, [], n)
509                                    Just rns' -> (False, map convRn rns', n))
510            edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
511            convRn (a,b) = (mkModuleName a, mkModuleName b)
512            -- ToDo: ATM, -hide-all-packages implicitly triggers change in
513            -- behavior, maybe eventually make it toggleable with a separate
514            -- flag
515            vm_cleared | gopt Opt_HideAllPackages dflags = vm
516                       -- NB: -package foo-0.1 (Foo as Foo1) does NOT hide
517                       -- other versions of foo. Presence of renaming means
518                       -- user probably wanted both.
519                       | Just _ <- m_rns = vm
520                       | otherwise = filterUFM_Directly
521                             (\k (_,_,n') -> k == getUnique (calcKey p)
522                                                 || n /= n') vm
523          _ -> panic "applyPackageFlag"
524
525     HidePackage str ->
526        case selectPackages (matchingStr str) pkgs unusable of
527          Left ps       -> packageFlagErr dflags flag ps
528          Right (ps,_) -> return (pkgs, vm')
529           where vm' = delListFromUFM vm (map calcKey ps)
530
531     -- we trust all matching packages. Maybe should only trust first one?
532     -- and leave others the same or set them untrusted
533     TrustPackage str ->
534        case selectPackages (matchingStr str) pkgs unusable of
535          Left ps       -> packageFlagErr dflags flag ps
536          Right (ps,qs) -> return (map trust ps ++ qs, vm)
537           where trust p = p {trusted=True}
538
539     DistrustPackage str ->
540        case selectPackages (matchingStr str) pkgs unusable of
541          Left ps       -> packageFlagErr dflags flag ps
542          Right (ps,qs) -> return (map distrust ps ++ qs, vm)
543           where distrust p = p {trusted=False}
544
545     IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage"
546
547 selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
548                -> UnusablePackages
549                -> Either [(PackageConfig, UnusablePackageReason)]
550                   ([PackageConfig], [PackageConfig])
551 selectPackages matches pkgs unusable
552   = let (ps,rest) = partition matches pkgs
553     in if null ps
554         then Left (filter (matches.fst) (Map.elems unusable))
555         else Right (sortByVersion ps, rest)
556
557 -- A package named on the command line can either include the
558 -- version, or just the name if it is unambiguous.
559 matchingStr :: String -> PackageConfig -> Bool
560 matchingStr str p
561         =  str == display (sourcePackageId p)
562         || str == display (pkgName (sourcePackageId p))
563
564 matchingId :: String -> PackageConfig -> Bool
565 matchingId str p =  InstalledPackageId str == installedPackageId p
566
567 matchingKey :: String -> PackageConfig -> Bool
568 matchingKey str p = str == display (packageKey p)
569
570 matching :: PackageArg -> PackageConfig -> Bool
571 matching (PackageArg str) = matchingStr str
572 matching (PackageIdArg str) = matchingId str
573 matching (PackageKeyArg str) = matchingKey str
574
575 sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m]
576 sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId)))
577
578 comparing :: Ord a => (t -> a) -> t -> t -> Ordering
579 comparing f a b = f a `compare` f b
580
581 packageFlagErr :: DynFlags
582                -> PackageFlag
583                -> [(PackageConfig, UnusablePackageReason)]
584                -> IO a
585
586 -- for missing DPH package we emit a more helpful error message, because
587 -- this may be the result of using -fdph-par or -fdph-seq.
588 packageFlagErr dflags (ExposePackage (PackageArg pkg) _) []
589   | is_dph_package pkg
590   = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
591   where dph_err = text "the " <> text pkg <> text " package is not installed."
592                   $$ text "To install it: \"cabal install dph\"."
593         is_dph_package pkg = "dph" `isPrefixOf` pkg
594
595 packageFlagErr dflags flag reasons
596   = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
597   where err = text "cannot satisfy " <> pprFlag flag <>
598                 (if null reasons then empty else text ": ") $$
599               nest 4 (ppr_reasons $$
600                       -- ToDo: this admonition seems a bit dodgy
601                       text "(use -v for more information)")
602         ppr_reasons = vcat (map ppr_reason reasons)
603         ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason
604
605 pprFlag :: PackageFlag -> SDoc
606 pprFlag flag = case flag of
607     IgnorePackage p -> text "-ignore-package " <> text p
608     HidePackage p   -> text "-hide-package " <> text p
609     ExposePackage a rns -> ppr_arg a <> ppr_rns rns
610     TrustPackage p    -> text "-trust " <> text p
611     DistrustPackage p -> text "-distrust " <> text p
612   where ppr_arg arg = case arg of
613                      PackageArg    p -> text "-package " <> text p
614                      PackageIdArg  p -> text "-package-id " <> text p
615                      PackageKeyArg p -> text "-package-key " <> text p
616         ppr_rns Nothing = empty
617         ppr_rns (Just rns) = char '(' <> hsep (punctuate comma (map ppr_rn rns))
618                                       <> char ')'
619         ppr_rn (orig, new) | orig == new = text orig
620                            | otherwise = text orig <+> text "as" <+> text new
621
622 -- -----------------------------------------------------------------------------
623 -- Wired-in packages
624
625 wired_in_pkgids :: [String]
626 wired_in_pkgids = map packageKeyString wiredInPackageKeys
627
628 findWiredInPackages
629    :: DynFlags
630    -> [PackageConfig]           -- database
631    -> IO [PackageConfig]
632
633 findWiredInPackages dflags pkgs = do
634   --
635   -- Now we must find our wired-in packages, and rename them to
636   -- their canonical names (eg. base-1.0 ==> base).
637   --
638   let
639         matches :: PackageConfig -> String -> Bool
640         pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid
641
642         -- find which package corresponds to each wired-in package
643         -- delete any other packages with the same name
644         -- update the package and any dependencies to point to the new
645         -- one.
646         --
647         -- When choosing which package to map to a wired-in package
648         -- name, we pick the latest version (modern Cabal makes it difficult
649         -- to install multiple versions of wired-in packages, however!)
650         -- To override the default choice, -ignore-package could be used to
651         -- hide newer versions.
652         --
653         findWiredInPackage :: [PackageConfig] -> String
654                            -> IO (Maybe InstalledPackageId)
655         findWiredInPackage pkgs wired_pkg =
656            let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
657            case all_ps of
658                 []   -> notfound
659                 many -> pick (head (sortByVersion many))
660           where
661                 notfound = do
662                           debugTraceMsg dflags 2 $
663                             ptext (sLit "wired-in package ")
664                                  <> text wired_pkg
665                                  <> ptext (sLit " not found.")
666                           return Nothing
667                 pick :: InstalledPackageInfo_ ModuleName
668                      -> IO (Maybe InstalledPackageId)
669                 pick pkg = do
670                         debugTraceMsg dflags 2 $
671                             ptext (sLit "wired-in package ")
672                                  <> text wired_pkg
673                                  <> ptext (sLit " mapped to ")
674                                  <> pprIPkg pkg
675                         return (Just (installedPackageId pkg))
676
677
678   mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids
679   let
680         wired_in_ids = catMaybes mb_wired_in_ids
681
682         -- this is old: we used to assume that if there were
683         -- multiple versions of wired-in packages installed that
684         -- they were mutually exclusive.  Now we're assuming that
685         -- you have one "main" version of each wired-in package
686         -- (the latest version), and the others are backward-compat
687         -- wrappers that depend on this one.  e.g. base-4.0 is the
688         -- latest, base-3.0 is a compat wrapper depending on base-4.0.
689         {-
690         deleteOtherWiredInPackages pkgs = filterOut bad pkgs
691           where bad p = any (p `matches`) wired_in_pkgids
692                       && package p `notElem` map fst wired_in_ids
693         -}
694
695         updateWiredInDependencies pkgs = map upd_pkg pkgs
696           where upd_pkg p
697                   | installedPackageId p `elem` wired_in_ids
698                   = let pid = (sourcePackageId p) { pkgVersion = Version [] [] }
699                     in p { packageKey = OldPackageKey pid }
700                   | otherwise
701                   = p
702
703   return $ updateWiredInDependencies pkgs
704
705 -- ----------------------------------------------------------------------------
706
707 data UnusablePackageReason
708   = IgnoredWithFlag
709   | MissingDependencies [InstalledPackageId]
710   | ShadowedBy InstalledPackageId
711
712 type UnusablePackages = Map InstalledPackageId
713                             (PackageConfig, UnusablePackageReason)
714
715 pprReason :: SDoc -> UnusablePackageReason -> SDoc
716 pprReason pref reason = case reason of
717   IgnoredWithFlag ->
718       pref <+> ptext (sLit "ignored due to an -ignore-package flag")
719   MissingDependencies deps ->
720       pref <+>
721       ptext (sLit "unusable due to missing or recursive dependencies:") $$
722         nest 2 (hsep (map (text.display) deps))
723   ShadowedBy ipid ->
724       pref <+> ptext (sLit "shadowed by package ") <> text (display ipid)
725
726 reportUnusable :: DynFlags -> UnusablePackages -> IO ()
727 reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
728   where
729     report (ipid, (_, reason)) =
730        debugTraceMsg dflags 2 $
731          pprReason
732            (ptext (sLit "package") <+>
733             text (display ipid) <+> text "is") reason
734
735 -- ----------------------------------------------------------------------------
736 --
737 -- Detect any packages that have missing dependencies, and also any
738 -- mutually-recursive groups of packages (loops in the package graph
739 -- are not allowed).  We do this by taking the least fixpoint of the
740 -- dependency graph, repeatedly adding packages whose dependencies are
741 -- satisfied until no more can be added.
742 --
743 findBroken :: [PackageConfig] -> UnusablePackages
744 findBroken pkgs = go [] Map.empty pkgs
745  where
746    go avail ipids not_avail =
747      case partitionWith (depsAvailable ipids) not_avail of
748         ([], not_avail) ->
749             Map.fromList [ (installedPackageId p, (p, MissingDependencies deps))
750                          | (p,deps) <- not_avail ]
751         (new_avail, not_avail) ->
752             go (new_avail ++ avail) new_ipids (map fst not_avail)
753             where new_ipids = Map.insertList
754                                 [ (installedPackageId p, p) | p <- new_avail ]
755                                 ipids
756
757    depsAvailable :: InstalledPackageIndex
758                  -> PackageConfig
759                  -> Either PackageConfig (PackageConfig, [InstalledPackageId])
760    depsAvailable ipids pkg
761         | null dangling = Left pkg
762         | otherwise     = Right (pkg, dangling)
763         where dangling = filter (not . (`Map.member` ipids)) (depends pkg)
764
765 -- -----------------------------------------------------------------------------
766 -- Eliminate shadowed packages, giving the user some feedback
767
768 -- later packages in the list should shadow earlier ones with the same
769 -- package name/version.  Additionally, a package may be preferred if
770 -- it is in the transitive closure of packages selected using -package-id
771 -- flags.
772 shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
773 shadowPackages pkgs preferred
774  = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
775    in  Map.fromList shadowed
776  where
777  check (shadowed,pkgmap) pkg
778       | Just oldpkg <- lookupUFM pkgmap pkgid
779       , let
780             ipid_new = installedPackageId pkg
781             ipid_old = installedPackageId oldpkg
782         --
783       , ipid_old /= ipid_new
784       = if ipid_old `elem` preferred
785            then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap)
786            else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap')
787       | otherwise
788       = (shadowed, pkgmap')
789       where
790         pkgid = mkFastString (display (sourcePackageId pkg))
791         pkgmap' = addToUFM pkgmap pkgid pkg
792
793 -- -----------------------------------------------------------------------------
794
795 ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
796 ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
797   where
798   doit (IgnorePackage str) =
799      case partition (matchingStr str) pkgs of
800          (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag))
801                     | p <- ps ]
802         -- missing package is not an error for -ignore-package,
803         -- because a common usage is to -ignore-package P as
804         -- a preventative measure just in case P exists.
805   doit _ = panic "ignorePackages"
806
807 -- -----------------------------------------------------------------------------
808
809 depClosure :: InstalledPackageIndex
810            -> [InstalledPackageId]
811            -> [InstalledPackageId]
812 depClosure index ipids = closure Map.empty ipids
813   where
814    closure set [] = Map.keys set
815    closure set (ipid : ipids)
816      | ipid `Map.member` set = closure set ipids
817      | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set)
818                                                  (depends p ++ ipids)
819      | otherwise = closure set ipids
820
821 -- -----------------------------------------------------------------------------
822 -- When all the command-line options are in, we can process our package
823 -- settings and populate the package state.
824
825 mkPackageState
826     :: DynFlags
827     -> [PackageConfig]          -- initial database
828     -> [PackageKey]              -- preloaded packages
829     -> PackageKey                -- this package
830     -> IO (PackageState,
831            [PackageKey],         -- new packages to preload
832            PackageKey) -- this package, might be modified if the current
833                       -- package is a wired-in package.
834
835 mkPackageState dflags pkgs0 preload0 this_package = do
836
837 {-
838    Plan.
839
840    1. P = transitive closure of packages selected by -package-id
841
842    2. Apply shadowing.  When there are multiple packages with the same
843       packageKey,
844         * if one is in P, use that one
845         * otherwise, use the one highest in the package stack
846       [
847        rationale: we cannot use two packages with the same packageKey
848        in the same program, because packageKey is the symbol prefix.
849        Hence we must select a consistent set of packages to use.  We have
850        a default algorithm for doing this: packages higher in the stack
851        shadow those lower down.  This default algorithm can be overriden
852        by giving explicit -package-id flags; then we have to take these
853        preferences into account when selecting which other packages are
854        made available.
855
856        Our simple algorithm throws away some solutions: there may be other
857        consistent sets that would satisfy the -package flags, but it's
858        not GHC's job to be doing constraint solving.
859       ]
860
861    3. remove packages selected by -ignore-package
862
863    4. remove any packages with missing dependencies, or mutually recursive
864       dependencies.
865
866    5. report (with -v) any packages that were removed by steps 2-4
867
868    6. apply flags to set exposed/hidden on the resulting packages
869       - if any flag refers to a package which was removed by 2-4, then
870         we can give an error message explaining why
871
872    7. hide any packages which are superseded by later exposed packages
873 -}
874
875   let
876       flags = reverse (packageFlags dflags)
877
878       -- pkgs0 with duplicate packages filtered out.  This is
879       -- important: it is possible for a package in the global package
880       -- DB to have the same IPID as a package in the user DB, and
881       -- we want the latter to take precedence.  This is not the same
882       -- as shadowing (below), since in this case the two packages
883       -- have the same ABI and are interchangeable.
884       --
885       -- #4072: note that we must retain the ordering of the list here
886       -- so that shadowing behaves as expected when we apply it later.
887       pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0
888           where del p (s,ps)
889                   | pid `Set.member` s = (s,ps)
890                   | otherwise          = (Set.insert pid s, p:ps)
891                   where pid = installedPackageId p
892           -- XXX this is just a variant of nub
893
894       ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]
895
896       ipid_selected = depClosure ipid_map
897                                  [ InstalledPackageId i
898                                  | ExposePackage (PackageIdArg i) _ <- flags ]
899
900       (ignore_flags, other_flags) = partition is_ignore flags
901       is_ignore IgnorePackage{} = True
902       is_ignore _ = False
903
904       shadowed = shadowPackages pkgs0_unique ipid_selected
905       ignored  = ignorePackages ignore_flags pkgs0_unique
906
907       isBroken = (`Map.member` (Map.union shadowed ignored)).installedPackageId
908       pkgs0' = filter (not . isBroken) pkgs0_unique
909
910       broken   = findBroken pkgs0'
911
912       unusable = shadowed `Map.union` ignored `Map.union` broken
913       pkgs1 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs0'
914
915   reportUnusable dflags unusable
916
917   --
918   -- Calculate the initial set of packages, prior to any package flags.
919   -- This set contains the latest version of all valid (not unusable) packages,
920   -- or is empty if we have -hide-all-packages
921   --
922   let preferLater pkg pkg' =
923         case comparing (pkgVersion.sourcePackageId) pkg pkg' of
924             GT -> pkg
925             _  -> pkg'
926       calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg
927       initial = if gopt Opt_HideAllPackages dflags
928                     then emptyUFM
929                     else foldl' calcInitial emptyUFM pkgs1
930       vis_map0 = foldUFM (\p vm ->
931                             if exposed p
932                                then addToUFM vm (calcKey p)
933                                              (True, [], fsPackageName p)
934                                else vm)
935                          emptyUFM initial
936
937   --
938   -- Modify the package database according to the command-line flags
939   -- (-package, -hide-package, -ignore-package, -hide-all-packages).
940   -- This needs to know about the unusable packages, since if a user tries
941   -- to enable an unusable package, we should let them know.
942   --
943   (pkgs2, vis_map) <- foldM (applyPackageFlag dflags unusable)
944                             (pkgs1, vis_map0) other_flags
945
946   --
947   -- Sort out which packages are wired in. This has to be done last, since
948   -- it modifies the package keys of wired in packages, but when we process
949   -- package arguments we need to key against the old versions.
950   --
951   pkgs3 <- findWiredInPackages dflags pkgs2
952
953   --
954   -- Here we build up a set of the packages mentioned in -package
955   -- flags on the command line; these are called the "preload"
956   -- packages.  we link these packages in eagerly.  The preload set
957   -- should contain at least rts & base, which is why we pretend that
958   -- the command line contains -package rts & -package base.
959   --
960   let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]
961
962       get_exposed (ExposePackage a _) = take 1 . sortByVersion
963                                       . filter (matching a)
964                                       $ pkgs2
965       get_exposed _                 = []
966
967   let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3
968
969       ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
970                               | p <- pkgs3 ]
971
972       lookupIPID ipid@(InstalledPackageId str)
973          | Just pid <- Map.lookup ipid ipid_map = return pid
974          | otherwise                            = missingPackageErr dflags str
975
976   preload2 <- mapM lookupIPID preload1
977
978   let
979       -- add base & rts to the preload packages
980       basicLinkedPackages
981        | gopt Opt_AutoLinkPackages dflags
982           = filter (flip elemUFM pkg_db)
983                 [basePackageKey, rtsPackageKey]
984        | otherwise = []
985       -- but in any case remove the current package from the set of
986       -- preloaded packages so that base/rts does not end up in the
987       -- set up preloaded package when we are just building it
988       preload3 = nub $ filter (/= this_package)
989                      $ (basicLinkedPackages ++ preload2)
990
991   -- Close the preload packages with their dependencies
992   dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing))
993   let new_dep_preload = filter (`notElem` preload0) dep_preload
994
995   let pstate = PackageState{
996     preloadPackages     = dep_preload,
997     pkgIdMap            = pkg_db,
998     moduleToPkgConf     = mkModuleToPkgConf dflags pkg_db ipid_map vis_map,
999     moduleToPkgConfAll  = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map,
1000     installedPackageIdMap = ipid_map
1001     }
1002   return (pstate, new_dep_preload, this_package)
1003
1004
1005 -- -----------------------------------------------------------------------------
1006 -- | Makes the mapping from module to package info
1007
1008 -- | This function is generic; we instantiate it
1009 mkModuleToPkgConfGeneric
1010   :: forall m e.
1011      -- Empty map, e.g. the initial state of the output
1012      m e
1013      -- How to create an entry in the map based on the calculated information
1014   -> (PackageKey -> ModuleName -> PackageConfig -> ModuleOrigin -> e)
1015      -- How to override the origin of an entry (used for renaming)
1016   -> (e -> ModuleOrigin -> e)
1017      -- How to incorporate a list of entries into the map
1018   -> (m e -> [(ModuleName, e)] -> m e)
1019   -- The proper arguments
1020   -> DynFlags
1021   -> PackageConfigMap
1022   -> InstalledPackageIdMap
1023   -> VisibilityMap
1024   -> m e
1025 mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
1026                          dflags pkg_db ipid_map vis_map =
1027     foldl' extend_modmap emptyMap (eltsUFM pkg_db)
1028  where
1029   extend_modmap modmap pkg = addListTo modmap theBindings
1030    where
1031     theBindings :: [(ModuleName, e)]
1032     theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg)
1033                               = newBindings b rns
1034                 | otherwise   = newBindings False []
1035
1036     newBindings :: Bool -> [(ModuleName, ModuleName)] -> [(ModuleName, e)]
1037     newBindings e rns  = es e ++ hiddens ++ map rnBinding rns
1038
1039     rnBinding :: (ModuleName, ModuleName) -> (ModuleName, e)
1040     rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)
1041      where origEntry = case lookupUFM esmap orig of
1042             Just r -> r
1043             Nothing -> throwGhcException (CmdLineError (showSDoc dflags
1044                         (text "package flag: could not find module name" <+>
1045                             ppr orig <+> text "in package" <+> ppr pk)))
1046
1047     es :: Bool -> [(ModuleName, e)]
1048     es e =
1049      [(m, sing pk  m  pkg  (fromExposedModules e)) | m <- exposed_mods] ++
1050      [(m, sing pk' m' pkg' (fromReexportedModules e pkg))
1051      | ModuleExport{ exportName = m
1052                    , exportCachedTrueOrig = Just (ipid', m')} <- reexported_mods
1053      , let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
1054            pkg' = pkg_lookup pk' ]
1055
1056     esmap :: UniqFM e
1057     esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
1058                                  -- be overwritten
1059
1060     hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
1061
1062     pk = packageConfigId pkg
1063     pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
1064
1065     exposed_mods = exposedModules pkg
1066     reexported_mods = reexportedModules pkg
1067     hidden_mods = hiddenModules pkg
1068
1069 -- | This is a quick and efficient module map, which only contains an entry
1070 -- if it is specified unambiguously.
1071 mkModuleToPkgConf
1072   :: DynFlags
1073   -> PackageConfigMap
1074   -> InstalledPackageIdMap
1075   -> VisibilityMap
1076   -> ModuleNameMap SimpleModuleConf
1077 mkModuleToPkgConf =
1078   mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
1079     where emptyMap = emptyUFM
1080           sing pk m pkg = SModConf (mkModule pk m) pkg
1081           -- NB: don't put hidden entries in the map, they're not valid!
1082           addListTo m xs = addListToUFM_C merge m (filter isVisible xs)
1083           isVisible (_, SModConf _ _ o) = originVisible o
1084           isVisible (_, SModConfAmbiguous) = False
1085           merge (SModConf m pkg o) (SModConf m' _ o')
1086               | m == m' = SModConf m pkg (o `mappend` o')
1087               | otherwise = SModConfAmbiguous
1088           merge _ _ = SModConfAmbiguous
1089           setOrigins (SModConf m pkg _) os = SModConf m pkg os
1090           setOrigins SModConfAmbiguous _ = SModConfAmbiguous
1091
1092 -- | This is a slow and complete map, which includes information about
1093 -- everything, including hidden modules
1094 mkModuleToPkgConfAll
1095   :: DynFlags
1096   -> PackageConfigMap
1097   -> InstalledPackageIdMap
1098   -> VisibilityMap
1099   -> ModuleToPkgConfAll
1100 mkModuleToPkgConfAll =
1101   mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
1102     where emptyMap = Map.empty
1103           sing pk m _ = Map.singleton (mkModule pk m)
1104           addListTo = foldl' merge
1105           merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m
1106           setOrigins m os = fmap (const os) m
1107
1108 pprIPkg :: PackageConfig -> SDoc
1109 pprIPkg p = text (display (installedPackageId p))
1110
1111 -- -----------------------------------------------------------------------------
1112 -- Extracting information from the packages in scope
1113
1114 -- Many of these functions take a list of packages: in those cases,
1115 -- the list is expected to contain the "dependent packages",
1116 -- i.e. those packages that were found to be depended on by the
1117 -- current module/program.  These can be auto or non-auto packages, it
1118 -- doesn't really matter.  The list is always combined with the list
1119 -- of preload (command-line) packages to determine which packages to
1120 -- use.
1121
1122 -- | Find all the include directories in these and the preload packages
1123 getPackageIncludePath :: DynFlags -> [PackageKey] -> IO [String]
1124 getPackageIncludePath dflags pkgs =
1125   collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
1126
1127 collectIncludeDirs :: [PackageConfig] -> [FilePath]
1128 collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
1129
1130 -- | Find all the library paths in these and the preload packages
1131 getPackageLibraryPath :: DynFlags -> [PackageKey] -> IO [String]
1132 getPackageLibraryPath dflags pkgs =
1133   collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
1134
1135 collectLibraryPaths :: [PackageConfig] -> [FilePath]
1136 collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
1137
1138 -- | Find all the link options in these and the preload packages,
1139 -- returning (package hs lib options, extra library options, other flags)
1140 getPackageLinkOpts :: DynFlags -> [PackageKey] -> IO ([String], [String], [String])
1141 getPackageLinkOpts dflags pkgs =
1142   collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
1143
1144 collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String])
1145 collectLinkOpts dflags ps =
1146     (
1147         concatMap (map ("-l" ++) . packageHsLibs dflags) ps,
1148         concatMap (map ("-l" ++) . extraLibraries) ps,
1149         concatMap ldOptions ps
1150     )
1151
1152 packageHsLibs :: DynFlags -> PackageConfig -> [String]
1153 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
1154   where
1155         ways0 = ways dflags
1156
1157         ways1 = filter (/= WayDyn) ways0
1158         -- the name of a shared library is libHSfoo-ghc<version>.so
1159         -- we leave out the _dyn, because it is superfluous
1160
1161         -- debug RTS includes support for -eventlog
1162         ways2 | WayDebug `elem` ways1
1163               = filter (/= WayEventLog) ways1
1164               | otherwise
1165               = ways1
1166
1167         tag     = mkBuildTag (filter (not . wayRTSOnly) ways2)
1168         rts_tag = mkBuildTag ways2
1169
1170         mkDynName x
1171          | gopt Opt_Static dflags       = x
1172          | "HS" `isPrefixOf` x          = x ++ "-ghc" ++ cProjectVersion
1173            -- For non-Haskell libraries, we use the name "Cfoo". The .a
1174            -- file is libCfoo.a, and the .so is libfoo.so. That way the
1175            -- linker knows what we mean for the vanilla (-lCfoo) and dyn
1176            -- (-lfoo) ways. We therefore need to strip the 'C' off here.
1177          | Just x' <- stripPrefix "C" x = x'
1178          | otherwise
1179             = panic ("Don't understand library name " ++ x)
1180
1181         addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)
1182         addSuffix other_lib      = other_lib ++ (expandTag tag)
1183
1184         expandTag t | null t = ""
1185                     | otherwise = '_':t
1186
1187 -- | Find all the C-compiler options in these and the preload packages
1188 getPackageExtraCcOpts :: DynFlags -> [PackageKey] -> IO [String]
1189 getPackageExtraCcOpts dflags pkgs = do
1190   ps <- getPreloadPackagesAnd dflags pkgs
1191   return (concatMap ccOptions ps)
1192
1193 -- | Find all the package framework paths in these and the preload packages
1194 getPackageFrameworkPath  :: DynFlags -> [PackageKey] -> IO [String]
1195 getPackageFrameworkPath dflags pkgs = do
1196   ps <- getPreloadPackagesAnd dflags pkgs
1197   return (nub (filter notNull (concatMap frameworkDirs ps)))
1198
1199 -- | Find all the package frameworks in these and the preload packages
1200 getPackageFrameworks  :: DynFlags -> [PackageKey] -> IO [String]
1201 getPackageFrameworks dflags pkgs = do
1202   ps <- getPreloadPackagesAnd dflags pkgs
1203   return (concatMap frameworks ps)
1204
1205 -- -----------------------------------------------------------------------------
1206 -- Package Utils
1207
1208 -- | Takes a 'ModuleName', and if the module is in any package returns
1209 -- list of modules which take that name.
1210 lookupModuleInAllPackages :: DynFlags
1211                           -> ModuleName
1212                           -> [(Module, PackageConfig)]
1213 lookupModuleInAllPackages dflags m
1214   = case lookupModuleWithSuggestions dflags m Nothing of
1215       LookupFound a b -> [(a,b)]
1216       LookupMultiple rs -> map f rs
1217         where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags
1218                                                          (modulePackageKey m)))
1219       _ -> []
1220
1221 -- | The result of performing a lookup
1222 data LookupResult =
1223     -- | Found the module uniquely, nothing else to do
1224     LookupFound Module PackageConfig
1225     -- | Multiple modules with the same name in scope
1226   | LookupMultiple [(Module, ModuleOrigin)]
1227     -- | No modules found, but there were some hidden ones with
1228     -- an exact name match.  First is due to package hidden, second
1229     -- is due to module being hidden
1230   | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
1231     -- | Nothing found, here are some suggested different names
1232   | LookupNotFound [ModuleSuggestion] -- suggestions
1233
1234 data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
1235                       | SuggestHidden ModuleName Module ModuleOrigin
1236
1237 lookupModuleWithSuggestions :: DynFlags
1238                             -> ModuleName
1239                             -> Maybe FastString
1240                             -> LookupResult
1241 lookupModuleWithSuggestions dflags m mb_pn
1242   = case lookupUFM (moduleToPkgConf pkg_state) m of
1243      Just (SModConf m pkg o) | matches mb_pn pkg o ->
1244         ASSERT( originVisible o ) LookupFound m pkg
1245      _ -> case Map.lookup m (moduleToPkgConfAll pkg_state) of
1246         Nothing -> LookupNotFound suggestions
1247         Just xs ->
1248           case foldl' classify ([],[],[]) (Map.toList xs) of
1249             ([], [], []) -> LookupNotFound suggestions
1250             -- NB: Yes, we have to check this case too, since package qualified
1251             -- imports could cause the main lookup to fail due to ambiguity,
1252             -- but the second lookup to succeed.
1253             (_, _, [(m, _)])             -> LookupFound m (mod_pkg m)
1254             (_, _, exposed@(_:_))        -> LookupMultiple exposed
1255             (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
1256   where
1257     classify (hidden_pkg, hidden_mod, exposed) (m, origin0) =
1258       let origin = filterOrigin mb_pn (mod_pkg m) origin0
1259           x = (m, origin)
1260       in case origin of
1261           ModHidden                  -> (hidden_pkg,   x:hidden_mod, exposed)
1262           _ | originEmpty origin     -> (hidden_pkg,   hidden_mod,   exposed)
1263             | originVisible origin   -> (hidden_pkg,   hidden_mod,   x:exposed)
1264             | otherwise              -> (x:hidden_pkg, hidden_mod,   exposed)
1265
1266     pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags
1267     pkg_state = pkgState dflags
1268     mod_pkg = pkg_lookup . modulePackageKey
1269
1270     matches Nothing _ _ = True -- shortcut for efficiency
1271     matches mb_pn pkg o = originVisible (filterOrigin mb_pn pkg o)
1272
1273     -- Filters out origins which are not associated with the given package
1274     -- qualifier.  No-op if there is no package qualifier.  Test if this
1275     -- excluded all origins with 'originEmpty'.
1276     filterOrigin :: Maybe FastString
1277                  -> PackageConfig
1278                  -> ModuleOrigin
1279                  -> ModuleOrigin
1280     filterOrigin Nothing _ o = o
1281     filterOrigin (Just pn) pkg o =
1282       case o of
1283           ModHidden -> if go pkg then ModHidden else mempty
1284           ModOrigin { fromOrigPackage = e, fromExposedReexport = res,
1285                       fromHiddenReexport = rhs }
1286             -> ModOrigin {
1287                   fromOrigPackage = if go pkg then e else Nothing
1288                 , fromExposedReexport = filter go res
1289                 , fromHiddenReexport = filter go rhs
1290                 , fromPackageFlag = False -- always excluded
1291                 }
1292       where go pkg = pn == fsPackageName pkg
1293
1294     suggestions
1295       | gopt Opt_HelpfulErrors dflags =
1296            fuzzyLookup (moduleNameString m) all_mods
1297       | otherwise = []
1298
1299     all_mods :: [(String, ModuleSuggestion)]     -- All modules
1300     all_mods = sortBy (comparing fst) $
1301         [ (moduleNameString m, suggestion)
1302         | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags))
1303         , suggestion <- map (getSuggestion m) (Map.toList e)
1304         ]
1305     getSuggestion name (mod, origin) =
1306         (if originVisible origin then SuggestVisible else SuggestHidden)
1307             name mod origin
1308
1309 listVisibleModuleNames :: DynFlags -> [ModuleName]
1310 listVisibleModuleNames dflags =
1311     Map.keys (moduleToPkgConfAll (pkgState dflags))
1312
1313 -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
1314 -- 'PackageConfig's
1315 getPreloadPackagesAnd :: DynFlags -> [PackageKey] -> IO [PackageConfig]
1316 getPreloadPackagesAnd dflags pkgids =
1317   let
1318       state   = pkgState dflags
1319       pkg_map = pkgIdMap state
1320       ipid_map = installedPackageIdMap state
1321       preload = preloadPackages state
1322       pairs = zip pkgids (repeat Nothing)
1323   in do
1324   all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs)
1325   return (map (getPackageDetails dflags) all_pkgs)
1326
1327 -- Takes a list of packages, and returns the list with dependencies included,
1328 -- in reverse dependency order (a package appears before those it depends on).
1329 closeDeps :: DynFlags
1330           -> PackageConfigMap
1331           -> Map InstalledPackageId PackageKey
1332           -> [(PackageKey, Maybe PackageKey)]
1333           -> IO [PackageKey]
1334 closeDeps dflags pkg_map ipid_map ps
1335     = throwErr dflags (closeDepsErr pkg_map ipid_map ps)
1336
1337 throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
1338 throwErr dflags m
1339               = case m of
1340                 Failed e    -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
1341                 Succeeded r -> return r
1342
1343 closeDepsErr :: PackageConfigMap
1344              -> Map InstalledPackageId PackageKey
1345              -> [(PackageKey,Maybe PackageKey)]
1346              -> MaybeErr MsgDoc [PackageKey]
1347 closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
1348
1349 -- internal helper
1350 add_package :: PackageConfigMap
1351             -> Map InstalledPackageId PackageKey
1352             -> [PackageKey]
1353             -> (PackageKey,Maybe PackageKey)
1354             -> MaybeErr MsgDoc [PackageKey]
1355 add_package pkg_db ipid_map ps (p, mb_parent)
1356   | p `elem` ps = return ps     -- Check if we've already added this package
1357   | otherwise =
1358       case lookupPackage' pkg_db p of
1359         Nothing -> Failed (missingPackageMsg (packageKeyString p) <>
1360                            missingDependencyMsg mb_parent)
1361         Just pkg -> do
1362            -- Add the package's dependents also
1363            ps' <- foldM add_package_ipid ps (depends pkg)
1364            return (p : ps')
1365           where
1366             add_package_ipid ps ipid@(InstalledPackageId str)
1367               | Just pid <- Map.lookup ipid ipid_map
1368               = add_package pkg_db ipid_map ps (pid, Just p)
1369               | otherwise
1370               = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent)
1371
1372 missingPackageErr :: DynFlags -> String -> IO a
1373 missingPackageErr dflags p
1374     = throwGhcExceptionIO (CmdLineError (showSDoc dflags (missingPackageMsg p)))
1375
1376 missingPackageMsg :: String -> SDoc
1377 missingPackageMsg p = ptext (sLit "unknown package:") <+> text p
1378
1379 missingDependencyMsg :: Maybe PackageKey -> SDoc
1380 missingDependencyMsg Nothing = empty
1381 missingDependencyMsg (Just parent)
1382   = space <> parens (ptext (sLit "dependency of") <+> ftext (packageKeyFS parent))
1383
1384 -- -----------------------------------------------------------------------------
1385
1386 packageKeyPackageIdString :: DynFlags -> PackageKey -> String
1387 packageKeyPackageIdString dflags pkg_key
1388     | pkg_key == mainPackageKey = "main"
1389     | otherwise = maybe "(unknown)"
1390                       (display . sourcePackageId)
1391                       (lookupPackage dflags pkg_key)
1392
1393 -- | Will the 'Name' come from a dynamically linked library?
1394 isDllName :: DynFlags -> PackageKey -> Module -> Name -> Bool
1395 -- Despite the "dll", I think this function just means that
1396 -- the synbol comes from another dynamically-linked package,
1397 -- and applies on all platforms, not just Windows
1398 isDllName dflags _this_pkg this_mod name
1399   | gopt Opt_Static dflags = False
1400   | Just mod <- nameModule_maybe name
1401     -- Issue #8696 - when GHC is dynamically linked, it will attempt
1402     -- to load the dynamic dependencies of object files at compile
1403     -- time for things like QuasiQuotes or
1404     -- TemplateHaskell. Unfortunately, this interacts badly with
1405     -- intra-package linking, because we don't generate indirect
1406     -- (dynamic) symbols for intra-package calls. This means that if a
1407     -- module with an intra-package call is loaded without its
1408     -- dependencies, then GHC fails to link. This is the cause of #
1409     --
1410     -- In the mean time, always force dynamic indirections to be
1411     -- generated: when the module name isn't the module being
1412     -- compiled, references are dynamic.
1413     = if mod /= this_mod
1414       then True
1415       else case dllSplit dflags of
1416            Nothing -> False
1417            Just ss ->
1418                let findMod m = let modStr = moduleNameString (moduleName m)
1419                                in case find (modStr `Set.member`) ss of
1420                                   Just i -> i
1421                                   Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split")
1422                in findMod mod /= findMod this_mod
1423        
1424   | otherwise = False  -- no, it is not even an external name
1425
1426 -- -----------------------------------------------------------------------------
1427 -- Displaying packages
1428
1429 -- | Show (very verbose) package info on console, if verbosity is >= 5
1430 dumpPackages :: DynFlags -> IO ()
1431 dumpPackages = dumpPackages' showInstalledPackageInfo
1432
1433 dumpPackages' :: (InstalledPackageInfo -> String) -> DynFlags -> IO ()
1434 dumpPackages' showIPI dflags
1435   = do putMsg dflags $
1436              vcat (map (text . showIPI
1437                              . packageConfigToInstalledPackageInfo)
1438                        (listPackageConfigMap dflags))
1439
1440 -- | Show simplified package info on console, if verbosity == 4.
1441 -- The idea is to only print package id, and any information that might
1442 -- be different from the package databases (exposure, trust)
1443 simpleDumpPackages :: DynFlags -> IO ()
1444 simpleDumpPackages = dumpPackages' showIPI
1445     where showIPI ipi = let InstalledPackageId i = installedPackageId ipi
1446                             e = if exposed ipi then "E" else " "
1447                             t = if trusted ipi then "T" else " "
1448                         in e ++ t ++ "  " ++ i
1449
1450 -- | Show the mapping of modules to where they come from.
1451 pprModuleMap :: DynFlags -> SDoc
1452 pprModuleMap dflags =
1453   vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags))))
1454     where
1455       pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e)))
1456       pprEntry m (m',o)
1457         | m == moduleName m' = ppr (modulePackageKey m') <+> parens (ppr o)
1458         | otherwise = ppr m' <+> parens (ppr o)
1459
1460 fsPackageName :: PackageConfig -> FastString
1461 fsPackageName pkg = case packageName (sourcePackageId pkg) of
1462     PackageName n -> mkFastString n
1463
1464 \end{code}