From 399df96cd9f8d01bdffa1287f928866c8524c00c Mon Sep 17 00:00:00 2001 From: Bodigrim Date: Sun, 21 Jan 2024 20:26:27 +0000 Subject: [PATCH 1/5] Add more tests on splitFileName and dropFileName --- System/FilePath/Internal.hs | 2 ++ tests/filepath-tests/TestGen.hs | 6 ++++++ 2 files changed, 8 insertions(+) diff --git a/System/FilePath/Internal.hs b/System/FilePath/Internal.hs index 786eb3a3..567efbbf 100644 --- a/System/FilePath/Internal.hs +++ b/System/FilePath/Internal.hs @@ -602,6 +602,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) @@ -671,6 +672,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 diff --git a/tests/filepath-tests/TestGen.hs b/tests/filepath-tests/TestGen.hs index 8f26f2b4..1d75b032 100755 --- a/tests/filepath-tests/TestGen.hs +++ b/tests/filepath-tests/TestGen.hs @@ -458,6 +458,8 @@ tests = ,("AFP_W.splitFileName (\"c:\") == ((\"c:\"), (\"\"))", property $ AFP_W.splitFileName ("c:") == (("c:"), (""))) ,("W.splitFileName \"\\\\\\\\?\\\\A:\\\\fred\" == (\"\\\\\\\\?\\\\A:\\\\\", \"fred\")", property $ W.splitFileName "\\\\?\\A:\\fred" == ("\\\\?\\A:\\", "fred")) ,("AFP_W.splitFileName (\"\\\\\\\\?\\\\A:\\\\fred\") == ((\"\\\\\\\\?\\\\A:\\\\\"), (\"fred\"))", property $ AFP_W.splitFileName ("\\\\?\\A:\\fred") == (("\\\\?\\A:\\"), ("fred"))) + ,("W.splitFileName \"\\\\\\\\?\\\\A:\" == (\"\\\\\\\\?\\\\A:\", \"\")", property $ W.splitFileName "\\\\?\\A:" == ("\\\\?\\A:", "")) + ,("AFP_W.splitFileName (\"\\\\\\\\?\\\\A:\") == ((\"\\\\\\\\?\\\\A:\"), (\"\"))", property $ AFP_W.splitFileName ("\\\\?\\A:") == (("\\\\?\\A:"), (""))) ,("P.replaceFileName \"/directory/other.txt\" \"file.ext\" == \"/directory/file.ext\"", property $ P.replaceFileName "/directory/other.txt" "file.ext" == "/directory/file.ext") ,("W.replaceFileName \"/directory/other.txt\" \"file.ext\" == \"/directory/file.ext\"", property $ W.replaceFileName "/directory/other.txt" "file.ext" == "/directory/file.ext") ,("AFP_P.replaceFileName (\"/directory/other.txt\") (\"file.ext\") == (\"/directory/file.ext\")", property $ AFP_P.replaceFileName ("/directory/other.txt") ("file.ext") == ("/directory/file.ext")) @@ -474,6 +476,10 @@ tests = ,("W.dropFileName x == fst (W.splitFileName x)", property $ \(QFilePath x) -> W.dropFileName x == fst (W.splitFileName x)) ,("AFP_P.dropFileName x == fst (AFP_P.splitFileName x)", property $ \(QFilePathAFP_P x) -> AFP_P.dropFileName x == fst (AFP_P.splitFileName x)) ,("AFP_W.dropFileName x == fst (AFP_W.splitFileName x)", property $ \(QFilePathAFP_W x) -> AFP_W.dropFileName x == fst (AFP_W.splitFileName x)) + ,("isPrefixOf (P.takeDrive x) (P.dropFileName x)", property $ \(QFilePath x) -> isPrefixOf (P.takeDrive x) (P.dropFileName x)) + ,("isPrefixOf (W.takeDrive x) (W.dropFileName x)", property $ \(QFilePath x) -> isPrefixOf (W.takeDrive x) (W.dropFileName x)) + ,("(\\(getPosixString -> x) (getPosixString -> y) -> SBS.isPrefixOf x y) (AFP_P.takeDrive x) (AFP_P.dropFileName x)", property $ \(QFilePathAFP_P x) -> (\(getPosixString -> x) (getPosixString -> y) -> SBS.isPrefixOf x y) (AFP_P.takeDrive x) (AFP_P.dropFileName x)) + ,("(\\(getWindowsString -> x) (getWindowsString -> y) -> SBS16.isPrefixOf x y) (AFP_W.takeDrive x) (AFP_W.dropFileName x)", property $ \(QFilePathAFP_W x) -> (\(getWindowsString -> x) (getWindowsString -> y) -> SBS16.isPrefixOf x y) (AFP_W.takeDrive x) (AFP_W.dropFileName x)) ,("P.takeFileName \"/directory/file.ext\" == \"file.ext\"", property $ P.takeFileName "/directory/file.ext" == "file.ext") ,("W.takeFileName \"/directory/file.ext\" == \"file.ext\"", property $ W.takeFileName "/directory/file.ext" == "file.ext") ,("AFP_P.takeFileName (\"/directory/file.ext\") == (\"file.ext\")", property $ AFP_P.takeFileName ("/directory/file.ext") == ("file.ext")) From c39480351d4ed97cd0bfb569c3090574c4a8c4ed Mon Sep 17 00:00:00 2001 From: Bodigrim Date: Sun, 21 Jan 2024 20:28:36 +0000 Subject: [PATCH 2/5] Fix regression of splitFileName on '//?/A:' --- System/FilePath/Internal.hs | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/System/FilePath/Internal.hs b/System/FilePath/Internal.hs index 567efbbf..dbee0e8e 100644 --- a/System/FilePath/Internal.hs +++ b/System/FilePath/Internal.hs @@ -645,15 +645,26 @@ 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 From 67a45a488d858becdc8a7c2b9efe6edc0320af16 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 24 Jan 2024 17:41:41 +0800 Subject: [PATCH 3/5] Improve equivalence tests --- .github/workflows/test.yaml | 4 +- filepath.cabal | 4 + tests/filepath-equivalent-tests/TestEquiv.hs | 258 +++++++++++++++---- 3 files changed, 222 insertions(+), 44 deletions(-) diff --git a/.github/workflows/test.yaml b/.github/workflows/test.yaml index 75b03ac3..5613fb37 100644 --- a/.github/workflows/test.yaml +++ b/.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 diff --git a/filepath.cabal b/filepath.cabal index 7bf73171..56fba52d 100644 --- a/filepath.cabal +++ b/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 diff --git a/tests/filepath-equivalent-tests/TestEquiv.hs b/tests/filepath-equivalent-tests/TestEquiv.hs index 83b71c39..1e36bfb4 100644 --- a/tests/filepath-equivalent-tests/TestEquiv.hs +++ b/tests/filepath-equivalent-tests/TestEquiv.hs @@ -1,24 +1,196 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia, TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TypeApplications #-} module Main where -import Test.QuickCheck hiding ((==>)) +import Test.Tasty +import Test.Tasty.QuickCheck hiding ((==>)) import TestUtil import Prelude as P +import Data.Char (isAsciiLower, isAsciiUpper) +import Data.List.NonEmpty (NonEmpty(..)) +import Generic.Random +import Generics.Deriving.Show +import GHC.Generics import qualified System.FilePath.Windows as W import qualified System.FilePath.Posix as P import qualified Legacy.System.FilePath.Windows as LW import qualified Legacy.System.FilePath.Posix as LP -import Data.Char (isAsciiLower, isAsciiUpper) +import qualified Data.List.NonEmpty as NE + + +class AltShow a where + altShow :: a -> String + +instance {-# OVERLAPPABLE #-} Show a => AltShow a where + altShow = show + +instance {-# OVERLAPS #-} AltShow String where + altShow = id + + +newtype WindowsFilePaths = WindowsFilePaths { unWindowsFilePaths :: [WindowsFilePath] } + deriving (Show, Eq, Ord, Generic) + +-- filepath = namespace *"\" namespace-tail +-- / UNC +-- / [ disk ] *"\" relative-path +-- / disk *"\" +data WindowsFilePath = NS NameSpace [Separator] NSTail + | UNC UNCShare + | N (Maybe Char) [Separator] (Maybe RelFilePath) + -- ^ This differs from the grammar, because we allow + -- empty paths + | PotentiallyInvalid FilePath + -- ^ this branch is added purely for the tests + deriving (GShow, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryU `AndShrinking` WindowsFilePath) + +instance Show WindowsFilePath where + show wf = gshow wf ++ " (" ++ altShow wf ++ ")" + +instance AltShow WindowsFilePath where + altShow (NS ns seps nstail) = altShow ns ++ altShow seps ++ altShow nstail + altShow (UNC unc) = altShow unc + altShow (N mdisk seps mfrp) = maybe [] (:[]) mdisk ++ (altShow seps ++ maybe "" altShow mfrp) + altShow (PotentiallyInvalid fp) = fp + + +-- namespace-tail = ( disk 1*"\" relative-path ; C:foo\bar is not valid +-- ; namespaced paths are all absolute +-- / disk *"\" +-- / relative-path +-- ) +data NSTail = NST1 Char (NonEmpty Separator) RelFilePath + | NST2 Char [Separator] + | NST3 RelFilePath + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryU `AndShrinking` NSTail) + +instance AltShow NSTail where + altShow (NST1 disk seps relfp) = disk:':':(altShow seps ++ altShow relfp) + altShow (NST2 disk seps) = disk:':':altShow seps + altShow (NST3 relfp) = altShow relfp + + +-- UNC = "\\" 1*pchar "\" 1*pchar [ 1*"\" [ relative-path ] ] +data UNCShare = UNCShare Separator Separator + NonEmptyString + (NonEmpty Separator) + NonEmptyString + (Maybe (NonEmpty Separator, Maybe RelFilePath)) + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryU `AndShrinking` UNCShare) + +instance AltShow UNCShare where + altShow (UNCShare sep1 sep2 fp1 seps fp2 mrfp) = altShow sep1 ++ altShow sep2 ++ altShow fp1 ++ altShow seps ++ altShow fp2 ++ maybe "" (\(a, b) -> altShow a ++ maybe "" altShow b) mrfp + +newtype NonEmptyString = NonEmptyString (NonEmpty Char) + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryU `AndShrinking` NonEmptyString) + +instance AltShow NonEmptyString where + altShow (NonEmptyString ns) = NE.toList ns + + +-- | Windows API Namespaces +-- +-- https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file#namespaces +-- https://support.microsoft.com/en-us/topic/70b92942-a643-2f2d-2ac6-aad8acad49fb +-- https://superuser.com/a/1096784/854039 +-- https://reverseengineering.stackexchange.com/a/15178 +-- https://stackoverflow.com/a/25099634 +-- +-- namespace = file-namespace / device-namespace / nt-namespace +-- file-namespace = "\" "\" "?" "\" +-- device-namespace = "\" "\" "." "\" +-- nt-namespace = "\" "?" "?" "\" +data NameSpace = FileNameSpace + | DeviceNameSpace + | NTNameSpace + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryU `AndShrinking` NameSpace) + +instance AltShow NameSpace where + altShow FileNameSpace = "\\\\?\\" + altShow DeviceNameSpace = "\\\\.\\" + altShow NTNameSpace = "\\??\\" + + +data Separator = UnixSep + | WindowsSep + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryU `AndShrinking` Separator) + +instance AltShow Separator where + altShow UnixSep = "/" + altShow WindowsSep = "\\" + +instance {-# OVERLAPS #-} AltShow (NonEmpty Separator) where + altShow ne = mconcat $ NE.toList (altShow <$> ne) + +instance {-# OVERLAPS #-} AltShow [Separator] where + altShow [] = "" + altShow ne = altShow (NE.fromList ne) + +-- relative-path = 1*(path-name 1*"\") [ file-name ] / file-name +data RelFilePath = Rel1 (NonEmpty (NonEmptyString, NonEmpty Separator)) (Maybe FileName) + | Rel2 FileName + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryU `AndShrinking` RelFilePath) + +instance AltShow RelFilePath where + altShow (Rel1 ns mf) = (mconcat $ NE.toList $ fmap (\(a, b) -> altShow a ++ altShow b) ns) ++ maybe "" altShow mf + altShow (Rel2 fn) = altShow fn + +-- file-name = 1*pchar [ stream ] +data FileName = FileName NonEmptyString (Maybe DataStream) + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryU `AndShrinking` FileName) + +instance AltShow FileName where + altShow (FileName ns ds) = altShow ns ++ altShow ds + +-- stream = ":" 1*schar [ ":" 1*schar ] / ":" ":" 1*schar +data DataStream = DS1 NonEmptyString (Maybe NonEmptyString) + | DS2 NonEmptyString -- ::datatype + deriving (GShow, Show, Eq, Ord, Generic) + deriving Arbitrary via (GenericArbitraryU `AndShrinking` DataStream) + +instance AltShow DataStream where + altShow (DS1 ns Nothing) = ":" ++ altShow ns + altShow (DS1 ns (Just ns2)) = ":" ++ altShow ns ++ ":" ++ altShow ns2 + altShow (DS2 ns) = "::" ++ altShow ns + +instance Arbitrary WindowsFilePaths where + arbitrary = scale (`mod` 20) $ genericArbitrary uniform + +instance Arbitrary [Separator] where + arbitrary = scale (`mod` 20) $ genericArbitrary uniform + +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = scale (`mod` 20) $ do + x <- arbitrary + case x of + [] -> (NE.fromList . (:[])) <$> arbitrary + xs -> pure (NE.fromList xs) main :: IO () -main = runTests equivalentTests +main = defaultMain equivalentTests -equivalentTests :: [(String, Property)] -equivalentTests = +equivalentTests :: TestTree +equivalentTests = testProperties "equivalence" $ [ ( "pathSeparator (windows)" , property $ W.pathSeparator == LW.pathSeparator @@ -49,39 +221,41 @@ equivalentTests = ) , ( "splitSearchPath (windows)" - , property $ \p -> W.splitSearchPath p == LW.splitSearchPath p + , property $ \(xs :: WindowsFilePaths) + -> let p = (intercalate ";" (altShow <$> unWindowsFilePaths xs)) + in W.splitSearchPath p == LW.splitSearchPath p ) , ( "splitExtension (windows)" - , property $ \p -> W.splitExtension p == LW.splitExtension p + , property $ \(altShow @WindowsFilePath -> p) -> W.splitExtension p == LW.splitExtension p ) , ( "takeExtension (windows)" - , property $ \p -> W.takeExtension p == LW.takeExtension p + , property $ \(altShow @WindowsFilePath -> p) -> W.takeExtension p == LW.takeExtension p ) , ( "replaceExtension (windows)" - , property $ \p s -> W.replaceExtension p s == LW.replaceExtension p s + , property $ \(altShow @WindowsFilePath -> p) s -> W.replaceExtension p s == LW.replaceExtension p s ) , ( "dropExtension (windows)" - , property $ \p -> W.dropExtension p == LW.dropExtension p + , property $ \(altShow @WindowsFilePath -> p) -> W.dropExtension p == LW.dropExtension p ) , ( "addExtension (windows)" - , property $ \p s -> W.addExtension p s == LW.addExtension p s + , property $ \(altShow @WindowsFilePath -> p) s -> W.addExtension p s == LW.addExtension p s ) , ( "hasExtension (windows)" - , property $ \p -> W.hasExtension p == LW.hasExtension p + , property $ \(altShow @WindowsFilePath -> p) -> W.hasExtension p == LW.hasExtension p ) , ( "splitExtensions (windows)" - , property $ \p -> W.splitExtensions p == LW.splitExtensions p + , property $ \(altShow @WindowsFilePath -> p) -> W.splitExtensions p == LW.splitExtensions p ) , ( "dropExtensions (windows)" - , property $ \p -> W.dropExtensions p == LW.dropExtensions p + , property $ \(altShow @WindowsFilePath -> p) -> W.dropExtensions p == LW.dropExtensions p ) , ( "takeExtensions (windows)" @@ -89,107 +263,105 @@ equivalentTests = ) , ( "replaceExtensions (windows)" - , property $ \p s -> W.replaceExtensions p s == LW.replaceExtensions p s + , property $ \(altShow @WindowsFilePath -> p) s -> W.replaceExtensions p s == LW.replaceExtensions p s ) , ( "isExtensionOf (windows)" - , property $ \p s -> W.isExtensionOf p s == LW.isExtensionOf p s + , property $ \(altShow @WindowsFilePath -> p) s -> W.isExtensionOf p s == LW.isExtensionOf p s ) , ( "stripExtension (windows)" - , property $ \p s -> W.stripExtension p s == LW.stripExtension p s + , property $ \(altShow @WindowsFilePath -> p) s -> W.stripExtension p s == LW.stripExtension p s ) , ( "splitFileName (windows)" - , property $ \p -> W.splitFileName p == LW.splitFileName p + , property $ \(altShow @WindowsFilePath -> p) -> W.splitFileName p == LW.splitFileName p ) , ( "takeFileName (windows)" - , property $ \p -> W.takeFileName p == LW.takeFileName p + , property $ \(altShow @WindowsFilePath -> p) -> W.takeFileName p == LW.takeFileName p ) , ( "replaceFileName (windows)" - , property $ \p s -> W.replaceFileName p s == LW.replaceFileName p s + , property $ \(altShow @WindowsFilePath -> p) s -> W.replaceFileName p s == LW.replaceFileName p s ) , ( "dropFileName (windows)" - , property $ \p -> W.dropFileName p == LW.dropFileName p + , property $ \(altShow @WindowsFilePath -> p) -> W.dropFileName p == LW.dropFileName p ) , ( "takeBaseName (windows)" - , property $ \p -> W.takeBaseName p == LW.takeBaseName p + , property $ \(altShow @WindowsFilePath -> p) -> W.takeBaseName p == LW.takeBaseName p ) , ( "replaceBaseName (windows)" - , property $ \p s -> W.replaceBaseName p s == LW.replaceBaseName p s + , property $ \(altShow @WindowsFilePath -> p) s -> W.replaceBaseName p s == LW.replaceBaseName p s ) , ( "takeDirectory (windows)" - , property $ \p -> W.takeDirectory p == LW.takeDirectory p + , property $ \(altShow @WindowsFilePath -> p) -> W.takeDirectory p == LW.takeDirectory p ) , ( "replaceDirectory (windows)" - , property $ \p s -> W.replaceDirectory p s == LW.replaceDirectory p s + , property $ \(altShow @WindowsFilePath -> p) s -> W.replaceDirectory p s == LW.replaceDirectory p s ) , ( "combine (windows)" - , property $ \p s -> W.combine p s == LW.combine p s + , property $ \(altShow @WindowsFilePath -> p) s -> W.combine p s == LW.combine p s ) , ( "splitPath (windows)" - , property $ \p -> W.splitPath p == LW.splitPath p + , property $ \(altShow @WindowsFilePath -> p) -> W.splitPath p == LW.splitPath p ) , ( "joinPath (windows)" - , property $ \p -> W.joinPath p == LW.joinPath p - ) - , - ( "splitDirectories (windows)" - , property $ \p -> W.splitDirectories p == LW.splitDirectories p + , property $ \(xs :: WindowsFilePaths) -> + let p = altShow <$> unWindowsFilePaths xs + in W.joinPath p == LW.joinPath p ) , ( "splitDirectories (windows)" - , property $ \p -> W.splitDirectories p == LW.splitDirectories p + , property $ \(altShow @WindowsFilePath -> p) -> W.splitDirectories p == LW.splitDirectories p ) , ( "splitDrive (windows)" - , property $ \p -> W.splitDrive p == LW.splitDrive p + , property $ \(altShow @WindowsFilePath -> p) -> W.splitDrive p == LW.splitDrive p ) , ( "joinDrive (windows)" - , property $ \p s -> W.joinDrive p s == LW.joinDrive p s + , property $ \(altShow @WindowsFilePath -> p) s -> W.joinDrive p s == LW.joinDrive p s ) , ( "takeDrive (windows)" - , property $ \p -> W.takeDrive p == LW.takeDrive p + , property $ \(altShow @WindowsFilePath -> p) -> W.takeDrive p == LW.takeDrive p ) , ( "hasDrive (windows)" - , property $ \p -> W.hasDrive p == LW.hasDrive p + , property $ \(altShow @WindowsFilePath -> p) -> W.hasDrive p == LW.hasDrive p ) , ( "dropDrive (windows)" - , property $ \p -> W.dropDrive p == LW.dropDrive p + , property $ \(altShow @WindowsFilePath -> p) -> W.dropDrive p == LW.dropDrive p ) , ( "isDrive (windows)" - , property $ \p -> W.isDrive p == LW.isDrive p + , property $ \(altShow @WindowsFilePath -> p) -> W.isDrive p == LW.isDrive p ) , ( "hasTrailingPathSeparator (windows)" - , property $ \p -> W.hasTrailingPathSeparator p == LW.hasTrailingPathSeparator p + , property $ \(altShow @WindowsFilePath -> p) -> W.hasTrailingPathSeparator p == LW.hasTrailingPathSeparator p ) , ( "addTrailingPathSeparator (windows)" - , property $ \p -> W.addTrailingPathSeparator p == LW.addTrailingPathSeparator p + , property $ \(altShow @WindowsFilePath -> p) -> W.addTrailingPathSeparator p == LW.addTrailingPathSeparator p ) , ( "dropTrailingPathSeparator (windows)" - , property $ \p -> W.dropTrailingPathSeparator p == LW.dropTrailingPathSeparator p + , property $ \(altShow @WindowsFilePath -> p) -> W.dropTrailingPathSeparator p == LW.dropTrailingPathSeparator p ) , ( "normalise (windows)" - , property $ \p -> case p of + , property $ \(altShow @WindowsFilePath -> p) -> case p of (l:':':rs) -- new filepath normalises "a:////////" to "A:\\" -- see https://github.com/haskell/filepath/commit/cb4890aa03a5ee61f16f7a08dd2d964fffffb385 From 05304865cc7d3458ad5c629590344262b458b75c Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 24 Jan 2024 18:16:29 +0800 Subject: [PATCH 4/5] Fix AltShow Maybe instance --- tests/filepath-equivalent-tests/TestEquiv.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/filepath-equivalent-tests/TestEquiv.hs b/tests/filepath-equivalent-tests/TestEquiv.hs index 1e36bfb4..4405ea40 100644 --- a/tests/filepath-equivalent-tests/TestEquiv.hs +++ b/tests/filepath-equivalent-tests/TestEquiv.hs @@ -37,6 +37,10 @@ instance {-# OVERLAPPABLE #-} Show a => AltShow a where instance {-# OVERLAPS #-} AltShow String where altShow = id +instance {-# OVERLAPPABLE #-} AltShow a => AltShow (Maybe a) where + altShow Nothing = "" + altShow (Just a) = altShow a + newtype WindowsFilePaths = WindowsFilePaths { unWindowsFilePaths :: [WindowsFilePath] } deriving (Show, Eq, Ord, Generic) From 74713b9692d970d75ac0a3542b689cd871ec180f Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 25 Jan 2024 16:56:55 +0800 Subject: [PATCH 5/5] Truly fix splitFileName on windows --- System/FilePath/Internal.hs | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/System/FilePath/Internal.hs b/System/FilePath/Internal.hs index dbee0e8e..8ef468b8 100644 --- a/System/FilePath/Internal.hs +++ b/System/FilePath/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiWayIf #-} -- This template expects CPP definitions for: -- MODULE_NAME = Posix | Windows @@ -667,9 +668,24 @@ splitFileName_ fp = (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. --