[commit: packages/directory] master: makeAbsolute: handle drive-relative paths (09656a7)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/directory

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/09656a77a8bb5970a358310836188fd41cc6e8fd/directory

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

commit 09656a77a8bb5970a358310836188fd41cc6e8fd
Author: Phil Ruffwind <rf at rufflewind.com>
Date:   Tue Mar 7 05:24:29 2017 -0500

    makeAbsolute: handle drive-relative paths


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

09656a77a8bb5970a358310836188fd41cc6e8fd
 System/Directory.hs                  | 11 ++++++++++-
 System/Directory/Internal/Prelude.hs |  2 +-
 changelog.md                         |  2 ++
 tests/MakeAbsolute.hs                | 13 +++++++++++++
 4 files changed, 26 insertions(+), 2 deletions(-)

diff --git a/System/Directory.hs b/System/Directory.hs
index 19be2dd..ef92b28 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -1074,7 +1074,16 @@ prependCurrentDirectory path =
   modifyIOError ((`ioeAddLocation` "prependCurrentDirectory") .
                  (`ioeSetFileName` path)) $
   if isRelative path -- avoid the call to `getCurrentDirectory` if we can
-  then (</> path) <$> getCurrentDirectory
+  then do
+    cwd <- getCurrentDirectory
+    let curDrive = takeWhile (not . isPathSeparator) (takeDrive cwd)
+    let (drive, subpath) = splitDrive path
+    -- handle drive-relative paths (Windows only)
+    return . (</> subpath) $
+      case drive of
+        _ : _ | (toUpper <$> drive) /= (toUpper <$> curDrive) ->
+                  drive <> [pathSeparator]
+        _ -> cwd
   else return path
 
 -- | Add or remove the trailing path separator in the second path so as to
diff --git a/System/Directory/Internal/Prelude.hs b/System/Directory/Internal/Prelude.hs
index f6ce7be..51c8067 100644
--- a/System/Directory/Internal/Prelude.hs
+++ b/System/Directory/Internal/Prelude.hs
@@ -69,7 +69,7 @@ import Control.Exception
   )
 import Control.Monad ((>=>), (<=<), unless, when, replicateM_)
 import Data.Bits ((.&.), (.|.), complement)
-import Data.Char (isAlpha, isAscii, toLower)
+import Data.Char (isAlpha, isAscii, toLower, toUpper)
 import Data.Foldable (for_, traverse_)
 import Data.Function (on)
 import Data.Maybe (catMaybes, fromMaybe, maybeToList)
diff --git a/changelog.md b/changelog.md
index 30ba3c7..bb56c86 100644
--- a/changelog.md
+++ b/changelog.md
@@ -16,6 +16,8 @@ Changelog for the [`directory`][1] package
       * The `\\?\` prefix may show up in the error messages of the affected
         functions.
 
+  * `makeAbsolute` can now handle drive-relative paths on Windows.
+
 ## 1.3.1.0 (March 2017)
 
   * `findFile` (and similar functions): when an absolute path is given, the
diff --git a/tests/MakeAbsolute.hs b/tests/MakeAbsolute.hs
index abb99c2..d3996ba 100644
--- a/tests/MakeAbsolute.hs
+++ b/tests/MakeAbsolute.hs
@@ -3,6 +3,9 @@ module MakeAbsolute where
 #include "util.inl"
 import System.FilePath ((</>), addTrailingPathSeparator,
                         dropTrailingPathSeparator, normalise)
+#ifdef mingw32_HOST_OS
+import System.FilePath (takeDrive)
+#endif
 
 main :: TestEnv -> IO ()
 main _t = do
@@ -31,3 +34,13 @@ main _t = do
   T(expectEq) () sfoo (normalise (dot </> "foo/"))
   T(expectEq) () sfoo sfoo2
   T(expectEq) () sfoo sfoo3
+
+#ifdef mingw32_HOST_OS
+  cwd <- getCurrentDirectory
+  let driveLetter = toUpper (head (takeDrive cwd))
+  let driveLetter' = if driveLetter == 'Z' then 'A' else succ driveLetter
+  drp1 <- makeAbsolute (driveLetter : ":foobar")
+  drp2 <- makeAbsolute (driveLetter' : ":foobar")
+  T(expectEq) () drp1 =<< makeAbsolute "foobar"
+  T(expectEq) () drp2 (driveLetter' : ":\\foobar")
+#endif