merge upstream

[ghc-hetmet.git] / compiler / main / Packages.lhs

diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 860464e..1231671 100644 (file)
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -260,6 +260,7 @@ maybeHidePackages dflags pkgs
   where
     hide pkg = pkg{ exposed = False }
 
+-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
 mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
@@ -283,29 +284,30 @@ mungePackagePaths top_dir pkgroot pkg =
     munge_urls  = map munge_url
 
     munge_path p
-      | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
-      | Just p' <- stripVarPrefix "$topdir"    sp = top_dir </> p'
-      | otherwise                                 = p
-      where
-        sp = splitPath 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}" sp = toUrlPath pkgroot p'
-      | Just p' <- stripVarPrefix "$httptopdir"   sp = toUrlPath top_dir p'
-      | otherwise                                    = p
-      where
-        sp = splitPath 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 : FilePath.splitDirectories p)
-
-    stripVarPrefix var (root:path')
-      | Just [sep] <- stripPrefix var root
-      , isPathSeparator sep
-      = Just (joinPath path')
-
-    stripVarPrefix _ _ = Nothing
+                 ++ 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
 
 
 -- -----------------------------------------------------------------------------