Commit ea717aa4 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Factorize mungePackagePaths code

This patch factorizes the duplicated code used in ghc-pkg and in GHC to
munge package paths/urls.

It also fixes haddock-html munging in GHC (allowed to be either a file
or a url) to mimic ghc-pkg behavior.
parent 9e2c8e0e
......@@ -94,7 +94,6 @@ import GHC.Utils.Exception
import System.Directory
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import Control.Monad
import Data.Graph (stronglyConnComp, SCC(..))
import Data.Char ( toUpper )
......@@ -656,7 +655,7 @@ mungeUnitInfo :: FilePath -> FilePath
-> UnitInfo -> UnitInfo
mungeUnitInfo top_dir pkgroot =
mungeDynLibFields
. mungePackagePaths top_dir pkgroot
. mungeUnitInfoPaths top_dir pkgroot
mungeDynLibFields :: UnitInfo -> UnitInfo
mungeDynLibFields pkg =
......@@ -666,57 +665,6 @@ mungeDynLibFields pkg =
ds -> ds
}
-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
mungePackagePaths :: FilePath -> FilePath -> UnitInfo -> UnitInfo
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
--
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
mungePackagePaths top_dir pkgroot pkg =
pkg {
unitImportDirs = munge_paths (unitImportDirs pkg),
unitIncludeDirs = munge_paths (unitIncludeDirs pkg),
unitLibraryDirs = munge_paths (unitLibraryDirs pkg),
unitLibraryDynDirs = munge_paths (unitLibraryDynDirs pkg),
unitExtDepFrameworkDirs = munge_paths (unitExtDepFrameworkDirs pkg),
unitHaddockInterfaces = munge_paths (unitHaddockInterfaces pkg),
unitHaddockHTMLs = munge_urls (unitHaddockHTMLs pkg)
}
where
munge_paths = map munge_path
munge_urls = map munge_url
munge_path p
| Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
| Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
| otherwise = p
munge_url p
| Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
| Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
| otherwise = p
toUrlPath r p = "file:///"
-- URLs always use posix style '/' separators:
++ FilePath.Posix.joinPath
(r : -- We need to drop a leading "/" or "\\"
-- if there is one:
dropWhile (all isPathSeparator)
(FilePath.splitDirectories p))
-- We could drop the separator here, and then use </> above. However,
-- by leaving it in and using ++ we keep the same path separator
-- rather than letting FilePath change it to use \ as the separator
stripVarPrefix var path = case stripPrefix var path of
Just [] -> Just []
Just cs@(c : _) | isPathSeparator c -> Just cs
_ -> Nothing
-- -----------------------------------------------------------------------------
-- Modify our copy of the package database based on trust flags,
-- -trust and -distrust.
......
......@@ -64,6 +64,9 @@ module GHC.PackageDb
, PackageDbLock
, lockPackageDb
, unlockPackageDb
-- * Misc
, mkMungePathUrl
, mungeUnitInfoPaths
)
where
......@@ -81,12 +84,14 @@ import Data.Binary.Put as Bin
import Data.Binary.Get as Bin
import Control.Exception as Exception
import Control.Monad (when)
import System.FilePath
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import System.IO
import System.IO.Error
import GHC.IO.Exception (IOErrorType(InappropriateType))
import GHC.IO.Handle.Lock
import System.Directory
import Data.List (stripPrefix)
-- | @ghc-boot@'s UnitInfo, serialized to the database.
type DbUnitInfo = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule
......@@ -629,3 +634,70 @@ instance Binary DbInstUnitId where
case b of
0 -> DbUnitId <$> get
_ -> DbInstUnitId <$> get <*> get
-- | Return functions to perform path/URL variable substitution as per the Cabal
-- ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
--
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
--
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
mkMungePathUrl :: FilePath -> FilePath -> (FilePath -> FilePath, FilePath -> FilePath)
mkMungePathUrl top_dir pkgroot = (munge_path, munge_url)
where
munge_path p
| Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
| Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
| otherwise = p
munge_url p
| Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
| Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
| otherwise = p
toUrlPath r p = "file:///"
-- URLs always use posix style '/' separators:
++ FilePath.Posix.joinPath
(r : -- We need to drop a leading "/" or "\\"
-- if there is one:
dropWhile (all isPathSeparator)
(FilePath.splitDirectories p))
-- We could drop the separator here, and then use </> above. However,
-- by leaving it in and using ++ we keep the same path separator
-- rather than letting FilePath change it to use \ as the separator
stripVarPrefix var path = case stripPrefix var path of
Just [] -> Just []
Just cs@(c : _) | isPathSeparator c -> Just cs
_ -> Nothing
-- | Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
--
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
mungeUnitInfoPaths :: FilePath -> FilePath -> GenericUnitInfo a b c d e f -> GenericUnitInfo a b c d e f
mungeUnitInfoPaths top_dir pkgroot pkg =
-- TODO: similar code is duplicated in utils/ghc-pkg/Main.hs
pkg
{ unitImportDirs = munge_paths (unitImportDirs pkg)
, unitIncludeDirs = munge_paths (unitIncludeDirs pkg)
, unitLibraryDirs = munge_paths (unitLibraryDirs pkg)
, unitLibraryDynDirs = munge_paths (unitLibraryDynDirs pkg)
, unitExtDepFrameworkDirs = munge_paths (unitExtDepFrameworkDirs pkg)
, unitHaddockInterfaces = munge_paths (unitHaddockInterfaces pkg)
-- haddock-html is allowed to be either a URL or a file
, unitHaddockHTMLs = munge_paths (munge_urls (unitHaddockHTMLs pkg))
}
where
munge_paths = map munge_path
munge_urls = map munge_url
(munge_path,munge_url) = mkMungePathUrl top_dir pkgroot
......@@ -58,7 +58,6 @@ import Distribution.Types.MungedPackageId
import Distribution.Simple.Utils (toUTF8BS, writeUTF8File, readUTF8File)
import qualified Data.Version as Version
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
getModificationTime )
import Text.Printf
......@@ -966,10 +965,7 @@ mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
-- files and "package.conf.d" dirs) the pkgroot is the parent directory
-- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
-- TODO: This code is duplicated in compiler/main/Packages.hs
mungePackagePaths :: FilePath -> FilePath
-> InstalledPackageInfo -> InstalledPackageInfo
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- | Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
......@@ -977,7 +973,10 @@ mungePackagePaths :: FilePath -> FilePath
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
mungePackagePaths :: FilePath -> FilePath
-> InstalledPackageInfo -> InstalledPackageInfo
mungePackagePaths top_dir pkgroot pkg =
-- TODO: similar code is duplicated in GHC.PackageDb
pkg {
importDirs = munge_paths (importDirs pkg),
includeDirs = munge_paths (includeDirs pkg),
......@@ -985,39 +984,13 @@ mungePackagePaths top_dir pkgroot pkg =
libraryDynDirs = munge_paths (libraryDynDirs pkg),
frameworkDirs = munge_paths (frameworkDirs pkg),
haddockInterfaces = munge_paths (haddockInterfaces pkg),
-- haddock-html is allowed to be either a URL or a file
-- haddock-html is allowed to be either a URL or a file
haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
}
where
munge_paths = map munge_path
munge_urls = map munge_url
munge_path p
| Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
| Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
| otherwise = p
munge_url p
| Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
| Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
| otherwise = p
toUrlPath r p = "file:///"
-- URLs always use posix style '/' separators:
++ FilePath.Posix.joinPath
(r : -- We need to drop a leading "/" or "\\"
-- if there is one:
dropWhile (all isPathSeparator)
(FilePath.splitDirectories p))
-- We could drop the separator here, and then use </> above. However,
-- by leaving it in and using ++ we keep the same path separator
-- rather than letting FilePath change it to use \ as the separator
stripVarPrefix var path = case stripPrefix var path of
Just [] -> Just []
Just cs@(c : _) | isPathSeparator c -> Just cs
_ -> Nothing
(munge_path,munge_url) = mkMungePathUrl top_dir pkgroot
-- -----------------------------------------------------------------------------
-- Workaround for old single-file style package dbs
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment