From 2e17ea26318ff07e1f030a8096a4d099d1482ec8 Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@community.haskell.org>
Date: Fri, 15 Apr 2016 04:11:46 +0100
Subject: [PATCH] Adjust representation of file glob roots

Previously we represented unix and windows roots/drives explicitly but
this isn't necessary and it makes it inconvenient to use portable
functions like FilePath.takeDrive (which returns "/" on unix or things
like "c:\\" on windows). So instead we just use a FilePath as the root.
---
 cabal-install/Distribution/Client/Glob.hs     | 27 +++++++------------
 .../UnitTests/Distribution/Client/Glob.hs     | 21 ++++++++-------
 2 files changed, 21 insertions(+), 27 deletions(-)

diff --git a/cabal-install/Distribution/Client/Glob.hs b/cabal-install/Distribution/Client/Glob.hs
index e48a0c366af..78d4d8d993e 100644
--- a/cabal-install/Distribution/Client/Glob.hs
+++ b/cabal-install/Distribution/Client/Glob.hs
@@ -55,8 +55,7 @@ data GlobPiece = WildCard
 
 data FilePathRoot
    = FilePathRelative
-   | FilePathUnixRoot
-   | FilePathWinDrive Char
+   | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive'
    | FilePathHomeDir
   deriving (Eq, Show, Generic)
 
@@ -76,9 +75,8 @@ instance Binary GlobPiece
 isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath
 isTrivialFilePathGlob (FilePathGlob root pathglob) =
     case root of
-      FilePathRelative       -> go []          pathglob
-      FilePathUnixRoot       -> go ["/"]       pathglob
-      FilePathWinDrive drive -> go [drive:":"] pathglob
+      FilePathRelative       -> go []      pathglob
+      FilePathRoot root'     -> go [root'] pathglob
       FilePathHomeDir        -> Nothing
   where
     go paths (GlobDir  [Literal path] globs) = go (path:paths) globs
@@ -95,10 +93,9 @@ isTrivialFilePathGlob (FilePathGlob root pathglob) =
 getFilePathRootDirectory :: FilePathRoot
                          -> FilePath      -- ^ root for relative paths
                          -> IO FilePath
-getFilePathRootDirectory  FilePathRelative     root = return root
-getFilePathRootDirectory  FilePathUnixRoot        _ = return "/"
-getFilePathRootDirectory (FilePathWinDrive drive) _ = return (drive:":")
-getFilePathRootDirectory  FilePathHomeDir         _ = getHomeDirectory
+getFilePathRootDirectory  FilePathRelative   root = return root
+getFilePathRootDirectory (FilePathRoot root) _    = return root
+getFilePathRootDirectory  FilePathHomeDir    _    = getHomeDirectory
 
 
 ------------------------------------------------------------------------------
@@ -180,21 +177,17 @@ instance Text FilePathGlob where
 
 instance Text FilePathRoot where
   disp  FilePathRelative    = Disp.empty
-  disp  FilePathUnixRoot    = Disp.char '/'
-  disp (FilePathWinDrive c) = Disp.char c
-                      Disp.<> Disp.char ':'
-                      Disp.<> Disp.char '\\'
-  disp FilePathHomeDir      = Disp.char '~'
-                      Disp.<> Disp.char '/'
+  disp (FilePathRoot root)  = Disp.text root
+  disp FilePathHomeDir      = Disp.char '~' Disp.<> Disp.char '/'
 
   parse =
-        (     (Parse.char '/' >> return FilePathUnixRoot)
+        (     (Parse.char '/' >> return (FilePathRoot "/"))
           +++ (Parse.char '~' >> Parse.char '/' >> return FilePathHomeDir)
           +++ (do drive <- Parse.satisfy (\c -> (c >= 'a' && c <= 'z')
                                              || (c >= 'A' && c <= 'Z'))
                   _ <- Parse.char ':'
                   _ <- Parse.char '/' +++ Parse.char '\\'
-                  return (FilePathWinDrive (toUpper drive)))
+                  return (FilePathRoot (toUpper drive : ":\\")))
         )
     <++ return FilePathRelative
 
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs b/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs
index 9d18700abd6..592d795b427 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs
@@ -40,12 +40,12 @@ prop_roundtrip_printparse pathglob =
 testParseCases :: Assertion
 testParseCases = do
 
-  FilePathGlob FilePathUnixRoot GlobDirTrailing <- testparse "/"
+  FilePathGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/"
   FilePathGlob FilePathHomeDir  GlobDirTrailing <- testparse "~/"
 
-  FilePathGlob (FilePathWinDrive 'A') GlobDirTrailing <- testparse "A:/"
-  FilePathGlob (FilePathWinDrive 'Z') GlobDirTrailing <- testparse "z:/"
-  FilePathGlob (FilePathWinDrive 'C') GlobDirTrailing <- testparse "C:\\"
+  FilePathGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/"
+  FilePathGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/"
+  FilePathGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\"
   FilePathGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"
 
   FilePathGlob FilePathRelative
@@ -68,7 +68,7 @@ testParseCases = do
     (GlobDir [Literal "foo"]
       (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "foo/bar/"
 
-  FilePathGlob FilePathUnixRoot
+  FilePathGlob (FilePathRoot "/")
     (GlobDir [Literal "foo"]
       (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "/foo/bar/"
 
@@ -134,16 +134,17 @@ instance Arbitrary FilePathRoot where
   arbitrary =
     frequency
       [ (3, pure FilePathRelative)
-      , (1, pure FilePathUnixRoot)
+      , (1, pure (FilePathRoot unixroot))
+      , (1, FilePathRoot <$> windrive)
       , (1, pure FilePathHomeDir)
-      , (1, FilePathWinDrive <$> choose ('A', 'Z'))
       ]
+    where
+      unixroot = "/"
+      windrive = do d <- choose ('A', 'Z'); return (d : ":\\")
 
   shrink FilePathRelative     = []
-  shrink FilePathUnixRoot     = [FilePathRelative]
+  shrink (FilePathRoot _)     = [FilePathRelative]
   shrink FilePathHomeDir      = [FilePathRelative]
-  shrink (FilePathWinDrive d) = FilePathRelative
-                              : [ FilePathWinDrive d' | d' <- shrink d ]
 
 
 instance Arbitrary FilePathGlobRel where