Ticket #5977: 0001-Add-flags-to-manipulate-package-db-stack-5977.patch

File 0001-Add-flags-to-manipulate-package-db-stack-5977.patch, 7.5 KB (added by pcapriotti, 3 years ago)
  • compiler/main/DynFlags.hs

    From d8513b811767042a130c20dcd2798bc0faabd1a6 Mon Sep 17 00:00:00 2001
    From: Paolo Capriotti <[email protected]>
    Date: Thu, 3 May 2012 11:29:51 +0100
    Subject: [PATCH 1/3] Add flags to manipulate package db stack (#5977)
    
    ---
     compiler/main/DynFlags.hs  |   24 +++++++++++--
     compiler/main/Packages.lhs |   81 +++++++++++++++++++++-----------------------
     2 files changed, 60 insertions(+), 45 deletions(-)
    
    diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
    index a497ded..f49da93 100644
    a b module DynFlags ( 
    3838        GhcMode(..), isOneShot,
    3939        GhcLink(..), isNoLink,
    4040        PackageFlag(..),
     41        PkgConfRef(..),
    4142        Option(..), showOpt,
    4243        DynLibLoader(..),
    4344        fFlags, fWarningFlags, fLangFlags, xFlags,
    data DynFlag 
    275276   | Opt_ForceRecomp
    276277   | Opt_ExcessPrecision
    277278   | Opt_EagerBlackHoling
     279   | Opt_ReadGlobalPackageConf
    278280   | Opt_ReadUserPackageConf
    279281   | Opt_NoHsMain
    280282   | Opt_SplitObjs
    data DynFlags = DynFlags { 
    548550  depSuffixes           :: [String],
    549551
    550552  --  Package flags
    551   extraPkgConfs         :: [FilePath],
     553  extraPkgConfs         :: [PkgConfRef],
    552554        -- ^ The @-package-conf@ flags given on the command line, in the order
    553555        -- they appeared.
    554556
    dynamic_flags = [ 
    17551757package_flags :: [Flag (CmdLineP DynFlags)]
    17561758package_flags = [
    17571759        ------- Packages ----------------------------------------------------
    1758     Flag "package-conf"          (HasArg extraPkgConf_)
     1760    Flag "package-conf"          (HasArg (extraPkgConf_ . PkgConfFile))
     1761  , Flag "clear-package-conf"    (NoArg clearPkgConf)
     1762  , Flag "no-global-package-conf" (NoArg (unSetDynFlag Opt_ReadGlobalPackageConf))
    17591763  , Flag "no-user-package-conf"  (NoArg (unSetDynFlag Opt_ReadUserPackageConf))
     1764  , Flag "global-package-conf"   (NoArg (extraPkgConf_ GlobalPkgConf))
     1765  , Flag "user-package-conf"     (NoArg (extraPkgConf_ UserPkgConf))
     1766
    17601767  , Flag "package-name"          (hasArg setPackageName)
    17611768  , Flag "package-id"            (HasArg exposePackageId)
    17621769  , Flag "package"               (HasArg exposePackage)
    xFlags = [ 
    20662073defaultFlags :: [DynFlag]
    20672074defaultFlags
    20682075  = [ Opt_AutoLinkPackages,
     2076      Opt_ReadGlobalPackageConf,
    20692077      Opt_ReadUserPackageConf,
    20702078
    20712079      Opt_SharedImplib,
    setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) 
    24042412addCmdlineHCInclude :: String -> DynP ()
    24052413addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes =  a : cmdlineHcIncludes s})
    24062414
    2407 extraPkgConf_ :: FilePath -> DynP ()
     2415data PkgConfRef
     2416  = GlobalPkgConf
     2417  | UserPkgConf
     2418  | PkgConfFile FilePath
     2419
     2420extraPkgConf_ :: PkgConfRef -> DynP ()
    24082421extraPkgConf_  p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s })
    24092422
     2423clearPkgConf :: DynP ()
     2424clearPkgConf = do
     2425  unSetDynFlag Opt_ReadGlobalPackageConf
     2426  unSetDynFlag Opt_ReadUserPackageConf
     2427
    24102428exposePackage, exposePackageId, hidePackage, ignorePackage,
    24112429        trustPackage, distrustPackage :: String -> DynP ()
    24122430exposePackage p =
  • compiler/main/Packages.lhs

    diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
    index aa5a432..12aefc0 100644
    a b getPackageDetails :: PackageState -> PackageId -> PackageConfig 
    152152getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid)
    153153
    154154-- ----------------------------------------------------------------------------
    155 -- Loading the package config files and building up the package state
     155-- Loading the package db files and building up the package state
    156156
    157157-- | Call this after 'DynFlags.parseDynFlags'.  It reads the package
    158 -- configuration files, and sets up various internal tables of package
     158-- database files, and sets up various internal tables of package
    159159-- information, according to the package-related flags on the
    160160-- command-line (@-package@, @-hide-package@ etc.)
    161161--
    initPackages dflags = do 
    184184
    185185readPackageConfigs :: DynFlags -> IO [PackageConfig]
    186186readPackageConfigs dflags = do
    187    e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH")
    188    system_pkgconfs <- getSystemPackageConfigs dflags
    189 
    190    let pkgconfs = case e_pkg_path of
    191                     Left _   -> system_pkgconfs
    192                     Right path
    193                      | last cs == "" -> init cs ++ system_pkgconfs
    194                      | otherwise     -> cs
    195                      where cs = parseSearchPath path
    196                      -- if the path ends in a separator (eg. "/foo/bar:")
    197                      -- the we tack on the system paths.
    198 
    199    pkgs <- mapM (readPackageConfig dflags)
    200                 (pkgconfs ++ reverse (extraPkgConfs dflags))
    201                 -- later packages shadow earlier ones.  extraPkgConfs
    202                 -- is in the opposite order to the flags on the
    203                 -- command line.
    204 
    205    return (concat pkgs)
    206 
    207 
    208 getSystemPackageConfigs :: DynFlags -> IO [FilePath]
    209 getSystemPackageConfigs dflags = do
    210    -- System one always comes first
    211    let system_pkgconf = systemPackageConfig dflags
    212 
    213    -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
    214    -- unless the -no-user-package-conf flag was given.
    215    user_pkgconf <- do
    216       if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do
    217       appdir <- getAppUserDataDirectory "ghc"
    218       let
    219          dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
    220          pkgconf = dir </> "package.conf.d"
    221       --
    222       exist <- doesDirectoryExist pkgconf
    223       if exist then return [pkgconf] else return []
    224     `catchIO` (\_ -> return [])
    225 
    226    return (system_pkgconf : user_pkgconf)
     187  let -- Read global package db, unless the -no-user-package-conf flag was given
     188      global_conf_refs = [GlobalPkgConf | dopt Opt_ReadGlobalPackageConf dflags]
     189      -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
     190      -- unless the -no-user-package-conf flag was given.
     191      user_conf_refs = [UserPkgConf | dopt Opt_ReadUserPackageConf dflags]
     192
     193      system_conf_refs = global_conf_refs ++ user_conf_refs
     194
     195  e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH")
     196  let base_conf_refs = case e_pkg_path of
     197        Left _ -> system_conf_refs
     198        Right path
     199         | null (last cs)
     200         -> map PkgConfFile (init cs) ++ system_conf_refs
     201         | otherwise
     202         -> map PkgConfFile cs
     203         where cs = parseSearchPath path
     204         -- if the path ends in a separator (eg. "/foo/bar:")
     205         -- the we tack on the base paths.
     206
     207  let conf_refs = base_conf_refs ++ reverse (extraPkgConfs dflags)
     208  -- later packages shadow earlier ones.  extraPkgConfs
     209  -- is in the opposite order to the flags on the
     210  -- command line.
     211  confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
     212
     213  liftM concat $ mapM (readPackageConfig dflags) confs
     214
     215resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
     216resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
     217resolvePackageConfig _ UserPkgConf = handleIO (\_ -> return Nothing) $ do
     218  appdir <- getAppUserDataDirectory "ghc"
     219  let dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
     220      pkgconf = dir </> "package.conf.d"
     221  exist <- doesDirectoryExist pkgconf
     222  return $ if exist then Just pkgconf else Nothing
     223resolvePackageConfig _ (PkgConfFile name) = return $ Just name
    227224
    228225readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
    229226readPackageConfig dflags conf_file = do