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.

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