[commit: Cabal] master: Support ${pkgroot}-relative paths in installed package info from hc-pkg (acfdf2f)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/acfdf2f8ec673fe9bb25e24b648eff296420f492

>---------------------------------------------------------------

commit acfdf2f8ec673fe9bb25e24b648eff296420f492
Author: Duncan Coutts <duncan at community.haskell.org>
Date:   Wed May 25 11:47:42 2011 +0000

    Support ${pkgroot}-relative paths in installed package info from hc-pkg
    See http://hackage.haskell.org/trac/ghc/ticket/3268
    In new versions of ghc-pkg, ghc-pkg dump will emit an extra field like
    pkgroot: /the/path/that/is/the/pkgroot
    and other fields may contain ${pkgroot}, e.g.
    library-dirs: ${pkgroot}/blah/
    This allows relocatable packages, with package files installed
    relative to the package database itself.

>---------------------------------------------------------------

 Distribution/Simple/Program/HcPkg.hs |   73 ++++++++++++++++++++++++++++++---
 1 files changed, 66 insertions(+), 7 deletions(-)

diff --git a/Distribution/Simple/Program/HcPkg.hs b/Distribution/Simple/Program/HcPkg.hs
index fda6d32..d5061d9 100644
--- a/Distribution/Simple/Program/HcPkg.hs
+++ b/Distribution/Simple/Program/HcPkg.hs
@@ -30,9 +30,9 @@ import Distribution.Package
          ( PackageId, InstalledPackageId(..) )
 import Distribution.InstalledPackageInfo
          ( InstalledPackageInfo, InstalledPackageInfo_(..)
-         , showInstalledPackageInfo, parseInstalledPackageInfo )
+         , showInstalledPackageInfo
+         , emptyInstalledPackageInfo, fieldsInstalledPackageInfo )
 import Distribution.ParseUtils
-         ( ParseResult(..) )
 import Distribution.Simple.Compiler
          ( PackageDB(..), PackageDBStack )
 import Distribution.Simple.Program.Types
@@ -53,8 +53,14 @@ import Distribution.Compat.Exception
 
 import Data.Char
          ( isSpace )
-import Control.Monad
-         ( liftM )
+import Data.Maybe
+         ( fromMaybe )
+import Data.List
+         ( stripPrefix )
+import System.FilePath as FilePath
+         ( (</>), splitPath, splitDirectories, joinPath, isPathSeparator )
+import qualified System.FilePath.Posix as FilePath.Posix
+
 
 -- | Call @hc-pkg@ to register a package.
 --
@@ -128,12 +134,28 @@ dump verbosity hcPkg packagedb = do
 
   where
     parsePackages str =
-      let parse  = liftM setInstalledPackageId . parseInstalledPackageInfo
-          parsed = map parse (splitPkgs str)
+      let parsed = map parseInstalledPackageInfo' (splitPkgs str)
        in case [ msg | ParseFailed msg <- parsed ] of
-            []   -> Left [ pkg | ParseOk _ pkg <- parsed ]
+            []   -> Left [   setInstalledPackageId
+                           . maybe id mungePackagePaths pkgroot
+                           $ pkg
+                         | ParseOk _ (pkgroot, pkg) <- parsed ]
             msgs -> Right msgs
 
+    parseInstalledPackageInfo' =
+        parseFieldsFlat fields (Nothing, emptyInstalledPackageInfo)
+      where
+        fields =     liftFieldFst pkgrootField
+               : map liftFieldSnd fieldsInstalledPackageInfo
+
+        pkgrootField =
+          simpleField "pkgroot"
+            showFilePath    parseFilePathQ
+            (fromMaybe "")  (\x _ -> Just x)
+
+        liftFieldFst = liftField fst (\x (_x,y) -> (x,y))
+        liftFieldSnd = liftField snd (\y (x,_y) -> (x,y))
+
     --TODO: this could be a lot faster. We're doing normaliseLineEndings twice
     -- and converting back and forth with lines/unlines.
     splitPkgs :: String -> [String]
@@ -149,6 +171,43 @@ dump verbosity hcPkg packagedb = do
                            _:ws -> splitWith p ws
           where (ys,zs) = break p xs
 
+mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
+-- 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.
+mungePackagePaths pkgroot pkginfo =
+    pkginfo {
+      importDirs        = mungePaths (importDirs  pkginfo),
+      includeDirs       = mungePaths (includeDirs pkginfo),
+      libraryDirs       = mungePaths (libraryDirs pkginfo),
+      frameworkDirs     = mungePaths (frameworkDirs pkginfo),
+      haddockInterfaces = mungePaths (haddockInterfaces pkginfo),
+      haddockHTMLs      = mungeUrls  (haddockHTMLs pkginfo)
+    }
+  where
+    mungePaths = map mungePath
+    mungeUrls  = map mungeUrl
+
+    mungePath p = case stripVarPrefix "${pkgroot}" p of
+      Just p' -> pkgroot </> p'
+      Nothing -> p
+
+    mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of
+      Just p' -> toUrlPath pkgroot p'
+      Nothing -> p
+
+    toUrlPath r p = "file:///"
+                 -- URLs always use posix style '/' separators:
+                 ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
+
+    stripVarPrefix var p =
+      case splitPath p of
+        (root:path') -> case stripPrefix var root of
+          Just [sep] | isPathSeparator sep -> Just (joinPath path')
+          _                                -> Nothing
+        _                                  -> Nothing
+
 
 -- Older installed package info files did not have the installedPackageId
 -- field, so if it is missing then we fill it as the source package ID.