summaryrefslogtreecommitdiff
path: root/utils
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2020-04-06 12:17:04 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-04-30 01:56:56 -0400
commitea717aa4248b2122e1f7550f30239b50ab560e4f (patch)
tree6be60109187c269575170e569d72a4c918b5016b /utils
parent9e2c8e0e37a2709d5790d6c9a877a1463d6e88b5 (diff)
downloadhaskell-ea717aa4248b2122e1f7550f30239b50ab560e4f.tar.gz
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.
Diffstat (limited to 'utils')
-rw-r--r--utils/ghc-pkg/Main.hs39
1 files changed, 6 insertions, 33 deletions
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 2e2238ccb8..c822c31c4e 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -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