Fix W.splitFileName "/\\?/a:"

.github/workflows/test.yaml

@@ -50,7 +50,9 @@ jobs:
         set -eux
         cabal update
         cabal build --enable-tests --enable-benchmarks
-        cabal test
+        cabal test --test-show-details=direct filepath-tests
+        cabal test --test-show-details=direct --test-options='--quickcheck-tests 50_000' filepath-equivalent-tests
+        cabal test --test-show-details=direct abstract-filepath
         cabal bench
         cabal haddock
         cabal check

System/FilePath/Internal.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE MultiWayIf #-}
 
 -- This template expects CPP definitions for:
 --     MODULE_NAME = Posix | Windows
@@ -602,6 +603,7 @@ isDrive x = not (null x) && null (dropDrive x)
 -- > Posix:   splitFileName "/" == ("/","")
 -- > Windows: splitFileName "c:" == ("c:","")
 -- > Windows: splitFileName "\\\\?\\A:\\fred" == ("\\\\?\\A:\\","fred")
+-- > Windows: splitFileName "\\\\?\\A:" == ("\\\\?\\A:","")
 splitFileName :: FILEPATH -> (STRING, STRING)
 splitFileName x = if null path
     then (dotSlash, file)
@@ -644,20 +646,46 @@ splitFileName_ fp
   -- or UNC location "\\?\UNC\foo", where path separator is a part of the drive name.
   -- We can test this by trying dropDrive and falling back to splitDrive.
   | isWindows
-  , Just (s1, _s2, bs') <- uncons2 dirSlash
-  , isPathSeparator s1
-  -- If bs' is empty, then s2 as the last character of dirSlash must be a path separator,
-  -- so we are in the middle of shared drive.
-  -- Otherwise, since s1 is a path separator, we might be in the middle of UNC path.
-  , null bs' || maybe False isIncompleteUNC (readDriveUNC dirSlash)
-  = (fp, mempty)
+  = case uncons2 dirSlash of
+    Just (s1, s2, bs')
+      | isPathSeparator s1
+      -- If bs' is empty, then s2 as the last character of dirSlash must be a path separator,
+      -- so we are in the middle of shared drive.
+      -- Otherwise, since s1 is a path separator, we might be in the middle of UNC path.
+      , null bs' || maybe False isIncompleteUNC (readDriveUNC dirSlash)
+      -> (fp, mempty)
+      -- This handles inputs like "//?/A:" and "//?/A:foo"
+      | isPathSeparator s1
+      , isPathSeparator s2
+      , Just (s3, s4, bs'') <- uncons2 bs'
+      , s3 == _question
+      , isPathSeparator s4
+      , null bs''
+      , Just (drive, rest) <- readDriveLetter file
+      -> (dirSlash <> drive, rest)
+    _ -> (dirSlash, file)
   | otherwise
-  = (dirSlash, file)
+    = (dirSlash, file)
   where
     (dirSlash, file) = breakEnd isPathSeparator fp
-
+    -- an adjustant variant of 'dropTrailingPathSeparator' that normalises trailing path separators
+    -- on windows
+    dropTrailingPathSeparator' x =
+        if hasTrailingPathSeparator x
+        then let x' = dropWhileEnd isPathSeparator x
+             in if | null x' -> singleton (last x)
+                   | isDrive x -> addTrailingPathSeparator x'
+                   | otherwise -> x'
+        else x
+
+    -- an "incomplete" UNC is one without a path (but potentially a drive)
     isIncompleteUNC (pref, suff) = null suff && not (hasPenultimateColon pref)
-    hasPenultimateColon = maybe False (maybe False ((== _colon) . snd) . unsnoc . fst) . unsnoc
+
+    -- e.g. @//?/a:/@ or @//?/a://@, but not @//?/a:@
+    hasPenultimateColon pref
+      | hasTrailingPathSeparator pref
+      = maybe False (maybe False ((== _colon) . snd) . unsnoc . fst) . unsnoc . dropTrailingPathSeparator' $ pref
+      | otherwise = False
 
 -- | Set the filename.
 --
@@ -671,6 +699,7 @@ replaceFileName x y = a </> y where (a,_) = splitFileName_ x
 --
 -- > dropFileName "/directory/file.ext" == "/directory/"
 -- > dropFileName x == fst (splitFileName x)
+-- > isPrefixOf (takeDrive x) (dropFileName x)
 dropFileName :: FILEPATH -> FILEPATH
 dropFileName = fst . splitFileName
 

filepath.cabal

@@ -138,8 +138,12 @@ test-suite filepath-equivalent-tests
     , base
     , bytestring  >=0.11.3.0
     , filepath
+    , generic-random
+    , generic-deriving
     , os-string   >=2.0.1
     , QuickCheck  >=2.7      && <2.15
+    , tasty
+    , tasty-quickcheck
 
 test-suite abstract-filepath
   default-language: Haskell2010