diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-04-06 12:17:04 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-04-30 01:56:56 -0400 |
commit | ea717aa4248b2122e1f7550f30239b50ab560e4f (patch) | |
tree | 6be60109187c269575170e569d72a4c918b5016b | |
parent | 9e2c8e0e37a2709d5790d6c9a877a1463d6e88b5 (diff) | |
download | haskell-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.
-rw-r--r-- | compiler/GHC/Driver/Packages.hs | 54 | ||||
-rw-r--r-- | libraries/ghc-boot/GHC/PackageDb.hs | 74 | ||||
-rw-r--r-- | utils/ghc-pkg/Main.hs | 39 |
3 files changed, 80 insertions, 87 deletions
diff --git a/compiler/GHC/Driver/Packages.hs b/compiler/GHC/Driver/Packages.hs index 3b0cf0525a..2f0a8b46d4 100644 --- a/compiler/GHC/Driver/Packages.hs +++ b/compiler/GHC/Driver/Packages.hs @@ -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. diff --git a/libraries/ghc-boot/GHC/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs index e8daedda66..650234927c 100644 --- a/libraries/ghc-boot/GHC/PackageDb.hs +++ b/libraries/ghc-boot/GHC/PackageDb.hs @@ -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 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 |