Commit 854ab9a4 authored by simonmar's avatar simonmar

[project @ 2002-12-18 16:29:25 by simonmar]

"Auto" packages.

The big change here is that it is no longer necessary to explicitly
say '-package X' on the command line if X is a package containing
hierarchical Haskell modules.  All packages marked "auto" contribute
to the import path, so their modules are always available.  At link
time, the compiler knows which packages are actually used by the
program, and it links in only those libraries needed.

There's one exception: one-shot linking.  If you link a program using

    ghc -o prog A.o B.o ...

then you need to explicitly add -package flags for each package
required (except base & haskell98) because the compiler has no
information about the package dependencies in this case.

Package configs have a new field: auto, which is either True or False.
Non-auto packages must be mentioned on the command-line as usual.
Non-auto packages are still required for:

  - non-hierarchical libraries (to avoid polluting the module namespace)

  - packages with no Haskell content

  - if you want more than one version of a package, or packages
    providing overlapping functionality where the user must decide
    which one to use.

Doc changes to follow...
parent f6ba57ea
......@@ -571,7 +571,7 @@ cmLoadModules cmstate1 dflags mg2unsorted
valid_old_linkables
when (verb >= 2) $
putStrLn (showSDoc (text "Stable modules:"
hPutStrLn stderr (showSDoc (text "Stable modules:"
<+> sep (map (text.moduleNameUserString) stable_mods)))
-- Unload any modules which are going to be re-linked this
......@@ -646,7 +646,7 @@ cmLoadModules cmstate1 dflags mg2unsorted
hPutStrLn stderr "Warning: output was redirected with -o, but no output will be generated\nbecause there is no Main module."
-- link everything together
linkresult <- link ghci_mode dflags a_root_is_Main (hptLinkables hpt3)
linkresult <- link ghci_mode dflags a_root_is_Main hpt3
cmLoadFinish Succeeded linkresult
hpt3 modsDone ghci_mode pcs3
......@@ -673,7 +673,7 @@ cmLoadModules cmstate1 dflags mg2unsorted
cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep)
-- Link everything together
linkresult <- link ghci_mode dflags False (hptLinkables hpt4)
linkresult <- link ghci_mode dflags False hpt4
cmLoadFinish Failed linkresult
hpt4 mods_to_keep ghci_mode pcs3
......
......@@ -30,8 +30,7 @@ import ByteCodeItbls ( ItblEnv )
import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..))
import Packages
import DriverState ( v_Library_paths, v_Opt_l, getPackageConfigMap,
getStaticOpts )
import DriverState ( v_Library_paths, v_Opt_l, getStaticOpts )
import Finder ( findModule, findLinkable )
import HscTypes
import Name ( Name, nameModule, isExternalName )
......@@ -224,8 +223,8 @@ getLinkDeps hpt pit mods
} ;
-- 3. For each dependent module, find its linkable
-- This will either be in the HPT or (in the case of one-shot compilation)
-- we may need to use maybe_getFileLinkable
-- This will either be in the HPT or (in the case of one-shot
-- compilation) we may need to use maybe_getFileLinkable
lnks_needed <- mapM get_linkable mods_needed ;
return (lnks_needed, pkgs_needed) }
......
......@@ -24,19 +24,18 @@ import qualified PrintJava
import OccurAnal ( occurAnalyseBinds )
#endif
import Packages ( PackageConfig(name), packageNameString )
import DriverState ( getExplicitPackagesAnd, getPackageCIncludes )
import FastString ( unpackFS )
import DriverState ( v_HCHeader )
import Id ( Id )
import StgSyn ( StgBinding )
import AbsCSyn ( AbstractC )
import PprAbsC ( dumpRealC, writeRealC )
import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..), typeEnvTyCons )
import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..),
typeEnvTyCons, Dependencies(..) )
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn, showPass )
import Outputable
import Pretty ( Mode(..), printDoc )
import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName )
import DATA_IOREF ( readIORef, writeIORef )
import Monad ( when )
import IO
\end{code}
......@@ -51,15 +50,16 @@ import IO
\begin{code}
codeOutput :: DynFlags
-> ModGuts
-> [(StgBinding,[Id])] -- The STG program with SRTs
-> AbstractC -- Compiled abstract C
-> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
codeOutput dflags
(ModGuts {mg_module = mod_name,
mg_types = type_env,
mg_foreign = foreign_stubs,
mg_deps = deps,
mg_binds = core_binds})
stg_binds flat_abstractC
flat_abstractC
= let
tycons = typeEnvTyCons type_env
in
......@@ -71,27 +71,26 @@ codeOutput dflags
do { showPass dflags "CodeOutput"
; let filenm = dopt_OutName dflags
; stub_names <- outputForeignStubs dflags foreign_stubs
; case dopt_HscLang dflags of
HscInterpreted -> return stub_names
HscAsm -> outputAsm dflags filenm flat_abstractC
>> return stub_names
HscC -> outputC dflags filenm flat_abstractC stub_names
>> return stub_names
; stubs_exist <- outputForeignStubs dflags foreign_stubs
; case dopt_HscLang dflags of {
HscInterpreted -> return ();
HscAsm -> outputAsm dflags filenm flat_abstractC;
HscC -> outputC dflags filenm flat_abstractC stubs_exist
deps foreign_stubs;
HscJava ->
#ifdef JAVA
outputJava dflags filenm mod_name tycons core_binds
>> return stub_names
outputJava dflags filenm mod_name tycons core_binds;
#else
panic "Java support not compiled into this ghc"
panic "Java support not compiled into this ghc";
#endif
HscILX ->
#ifdef ILX
outputIlx dflags filenm mod_name tycons stg_binds
>> return stub_names
outputIlx dflags filenm mod_name tycons stg_binds;
#else
panic "ILX support not compiled into this ghc"
panic "ILX support not compiled into this ghc";
#endif
}
; return stubs_exist
}
doOutput :: String -> (Handle -> IO ()) -> IO ()
......@@ -106,11 +105,38 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
%************************************************************************
\begin{code}
outputC dflags filenm flat_absC (stub_h_exists, _)
outputC dflags filenm flat_absC
(stub_h_exists, _) dependencies (ForeignStubs _ _ ffi_decl_headers _ )
= do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
header <- readIORef v_HCHeader
-- figure out which header files to #include in the generated .hc file:
--
-- * extra_includes from packages
-- * -#include options from the cmdline and OPTIONS pragmas
-- * the _stub.h file, if there is one.
--
let packages = dep_pkgs dependencies
pkg_configs <- getExplicitPackagesAnd packages
let pkg_names = map name pkg_configs
c_includes <- getPackageCIncludes pkg_configs
let cmdline_includes = cmdlineHcIncludes dflags -- -#include options
all_headers = c_includes
++ reverse cmdline_includes
++ reverse (map unpackFS ffi_decl_headers)
-- reverse correct?
let cc_injects = unlines (map mk_include all_headers)
mk_include h_file =
case h_file of
'"':_{-"-} -> "#include "++h_file
'<':_ -> "#include "++h_file
_ -> "#include \""++h_file++"\""
doOutput filenm $ \ h -> do
hPutStr h header
hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
hPutStr h cc_injects
when stub_h_exists $
hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
writeRealC h flat_absC
......@@ -189,20 +215,11 @@ outputIlx dflags filename mod tycons stg_binds
%************************************************************************
\begin{code}
-- Turn the list of headers requested in foreign import
-- declarations into a string suitable for emission into generated
-- C code...
mkForeignHeaders headers
= unlines
. map (\fname -> "#include \"" ++ unpackFS fname ++ "\"")
. reverse
$ headers
outputForeignStubs :: DynFlags -> ForeignStubs
-> IO (Bool, -- Header file created
Bool) -- C file created
outputForeignStubs dflags NoStubs = return (False, False)
outputForeignStubs dflags (ForeignStubs h_code c_code hdrs _)
outputForeignStubs dflags (ForeignStubs h_code c_code _ _)
= do
dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export header file" stub_h_output_d
......@@ -214,15 +231,9 @@ outputForeignStubs dflags (ForeignStubs h_code c_code hdrs _)
dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export stubs" stub_c_output_d
-- Extend the list of foreign headers (used in outputC)
fhdrs <- readIORef v_HCHeader
let new_fhdrs = fhdrs ++ mkForeignHeaders hdrs
writeIORef v_HCHeader new_fhdrs
stub_c_file_exists
<- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
("#define IN_STG_CODE 0\n" ++
new_fhdrs ++
"#include \"RtsAPI.h\"\n" ++
cplusplus_hdr)
cplusplus_ftr
......
This diff is collapsed.
-----------------------------------------------------------------------------
-- $Id: DriverState.hs,v 1.87 2002/12/17 13:50:29 simonmar Exp $
-- $Id: DriverState.hs,v 1.88 2002/12/18 16:29:28 simonmar Exp $
--
-- Settings for the driver
--
......@@ -12,16 +12,13 @@ module DriverState where
#include "../includes/config.h"
#include "HsVersions.h"
import SysTools ( getTopDir )
import ParsePkgConf ( loadPackageConfig )
import Packages ( PackageConfig(..), PackageConfigMap,
PackageName, mkPackageName, packageNameString,
packageDependents,
mungePackagePaths, emptyPkgMap, extendPkgMap, lookupPkg,
basePackage, rtsPackage, haskell98Package )
import SysTools ( getTopDir )
import Packages
import CmdLineOpts
import DriverPhases
import DriverUtil
import UniqFM ( eltsUFM )
import Util
import Config
import Panic
......@@ -32,8 +29,8 @@ import EXCEPTION
import List
import Char
import Monad
import Maybe ( fromJust, isJust )
import Directory ( doesDirectoryExist )
import Maybe ( fromJust, isJust )
import Directory ( doesDirectoryExist )
-----------------------------------------------------------------------------
-- non-configured things
......@@ -452,91 +449,102 @@ addToDirList ref path
splitUp xs = return (split split_marker xs)
#endif
GLOBAL_VAR(v_HCHeader, "", String)
-----------------------------------------------------------------------------
-- Packages
------------------------
-- The PackageConfigMap is read in from the configuration file
-- It doesn't change during a run
GLOBAL_VAR(v_Package_details, emptyPkgMap, PackageConfigMap)
-- ----------------------------------------------------------------------------
-- Loading the package config file
readPackageConf :: String -> IO ()
readPackageConf conf_file = do
proto_pkg_configs <- loadPackageConfig conf_file
top_dir <- getTopDir
old_pkg_map <- readIORef v_Package_details
let pkg_configs = mungePackagePaths top_dir proto_pkg_configs
new_pkg_map = extendPkgMap old_pkg_map pkg_configs
writeIORef v_Package_details new_pkg_map
extendPackageConfigMap pkg_configs
mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
-- Replace the string "$libdir" at the beginning of a path
-- with the current libdir (obtained from the -B option).
mungePackagePaths top_dir ps = map munge_pkg ps
where
munge_pkg p = p{ import_dirs = munge_paths (import_dirs p),
include_dirs = munge_paths (include_dirs p),
library_dirs = munge_paths (library_dirs p),
framework_dirs = munge_paths (framework_dirs p) }
getPackageConfigMap :: IO PackageConfigMap
getPackageConfigMap = readIORef v_Package_details
munge_paths = map munge_path
munge_path p
| Just p' <- my_prefix_match "$libdir" p = top_dir ++ p'
| otherwise = p
------------------------
-- The package list reflects what was given as command-line options,
-- plus their dependent packages.
-- It is maintained in dependency order;
-- earlier ones depend on later ones, but not vice versa
GLOBAL_VAR(v_Packages, initPackageList, [PackageName])
getPackages :: IO [PackageName]
getPackages = readIORef v_Packages
-- -----------------------------------------------------------------------------
-- The list of packages requested on the command line
initPackageList = [haskell98Package,
basePackage,
rtsPackage]
-- The package list reflects what packages were given as command-line options,
-- plus their dependent packages. It is maintained in dependency order;
-- earlier packages may depend on later ones, but not vice versa
GLOBAL_VAR(v_ExplicitPackages, initPackageList, [PackageName])
initPackageList = [rtsPackage]
-- add a package requested from the command-line
addPackage :: String -> IO ()
addPackage package
= do { pkg_details <- getPackageConfigMap
; ps <- readIORef v_Packages
; ps' <- add_package pkg_details ps (mkPackageName package)
addPackage package = do
pkg_details <- getPackageConfigMap
ps <- readIORef v_ExplicitPackages
ps' <- add_package pkg_details ps (mkPackageName package)
-- Throws an exception if it fails
; writeIORef v_Packages ps' }
writeIORef v_ExplicitPackages ps'
-- internal helper
add_package :: PackageConfigMap -> [PackageName]
-> PackageName -> IO [PackageName]
add_package pkg_details ps p
| p `elem` ps -- Check if we've already added this package
= return ps
| Just details <- lookupPkg pkg_details p
= do { -- Add the package's dependents first
ps' <- foldM (add_package pkg_details) ps
(packageDependents details)
; return (p : ps') }
-- Add the package's dependents also
= do ps' <- foldM (add_package pkg_details) ps (packageDependents details)
return (p : ps')
| otherwise
= throwDyn (CmdLineError ("unknown package name: " ++ packageNameString p))
getPackageImportPath :: IO [String]
-- -----------------------------------------------------------------------------
-- Extracting information from the packages in scope
-- Many of these functions take a list of packages: in those cases,
-- the list is expected to contain the "dependent packages",
-- i.e. those packages that were found to be depended on by the
-- current module/program. These can be auto or non-auto packages, it
-- doesn't really matter. The list is always combined with the list
-- of explicit (command-line) packages to determine which packages to
-- use.
getPackageImportPath :: IO [String]
getPackageImportPath = do
ps <- getPackageInfo
ps <- getExplicitAndAutoPackageConfigs
-- import dirs are always derived from the 'auto'
-- packages as well as the explicit ones
return (nub (filter notNull (concatMap import_dirs ps)))
getPackageIncludePath :: IO [String]
getPackageIncludePath = do
ps <- getPackageInfo
getPackageIncludePath :: [PackageName] -> IO [String]
getPackageIncludePath pkgs = do
ps <- getExplicitPackagesAnd pkgs
return (nub (filter notNull (concatMap include_dirs ps)))
-- includes are in reverse dependency order (i.e. rts first)
getPackageCIncludes :: IO [String]
getPackageCIncludes = do
ps <- getPackageInfo
return (reverse (nub (filter notNull (concatMap c_includes ps))))
getPackageLibraryPath :: IO [String]
getPackageLibraryPath = do
ps <- getPackageInfo
getPackageCIncludes :: [PackageConfig] -> IO [String]
getPackageCIncludes pkg_configs = do
return (reverse (nub (filter notNull (concatMap c_includes pkg_configs))))
getPackageLibraryPath :: [PackageName] -> IO [String]
getPackageLibraryPath pkgs = do
ps <- getExplicitPackagesAnd pkgs
return (nub (filter notNull (concatMap library_dirs ps)))
getPackageLinkOpts :: IO [String]
getPackageLinkOpts = do
ps <- getPackageInfo
getPackageLinkOpts :: [PackageName] -> IO [String]
getPackageLinkOpts pkgs = do
ps <- getExplicitPackagesAnd pkgs
tag <- readIORef v_Build_tag
static <- readIORef v_Static
let
......@@ -580,35 +588,42 @@ getPackageLinkOpts = do
getPackageExtraGhcOpts :: IO [String]
getPackageExtraGhcOpts = do
ps <- getPackageInfo
ps <- getExplicitAndAutoPackageConfigs
return (concatMap extra_ghc_opts ps)
getPackageExtraCcOpts :: IO [String]
getPackageExtraCcOpts = do
ps <- getPackageInfo
getPackageExtraCcOpts :: [PackageName] -> IO [String]
getPackageExtraCcOpts pkgs = do
ps <- getExplicitPackagesAnd pkgs
return (concatMap extra_cc_opts ps)
#ifdef darwin_TARGET_OS
getPackageFrameworkPath :: IO [String]
getPackageFrameworkPath :: [PackageName] -> IO [String]
getPackageFrameworkPath = do
ps <- getPackageInfo
ps <- getExplicitPackagesAnd pkgs
return (nub (filter notNull (concatMap framework_dirs ps)))
getPackageFrameworks :: IO [String]
getPackageFrameworks = do
ps <- getPackageInfo
getPackageFrameworks :: [PackageName] -> IO [String]
getPackageFrameworks pkgs = do
ps <- getExplicitPackagesAnd pkgs
return (concatMap extra_frameworks ps)
#endif
getPackageInfo :: IO [PackageConfig]
getPackageInfo = do ps <- getPackages
getPackageDetails ps
getPackageDetails :: [PackageName] -> IO [PackageConfig]
getPackageDetails ps = do
pkg_details <- getPackageConfigMap
return [ pkg | Just pkg <- map (lookupPkg pkg_details) ps ]
-- -----------------------------------------------------------------------------
-- Package Utils
getExplicitPackagesAnd :: [PackageName] -> IO [PackageConfig]
getExplicitPackagesAnd pkg_names = do
pkg_map <- getPackageConfigMap
expl <- readIORef v_ExplicitPackages
all_pkgs <- foldM (add_package pkg_map) expl pkg_names
getPackageDetails all_pkgs
-- return all packages, including both the auto packages and the explicit ones
getExplicitAndAutoPackageConfigs :: IO [PackageConfig]
getExplicitAndAutoPackageConfigs = do
pkg_map <- getPackageConfigMap
let auto_packages = [ mkPackageName (name p) | p <- eltsUFM pkg_map, auto p ]
getExplicitPackagesAnd auto_packages
-----------------------------------------------------------------------------
-- Ways
......
......@@ -5,7 +5,6 @@
\begin{code}
module Finder (
initFinder, -- :: [PackageConfig] -> IO (),
flushFinderCache, -- :: IO ()
findModule, -- :: ModuleName -> IO (Maybe (Module, ModLocation))
......@@ -52,9 +51,6 @@ import Monad
-- It does *not* know which particular package a module lives in, because
-- that information is only contained in the interface file.
initFinder :: [PackageConfig] -> IO ()
initFinder pkgs = return ()
-- -----------------------------------------------------------------------------
-- The finder's cache
......
......@@ -330,7 +330,7 @@ hscFrontEnd hsc_env pcs_ch location = do {
-- PARSE
-------------------
; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
(expectJust "hscRecomp:hspp" (ml_hspp_file location))
(expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
; case maybe_parsed of {
Nothing -> return (Left (HscFail pcs_ch));
......@@ -344,7 +344,7 @@ hscFrontEnd hsc_env pcs_ch location = do {
; case maybe_tc_result of {
Nothing -> return (Left (HscFail pcs_ch));
Just tc_result -> do {
-------------------
-- DESUGAR
-------------------
......@@ -393,8 +393,7 @@ hscBackEnd dflags cg_info_ref prepd_result
------------------ Code output -----------------------
(stub_h_exists, stub_c_exists)
<- codeOutput dflags prepd_result
stg_binds abstractC
<- codeOutput dflags prepd_result abstractC
return (stub_h_exists, stub_c_exists, Nothing)
......
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
-- $Id: Main.hs,v 1.115 2002/12/17 13:50:29 simonmar Exp $
-- $Id: Main.hs,v 1.116 2002/12/18 16:29:30 simonmar Exp $
--
-- GHC Driver program
--
......@@ -23,21 +23,21 @@ import DriverPhases( objish_file )
#endif
import Finder ( initFinder )
import CompManager ( cmInit, cmLoadModules, cmDepAnal )
import HscTypes ( GhciMode(..) )
import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion )
import SysTools ( getPackageConfigPath, initSysTools, cleanTempFiles )
import Packages ( showPackages )
import Packages ( showPackages, getPackageConfigMap )
import DriverPipeline ( staticLink, doMkDLL, genPipeline, pipeLoop )
import DriverState ( buildCoreToDo, buildStgToDo,
findBuildTag, getPackageInfo, getPackageConfigMap,
findBuildTag,
getPackageExtraGhcOpts, unregFlags,
v_GhcMode, v_GhcModeFlag, GhcMode(..),
v_Keep_tmp_files, v_Ld_inputs, v_Ways,
v_OptLevel, v_Output_file, v_Output_hi,
readPackageConf, verifyOutputFiles, v_NoLink
readPackageConf, verifyOutputFiles, v_NoLink,
v_Build_tag
)
import DriverFlags ( buildStaticHscOpts,
dynamic_flags, processArgs, static_flags)
......@@ -201,9 +201,13 @@ main =
-- by module basis, using only the -fvia-C and -fasm flags. If the global
-- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect.
dyn_flags <- getDynFlags
build_tag <- readIORef v_Build_tag
let lang = case mode of
DoInteractive -> HscInterpreted
_other -> hscLang dyn_flags
_other | build_tag /= "" -> HscC
| otherwise -> hscLang dyn_flags
-- for ways other that the normal way, we must
-- compile via C.
setDynFlags (dyn_flags{ coreToDo = core_todo,
stgToDo = stg_todo,
......@@ -246,10 +250,6 @@ main =
when (verb >= 3)
(hPutStrLn stderr ("Hsc static flags: " ++ unwords static_opts))
-- initialise the finder
pkg_avails <- getPackageInfo
initFinder pkg_avails
-- mkdependHS is special
when (mode == DoMkDependHS) beginMkDependHS
......@@ -304,10 +304,15 @@ main =
o_files <- mapM compileFile srcs
when (mode == DoMkDependHS) endMkDependHS
omit_linking <- readIORef v_NoLink
when (mode == DoLink && not omit_linking)
(staticLink o_files [basePackage, haskell98Package])
-- we always link in the base package in one-shot linking.
-- any other packages required must be given using -package
-- options on the command-line.
when (mode == DoMkDependHS) endMkDependHS
when (mode == DoLink && not omit_linking) (staticLink o_files)
when (mode == DoMkDLL) (doMkDLL o_files)
......
......@@ -7,36 +7,33 @@
module Packages (
PackageConfig(..),
defaultPackageConfig,
mungePackagePaths, packageDependents,
packageDependents,
showPackages,
PackageName, -- Instance of Outputable
mkPackageName, packageNameString,
basePackage, rtsPackage, haskell98Package, thPackage, -- :: PackageName
basePackage, rtsPackage, haskell98Package, thPackage, -- :: PackageName
PackageConfigMap, emptyPkgMap, extendPkgMap, lookupPkg
PackageConfigMap, emptyPkgMap, lookupPkg,
extendPackageConfigMap, getPackageDetails, getPackageConfigMap,
)
where
#include "HsVersions.h"
import Pretty
import CmdLineOpts ( dynFlag, verbosity )
import DriverUtil ( my_prefix_match )
import ErrUtils ( dumpIfSet )
import Outputable ( docToSDoc )
import FastString
import UniqFM
\end{code}
import Util
import Pretty
%*********************************************************
%* *
\subsection{Basic data types}
%* *
%*********************************************************
import DATA_IOREF
-- -----------------------------------------------------------------------------
-- The PackageConfig type
\begin{code}
#define WANT_PRETTY
#define INTERNAL_PRETTY
-- Yes, do generate pretty-printing stuff for packages, and use our
......@@ -44,14 +41,13 @@ import UniqFM
-- There's a blob of code shared with ghc-pkg,
-- so we just include it from there
-- Primarily it defines
-- PackageConfig (a record)
-- PackageName (FastString)
-- Primarily it defines PackageConfig (a record)
#include "../utils/ghc-pkg/Package.hs"
\end{code}
\begin{code}
-- -----------------------------------------------------------------------------
-- Package names
type PackageName = FastString -- No encoding at all
mkPackageName :: String -> PackageName
......@@ -70,14 +66,14 @@ packageDependents :: PackageConfig -> [PackageName]
-- Impedence matcher, because PackageConfig has Strings
-- not PackageNames at the moment. Sigh.
packageDependents pkg = map mkPackageName (package_deps pkg)
\end{code}
A PackageConfigMap maps a PackageName to a PackageConfig
-- -----------------------------------------------------------------------------
-- A PackageConfigMap maps a PackageName to a PackageConfig
\begin{code}
type PackageConfigMap = UniqFM PackageConfig
lookupPkg :: PackageConfigMap -> PackageName -> Maybe PackageConfig
emptyPkgMap :: PackageConfigMap
emptyPkgMap = emptyUFM
......@@ -88,40 +84,26 @@ extendPkgMap pkg_map new_pkgs
= foldl add pkg_map new_pkgs
where
add pkg_map p = addToUFM pkg_map (mkFastString (name p)) p
\end{code}
%*********************************************************
%* *
\subsection{Load the config file}
%* *
%*********************************************************
GLOBAL_VAR(v_Package_details, emptyPkgMap, PackageConfigMap)
\begin{code}
mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
-- Replace the string "$libdir" at the beginning of a path
-- with the current libdir (obtained from the -B option).
mungePackagePaths top_dir ps = map munge_pkg ps
where
munge_pkg p = p{ import_dirs = munge_paths (import_dirs p),
include_dirs = munge_paths (include_dirs p),
library_dirs = munge_paths (library_dirs p),
framework_dirs = munge_paths (framework_dirs p) }
munge_paths = map munge_path
munge_path p
| Just p' <- my_prefix_match "$libdir" p = top_dir ++ p'
| otherwise = p
\end{code}
getPackageConfigMap :: IO PackageConfigMap
getPackageConfigMap = readIORef v_Package_details
extendPackageConfigMap :: [PackageConfig] -> IO ()
extendPackageConfigMap pkg_configs = do
old_pkg_map <- readIORef v_Package_details
writeIORef v_Package_details (extendPkgMap old_pkg_map pkg_configs)
%*********************************************************
%* *
\subsection{Display results}
%* *
%*********************************************************
getPackageDetails :: [PackageName] -> IO [PackageConfig]
getPackageDetails ps = do
pkg_details <- getPackageConfigMap
return [ pkg | Just pkg <- map (lookupPkg pkg_details) ps ]
-- -----------------------------------------------------------------------------
-- Displaying packages
\begin{code}
showPackages :: PackageConfigMap -> IO ()
-- Show package info on console, if verbosity is >= 3
showPackages pkg_map
......@@ -131,4 +113,5 @@ showPackages pkg_map
}
where
ps = eltsUFM pkg_map
\end{code}
......@@ -52,6 +52,11 @@ field :: { PackageConfig -> PackageConfig }
"name" -> returnP (\ p -> p{name = unpackFS $3});
_ -> happyError } }
| VARID '=' bool
{\p -> case unpackFS $1 of {
"auto" -> p{auto = $3};