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, 2 years ago)
  • compiler/main/DynFlags.hs

    From d8513b811767042a130c20dcd2798bc0faabd1a6 Mon Sep 17 00:00:00 2001
    From: Paolo Capriotti <p.capriotti@gmail.com>
    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