From 6df66da54a984182d389474871a92d67c75f78c3 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Thu, 23 Apr 2026 23:53:59 +0530 Subject: [PATCH 1/5] Add tests for FileSystem.Path module --- test/Streamly/Test/FileSystem/Path.hs | 340 ++++++++++++++++++++++++++ test/streamly-tests.cabal | 8 + 2 files changed, 348 insertions(+) create mode 100644 test/Streamly/Test/FileSystem/Path.hs diff --git a/test/Streamly/Test/FileSystem/Path.hs b/test/Streamly/Test/FileSystem/Path.hs new file mode 100644 index 0000000000..ed36b2358e --- /dev/null +++ b/test/Streamly/Test/FileSystem/Path.hs @@ -0,0 +1,340 @@ +-- | +-- Module : Streamly.Test.FileSystem.Path +-- Copyright : (c) 2024 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Test.FileSystem.Path (main) where + +import Data.Maybe (isJust, isNothing) +import Test.Hspec as H + +import qualified Streamly.Internal.FileSystem.Path as Path + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +-- | Build a path from a string, failing at runtime if invalid. +p :: String -> Path.Path +p = Path.fromString_ + +-- | Round-trip a path through toString. +str :: Path.Path -> String +str = Path.toString + + +------------------------------------------------------------------------------- +-- Construction and conversion +------------------------------------------------------------------------------- + +testFromString :: Spec +testFromString = describe "fromString" $ do + it "valid absolute path" $ + isJust (Path.fromString "/usr/bin" :: Maybe Path.Path) `shouldBe` True + it "valid relative path" $ + isJust (Path.fromString "a/b/c" :: Maybe Path.Path) `shouldBe` True + it "empty string is invalid" $ + isNothing (Path.fromString "" :: Maybe Path.Path) `shouldBe` True + it "toString . fromString_ roundtrip" $ + str (p "/usr/bin") `shouldBe` "/usr/bin" + it "relative roundtrip" $ + str (p "a/b/c") `shouldBe` "a/b/c" + +------------------------------------------------------------------------------- +-- Separators +------------------------------------------------------------------------------- + +testSeparators :: Spec +testSeparators = describe "separators" $ do + it "hasTrailingSeparator with trailing" $ + Path.hasTrailingSeparator (p "foo/") `shouldBe` True + it "hasTrailingSeparator without trailing" $ + Path.hasTrailingSeparator (p "foo") `shouldBe` False + it "dropTrailingSeparators" $ + str (Path.dropTrailingSeparators (p "foo/")) `shouldBe` "foo" + it "dropTrailingSeparators idempotent" $ + str (Path.dropTrailingSeparators (p "foo")) `shouldBe` "foo" + it "addTrailingSeparator adds separator" $ + Path.hasTrailingSeparator (Path.addTrailingSeparator (p "foo")) + `shouldBe` True + it "addTrailingSeparator idempotent" $ + str (Path.addTrailingSeparator (p "foo/")) `shouldBe` "foo/" + +------------------------------------------------------------------------------- +-- Root detection +------------------------------------------------------------------------------- + +testRooted :: Spec +testRooted = describe "isRooted/isUnrooted" $ do + it "/ is rooted" $ Path.isRooted (p "/") `shouldBe` True + it "/x is rooted" $ Path.isRooted (p "/x") `shouldBe` True + it ". is rooted" $ Path.isRooted (p ".") `shouldBe` True + it "./x is rooted" $ Path.isRooted (p "./x") `shouldBe` True + it "x is unrooted" $ Path.isUnrooted (p "x") `shouldBe` True + it "x/y is unrooted" $ Path.isUnrooted (p "x/y") `shouldBe` True + it ".. is unrooted" $ Path.isUnrooted (p "..") `shouldBe` True + it "../x is unrooted" $ Path.isUnrooted (p "../x") `shouldBe` True + +------------------------------------------------------------------------------- +-- Joining +------------------------------------------------------------------------------- + +testJoin :: Spec +testJoin = describe "join" $ do + it "join two segments" $ + str (Path.join (p "/usr") (p "bin")) `shouldBe` "/usr/bin" + it "join with trailing sep on first" $ + str (Path.join (p "/usr/") (p "bin")) `shouldBe` "/usr/bin" + it "unsafeJoin ignores leading sep" $ + str (Path.unsafeJoin (p "x") (p "/y")) `shouldBe` "x/y" + it "joinStr appends string" $ + str (Path.joinStr (p "/usr") "bin") `shouldBe` "/usr/bin" + it "joinDir requires trailing sep" $ + str (Path.joinDir (p "/usr/") (p "bin")) `shouldBe` "/usr/bin" + +------------------------------------------------------------------------------- +-- Splitting +------------------------------------------------------------------------------- + +testSplitRoot :: Spec +testSplitRoot = describe "splitRoot" $ do + it "/ has root only" $ do + let r = Path.splitRoot (p "/") + isJust r `shouldBe` True + fmap (str . fst) r `shouldBe` Just "/" + fmap (fmap str . snd) r `shouldBe` Just Nothing + it "/home has root and path" $ do + let r = Path.splitRoot (p "/home") + fmap (str . fst) r `shouldBe` Just "/" + fmap (fmap str . snd) r `shouldBe` Just (Just "home") + it "relative has no root" $ + isNothing (Path.splitRoot (p "home")) `shouldBe` True + it ". is root" $ + fmap (str . fst) (Path.splitRoot (p ".")) `shouldBe` Just "." + it "./home splits correctly" $ do + let r = Path.splitRoot (p "./home") + fmap (str . fst) r `shouldBe` Just "./" + fmap (fmap str . snd) r `shouldBe` Just (Just "home") + +testSplitFile :: Spec +testSplitFile = describe "splitFile" $ do + it "/ has no file" $ + isNothing (Path.splitFile (p "/")) `shouldBe` True + it ". has no file" $ + isNothing (Path.splitFile (p ".")) `shouldBe` True + it "/home splits to dir+file" $ do + let r = Path.splitFile (p "/home") + fmap (fmap str . fst) r `shouldBe` Just (Just "/") + fmap (str . snd) r `shouldBe` Just "home" + it "home alone has no dir" $ do + let r = Path.splitFile (p "home") + fmap (fmap str . fst) r `shouldBe` Just Nothing + fmap (str . snd) r `shouldBe` Just "home" + it "x/ has no file (dir path)" $ + isNothing (Path.splitFile (p "x/")) `shouldBe` True + +testPathView :: Spec +testPathView = describe "path view" $ do + it "takeFileName" $ + fmap str (Path.takeFileName (p "/home/user/file.txt")) + `shouldBe` Just "file.txt" + it "takeFileName on dir returns Nothing" $ + isNothing (Path.takeFileName (p "/home/user/")) `shouldBe` True + it "takeDirectory" $ + fmap str (Path.takeDirectory (p "/home/user/file.txt")) + `shouldBe` Just "/home/user/" + it "takeDirectory on plain file returns Nothing" $ + isNothing (Path.takeDirectory (p "file.txt")) `shouldBe` True + +------------------------------------------------------------------------------- +-- Extensions +------------------------------------------------------------------------------- + +testExtensions :: Spec +testExtensions = describe "extensions" $ do + it "splitExtension with extension" $ do + let r = Path.splitExtension (p "/home/user/file.txt") + fmap (str . fst) r `shouldBe` Just "/home/user/file" + fmap (str . snd) r `shouldBe` Just ".txt" + it "splitExtension no extension" $ + isNothing (Path.splitExtension (p "x")) `shouldBe` True + it "splitExtension dot file" $ + isNothing (Path.splitExtension (p ".hidden")) `shouldBe` True + it "takeExtension" $ + fmap str (Path.takeExtension (p "file.tar")) `shouldBe` Just ".tar" + it "dropExtension" $ + str (Path.dropExtension (p "/home/file.txt")) `shouldBe` "/home/file" + it "dropExtension no-op when no extension" $ + str (Path.dropExtension (p "/home/file")) `shouldBe` "/home/file" + it "takeFileBase" $ + fmap str (Path.takeFileBase (p "/home/user/file.txt")) + `shouldBe` Just "file" + it "takeFileBase hidden file" $ + fmap str (Path.takeFileBase (p "/home/user/.hidden")) + `shouldBe` Just ".hidden" + +------------------------------------------------------------------------------- +-- Equality +------------------------------------------------------------------------------- + +testEqPath :: Spec +testEqPath = describe "eqPath" $ do + it "equal plain paths" $ + Path.eqPath id (p "x") (p "x") `shouldBe` True + it "redundant separators ignored" $ + Path.eqPath id (p "x//y") (p "x/y") `shouldBe` True + it "dot segments ignored" $ + Path.eqPath id (p "x/./y") (p "x/y") `shouldBe` True + it "trailing sep matters by default" $ + Path.eqPath id (p "x/") (p "x") `shouldBe` False + it "ignoreTrailingSeparators" $ + Path.eqPath (Path.ignoreTrailingSeparators True) (p "x/") (p "x") + `shouldBe` True + it "case sensitive by default" $ + Path.eqPath id (p "x") (p "X") `shouldBe` False + it "relative paths not equal by default" $ + Path.eqPath id (p ".") (p ".") `shouldBe` False + it "allowRelativeEquality" $ + Path.eqPath (Path.allowRelativeEquality True) (p ".") (p ".") + `shouldBe` True + it "eqPathBytes exact match" $ + Path.eqPathBytes (p "x//y") (p "x//y") `shouldBe` True + it "eqPathBytes differs" $ + Path.eqPathBytes (p "x//y") (p "x/y") `shouldBe` False + +------------------------------------------------------------------------------- +-- Normalization +------------------------------------------------------------------------------- + +testPathDepth :: Spec +testPathDepth = describe "pathDepth" $ do + it "root has depth 0" $ + Path.pathDepth (p "/") `shouldBe` 0 + it "single segment" $ + Path.pathDepth (p "x") `shouldBe` 1 + it "single segment with trailing sep" $ + Path.pathDepth (p "x/") `shouldBe` 1 + it "/x has depth 1" $ + Path.pathDepth (p "/x") `shouldBe` 1 + it "/x/y has depth 2" $ + Path.pathDepth (p "/x/y") `shouldBe` 2 + it "x/y has depth 2" $ + Path.pathDepth (p "x/y") `shouldBe` 2 + it ". has depth 0 (rooted, 1 comp - 1)" $ + Path.pathDepth (p ".") `shouldBe` 0 + it "./x has depth 1" $ + Path.pathDepth (p "./x") `shouldBe` 1 + +testCollapseSeparators :: Spec +testCollapseSeparators = describe "collapseSeparators" $ do + it "no change needed" $ + str (Path.collapseSeparators (p "a/b")) `shouldBe` "a/b" + it "double separator" $ + str (Path.collapseSeparators (p "a//b")) `shouldBe` "a/b" + it "triple separator" $ + str (Path.collapseSeparators (p "a///b")) `shouldBe` "a/b" + it "preserves leading separator" $ + str (Path.collapseSeparators (p "/a//b")) `shouldBe` "/a/b" + it "preserves trailing separator" $ + str (Path.collapseSeparators (p "a//b/")) `shouldBe` "a/b/" + +testCollapseDotDots :: Spec +testCollapseDotDots = describe "collapseDotDots" $ do + it "no change needed" $ + str (Path.collapseDotDots (p "a/b/c")) `shouldBe` "a/b/c" + it "basic collapse" $ + str (Path.collapseDotDots (p "a/b/../c")) `shouldBe` "a/c" + it "multiple collapses" $ + str (Path.collapseDotDots (p "a/b/c/../../d")) `shouldBe` "a/d" + it "cannot go above start - leading dotdot kept" $ + str (Path.collapseDotDots (p "a/../../c")) `shouldBe` "../c" + it "absolute path collapse" $ + str (Path.collapseDotDots (p "/a/b/../c")) `shouldBe` "/a/c" + it "cannot go above root" $ do + -- /.. should stay as / (root is preserved) + let result = Path.collapseDotDots (p "/a/..") + str result `shouldBe` "/" + it "all segments cancel gives dot" $ + str (Path.collapseDotDots (p "a/..")) `shouldBe` "." + it "dotdot at start preserved" $ + str (Path.collapseDotDots (p "../a")) `shouldBe` "../a" + +testNormalise :: Spec +testNormalise = describe "normalise" $ do + it "collapses separators and dot segments" $ + str (Path.normalise id (p "a//./b")) `shouldBe` "a/b" + it "with ignoreTrailingSeparators drops trailing" $ + str (Path.normalise (Path.ignoreTrailingSeparators True) (p "a//b/")) + `shouldBe` "a/b" + it "without flag keeps trailing sep only if no dot segments" $ + str (Path.normalise id (p "a//b")) `shouldBe` "a/b" + +------------------------------------------------------------------------------- +-- Path prefix +------------------------------------------------------------------------------- + +testCommonPrefix :: Spec +testCommonPrefix = describe "takeCommonPrefix" $ do + it "common prefix of same paths" $ + fmap str (Path.takeCommonPrefix id (p "/a/b") (p "/a/b")) + `shouldBe` Just "/a/b" + it "common prefix to segment boundary" $ + fmap str (Path.takeCommonPrefix id (p "/a/b/c") (p "/a/b/d")) + `shouldBe` Just "/a/b" + it "no common prefix for relative paths" $ + isNothing (Path.takeCommonPrefix id (p "a/b") (p "c/d")) `shouldBe` True + it "one is prefix of other" $ + fmap str (Path.takeCommonPrefix id (p "/a/b") (p "/a/b/c")) + `shouldBe` Just "/a/b" + it "root only in common" $ + fmap str (Path.takeCommonPrefix id (p "/a") (p "/b")) + `shouldBe` Just "/" + it "no separator in common" $ + isNothing (Path.takeCommonPrefix id (p "abc") (p "abd")) `shouldBe` True + +testStripPrefix :: Spec +testStripPrefix = describe "stripPrefix" $ do + it "strips matching prefix" $ + fmap str (Path.stripPrefix id (p "/a/b") (p "/a/b/c")) + `shouldBe` Just "c" + it "strips with trailing sep in prefix" $ + fmap str (Path.stripPrefix id (p "/a/b/") (p "/a/b/c")) + `shouldBe` Just "c" + it "no match returns Nothing" $ + isNothing (Path.stripPrefix id (p "/a/x") (p "/a/b/c")) `shouldBe` True + it "not at segment boundary returns Nothing" $ + isNothing (Path.stripPrefix id (p "/a/b") (p "/a/bc")) `shouldBe` True + it "prefix equals path returns Nothing (empty remainder)" $ + isNothing (Path.stripPrefix id (p "/a/b") (p "/a/b")) `shouldBe` True + it "strips nested prefix" $ + fmap str (Path.stripPrefix id (p "/a") (p "/a/b/c")) + `shouldBe` Just "b/c" + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "FileSystem.Path" + +main :: IO () +main = hspec $ do + describe moduleName $ do + testFromString + testSeparators + testRooted + testJoin + testSplitRoot + testSplitFile + testPathView + testExtensions + testEqPath + testPathDepth + testCollapseSeparators + testCollapseDotDots + testNormalise + testCommonPrefix + testStripPrefix diff --git a/test/streamly-tests.cabal b/test/streamly-tests.cabal index 287e92529b..502811d40d 100644 --- a/test/streamly-tests.cabal +++ b/test/streamly-tests.cabal @@ -550,6 +550,14 @@ test-suite FileSystem.Handle if flag(use-streamly-core) buildable: False +test-suite FileSystem.Path + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/FileSystem/Path.hs + ghc-options: -main-is Streamly.Test.FileSystem.Path.main + if flag(use-streamly-core) + buildable: False + test-suite FileSystem.DirIO import: test-options type: exitcode-stdio-1.0 From 05db52f92f64cfb8363ea91f52d07780bc4ac3e9 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sat, 2 May 2026 04:02:11 +0530 Subject: [PATCH 2/5] Add docs to normalise and prefix operations --- .../Streamly/Internal/FileSystem/PosixPath.hs | 105 +++++++++++++++++- 1 file changed, 104 insertions(+), 1 deletion(-) diff --git a/core/src/Streamly/Internal/FileSystem/PosixPath.hs b/core/src/Streamly/Internal/FileSystem/PosixPath.hs index 3dfd5c5ad5..531c0890da 100644 --- a/core/src/Streamly/Internal/FileSystem/PosixPath.hs +++ b/core/src/Streamly/Internal/FileSystem/PosixPath.hs @@ -1706,7 +1706,44 @@ collapseDotDots (OS_PATH p) = OS_PATH $ Common.collapseDotDots Common.OS_NAME p -- | Convert the path to an equivalent but standard format for reliable --- comparison. +-- comparison. Collapses redundant separators and removes @.@ components, +-- normalises the root (including separator style on Windows), and optionally +-- folds case per the 'EqCfg' options. Does /not/ collapse @..@ segments, as +-- that is unsafe in the presence of symlinks. +-- +-- A trailing separator is preserved unless 'ignoreTrailingSeparators' is set +-- in the 'EqCfg'. +-- +-- >>> f = Path.toString . Path.normalise id . Path.fromString_ +-- +-- Redundant separators are collapsed: +-- +-- >>> f "x//y" +-- "x/y" +-- +-- @.@ components are removed: +-- +-- >>> f "x/./y" +-- "x/y" +-- +-- >>> f "x/y/." +-- "x/y" +-- +-- Trailing separator is preserved by default: +-- +-- >>> f "x/y/" +-- "x/y/" +-- +-- >>> cfg = Path.ignoreTrailingSeparators True +-- >>> g = Path.toString . Path.normalise cfg . Path.fromString_ +-- >>> g "x/y/" +-- "x/y" +-- +-- @..@ components are not collapsed: +-- +-- >>> f "x/../y" +-- "x/../y" +-- normalise :: (EqCfg -> EqCfg) -> OS_PATH_TYPE -> OS_PATH_TYPE normalise cfg (OS_PATH p) = OS_PATH $ Common.normalise @@ -1717,6 +1754,36 @@ normalise cfg (OS_PATH p) = -- Path prefix ------------------------------------------------------------------------------ +-- | Return the longest common non-empty prefix of two paths at a path segment +-- boundary. The common prefix is normalised: redundant separators and @.@ +-- components are removed. @..@ components are not collapsed. +-- +-- Returns 'Nothing' if the two paths share no common prefix (e.g. they have +-- different roots) or if the entire common body is empty. +-- +-- >>> f a b = fmap Path.toString $ Path.takeCommonPrefix id (Path.fromString_ a) (Path.fromString_ b) +-- +-- >>> f "/x/y/z" "/x/y/w" +-- Just "/x/y" +-- +-- >>> f "/x/y" "/x/z" +-- Just "/x" +-- +-- Paths sharing only the root: +-- +-- >>> f "/x/y" "/a/b" +-- Just "/" +-- +-- Paths with different roots have no common prefix: +-- +-- >>> f "x/y" "/x/y" +-- Nothing +-- +-- Redundant separators are normalised before comparison: +-- +-- >>> f "/x//y" "/x/y/z" +-- Just "/x/y" +-- takeCommonPrefix :: (EqCfg -> EqCfg) -> OS_PATH_TYPE -> OS_PATH_TYPE -> Maybe OS_PATH_TYPE takeCommonPrefix cfg (OS_PATH a) (OS_PATH b) = @@ -1725,6 +1792,42 @@ takeCommonPrefix cfg (OS_PATH a) (OS_PATH b) = Unicode.UNICODE_DECODER Common.OS_NAME (cfg eqCfg) a b +-- XXX distinguish the case of no common prefix and the paths being +-- equal? If we throw an exception we can distringuish the two cases as +-- NoCommonPrefix, and NotProperPrefix. + +-- | Strip a prefix from a path at a path segment boundary. Returns the +-- remaining suffix if the first argument is a prefix of the second, or +-- 'Nothing' if it is not or if stripping the prefix leaves an empty remainder +-- (i.e. the prefix equals the full path). +-- +-- The prefix is compared using the supplied 'EqCfg' normalisation: redundant +-- separators and @.@ components are removed before matching. @..@ components +-- are not collapsed. +-- +-- >>> f pre p = fmap Path.toString $ Path.stripPrefix id (Path.fromString_ pre) (Path.fromString_ p) +-- +-- >>> f "/x" "/x/y/z" +-- Just "y/z" +-- +-- >>> f "/x/y" "/x/y/z" +-- Just "z" +-- +-- Prefix not present: +-- +-- >>> f "/a" "/x/y" +-- Nothing +-- +-- Prefix equals full path, leaving empty remainder: +-- +-- >>> f "/x/y" "/x/y" +-- Nothing +-- +-- Redundant separators in the prefix are normalised before matching: +-- +-- >>> f "/x//y" "/x/y/z" +-- Just "z" +-- stripPrefix :: (EqCfg -> EqCfg) -> OS_PATH_TYPE -> OS_PATH_TYPE -> Maybe OS_PATH_TYPE stripPrefix cfg (OS_PATH prefix) (OS_PATH p) = From f3b293c2f5b3107dfa828a16f9543452db87afea Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sat, 16 May 2026 21:15:57 +0530 Subject: [PATCH 3/5] Make Windows drive and UNC authority case-insensitive in path equality --- core/docs/Changelog.md | 4 +- .../Internal/FileSystem/Path/Common.hs | 238 +++++++++++------- .../Streamly/Internal/FileSystem/PosixPath.hs | 32 ++- .../Internal/FileSystem/WindowsPath.hs | 41 ++- 4 files changed, 196 insertions(+), 119 deletions(-) diff --git a/core/docs/Changelog.md b/core/docs/Changelog.md index d948b2ee9e..6f0201dd3e 100644 --- a/core/docs/Changelog.md +++ b/core/docs/Changelog.md @@ -2,7 +2,9 @@ ## Unreleased -# Bug fix: Fixed `followSymlinks` option not working correctly on macOS. +* Breaking: In `FileSystem.Path` module the default for `eqPath` changed + on Windows to case-sensitive comparison. +* Bug fix: Fixed `followSymlinks` option not working correctly on macOS. ## 0.3.0 diff --git a/core/src/Streamly/Internal/FileSystem/Path/Common.hs b/core/src/Streamly/Internal/FileSystem/Path/Common.hs index d58bf6c8e5..4b4acf64ef 100644 --- a/core/src/Streamly/Internal/FileSystem/Path/Common.hs +++ b/core/src/Streamly/Internal/FileSystem/Path/Common.hs @@ -122,7 +122,7 @@ where import Control.Monad (when) import Control.Monad.Catch (MonadThrow(..)) -import Data.Char (chr, ord, isAlpha, toUpper) +import Data.Char (chr, ord, isAlpha, toLower, toUpper) import Data.Function ((&)) import Data.Functor.Identity (Identity(..)) import Data.Word (Word8, Word16) @@ -1785,6 +1785,15 @@ normalizeCaseAndSeparators = . fmap toDefaultSeparator . Array.read +-- | Change to lower case and replace separators by primary separator +{-# INLINE normalizeLowerCaseAndSeparators #-} +normalizeLowerCaseAndSeparators :: Monad m => Array Word16 -> Stream m Char +normalizeLowerCaseAndSeparators = + fmap toLower + . Unicode.decodeUtf16le' + . fmap toDefaultSeparator + . Array.read + {-# INLINE normalizeCaseWith #-} normalizeCaseWith :: (Monad m, Unbox a) => (Stream m a -> Stream m Char) -> Array a -> Stream m Char @@ -1844,38 +1853,46 @@ data WindowsRoot = | WindowsDriveRoot -- C:... or \\... deriving Eq +-- | Detect a Windows verbatim/device-namespace root, e.g. @\\\\?\\...@ +-- (separators may be forward or backward slashes). Such paths bypass Windows +-- path normalisation and must be compared and rendered verbatim. +{-# INLINE isVerbatimRoot #-} +isVerbatimRoot :: (Unbox a, Integral a) => Array a -> Bool +isVerbatimRoot a = + Array.length a >= 4 + && isSeparatorWord Windows (Array.unsafeGetIndex 0 a) + && isSeparatorWord Windows (Array.unsafeGetIndex 1 a) + && unsafeIndexChar 2 a == '?' + && isSeparatorWord Windows (Array.unsafeGetIndex 3 a) + -- | Here we must pass a path i.e. either a drive root or a UNC path, it must -- not be a plain root. If not then this function will not work correctly e.g. -- it might change \/ to // making the path a share name from a normal path. +-- +-- The drive letter and UNC server/share name are always compared +-- case-insensitively (Windows file systems are case-insensitive on these). +-- Verbatim @\\\\?\\@ paths are compared byte-for-byte with no normalisation. eqWindowsRootWithDrive :: (Unbox a, Integral a) => - Bool -> Array a -> Array a -> Bool -eqWindowsRootWithDrive ignCase a b = - -- XXX we should not normalize Windows literal paths in any case - if ignCase - then + Array a -> Array a -> Bool +eqWindowsRootWithDrive a b + | isVerbatimRoot a || isVerbatimRoot b = Array.byteEq a b + | otherwise = + -- XXX We probably do not want to translate UnC etc. to UNC. + -- Such a path should either be rejected in splitRoot or we + -- should not translate that here. + -- XXX if so write test cases for that. let f = normalizeCaseAndSeparators . Array.unsafeCast - -- XXX We probably do not want to translate UnC etc. to UNC. - -- Such a path should either be rejected in splitRoot or we - -- should not translate that here. - -- XXX if so write test cases for that. - in runIdentity $ Stream.eqBy (==) (f a) (f b) - else - let f = fmap toDefaultSeparator . Array.read - -- XXX should we ignore case for drives anyway? irrespective of the - -- remaining path. Are there case sensitive filesystems on windows? - -- Are drives ever case sensitive? - -- XXX if so write test cases for that. in runIdentity $ Stream.eqBy (==) (f a) (f b) -- | We should call this only when the roots are either both absolute or both -- null otherwise it may not function correctly. {-# INLINE eqAbsOrNullRoots #-} eqAbsOrNullRoots :: (Unbox a, Integral a) => - Bool -> OS -> Array a -> Array a -> Bool -eqAbsOrNullRoots _ Posix a b = + OS -> Array a -> Array a -> Bool +eqAbsOrNullRoots Posix a b = -- a can be "/" and b can be "//" Array.null a == Array.null b -eqAbsOrNullRoots ignCase Windows a b = eqWindowsRootWithDrive ignCase a b +eqAbsOrNullRoots Windows a b = eqWindowsRootWithDrive a b -- | Can only be either "", '.', './' or '/' (or Windows separators) getPlainRootType :: (Unbox a, Integral a) => Array a -> PlainRoot @@ -1896,25 +1913,25 @@ getWindowsRootType arr = then WindowsDriveRoot else WindowsPlainRoot -eqWindowsRootLax :: (Unbox a, Integral a) => Bool -> Array a -> Array a -> Bool -eqWindowsRootLax ignCase a b = +eqWindowsRootLax :: (Unbox a, Integral a) => Array a -> Array a -> Bool +eqWindowsRootLax a b = let aType = getWindowsRootType a bType = getWindowsRootType b in aType == bType && ( (aType == WindowsPlainRoot && eqPlainRootLax a b) - || eqWindowsRootWithDrive ignCase a b + || eqWindowsRootWithDrive a b ) {-# INLINABLE eqRootLax #-} -eqRootLax :: (Unbox a, Integral a) => Bool -> OS -> Array a -> Array a -> Bool -eqRootLax _ Posix a b = eqPlainRootLax a b -eqRootLax ignCase Windows a b = eqWindowsRootLax ignCase a b +eqRootLax :: (Unbox a, Integral a) => OS -> Array a -> Array a -> Bool +eqRootLax Posix a b = eqPlainRootLax a b +eqRootLax Windows a b = eqWindowsRootLax a b -eqRootStrict :: (Unbox a, Integral a) => Bool -> OS -> Array a -> Array a -> Bool -eqRootStrict ignCase os rootA rootB = +eqRootStrict :: (Unbox a, Integral a) => OS -> Array a -> Array a -> Bool +eqRootStrict os rootA rootB = (not (hasRelativeRoot os rootA) && not (hasRelativeRoot os rootB)) - && eqAbsOrNullRoots ignCase os rootA rootB + && eqAbsOrNullRoots os rootA rootB {-# INLINE eqComponentsWith #-} eqComponentsWith :: (Unbox a, Integral a) => @@ -1948,26 +1965,31 @@ eqComponentsWith EqCfg{..} decoder os a b = eqPath :: (Unbox a, Integral a) => (Stream Identity a -> Stream Identity Char) -> OS -> EqCfg -> Array a -> Array a -> Bool -eqPath decoder os eqCfg@(EqCfg{..}) a b = - let (rootA, stemA) = splitRoot os a - (rootB, stemB) = splitRoot os b - - eqRelative = - if _allowRelativeEquality - then eqRootLax _ignoreCase os rootA rootB - else eqRootStrict _ignoreCase os rootA rootB - - -- XXX If one ends in a "." and the other ends in ./ (and same for - -- ending with ".." and "../") then they can be equal. We can append a - -- slash in these two cases before comparing. - eqTrailingSep = - _ignoreTrailingSeparators - || hasTrailingSeparator os a == hasTrailingSeparator os b - - in - eqRelative - && eqTrailingSep - && eqComponentsWith eqCfg decoder os stemA stemB +eqPath decoder os eqCfg@(EqCfg{..}) a b + -- Verbatim "\\?\..." paths bypass all normalisation, even case folding + -- and separator normalisation, and are compared byte-for-byte. Mixing a + -- verbatim path with a non-verbatim path can never compare equal. + | os == Windows && (isVerbatimRoot a || isVerbatimRoot b) = + Array.byteEq a b + | otherwise = + let (rootA, stemA) = splitRoot os a + (rootB, stemB) = splitRoot os b + + eqRelative = + if _allowRelativeEquality + then eqRootLax os rootA rootB + else eqRootStrict os rootA rootB + + -- XXX If one ends in a "." and the other ends in ./ (and same for + -- ending with ".." and "../") then they can be equal. We can + -- append a slash in these two cases before comparing. + eqTrailingSep = + _ignoreTrailingSeparators + || hasTrailingSeparator os a == hasTrailingSeparator os b + + in eqRelative + && eqTrailingSep + && eqComponentsWith eqCfg decoder os stemA stemB ------------------------------------------------------------------------------ -- Normalization @@ -1979,21 +2001,33 @@ eqPath decoder os eqCfg@(EqCfg{..}) a b = -- | Here we must pass a path i.e. either a drive root or a UNC path, it must -- not be a plain root. If not then this function will not work correctly e.g. -- it might change \/ to // making the path a share name from a normal path. +-- +-- Canonicalisation rules: +-- +-- * Drive root: the drive letter is upper-cased (e.g. @c:\\@ -> @C:\\@). +-- * UNC root: the entire root (server and share name) is lower-cased +-- (e.g. @\\\\Server\\Share\\@ -> @\\\\server\\share\\@). +-- * Verbatim @\\\\?\\@ device paths are left untouched. +-- +-- Separators in non-verbatim roots are normalised to the primary separator. normaliseWindowsDriveRoot :: (Unbox a, Integral a) => - Bool -> Array a -> Array a -normaliseWindowsDriveRoot ignCase a = - -- XXX we should not normalize Windows literal paths in any case - let stream = - if ignCase - -- XXX We probably do not want to translate UnC etc. to UNC. - -- Such a path should either be rejected in splitRoot or we - -- should not translate that here. - -- XXX if so write test cases for that. - then fmap charToWord - $ normalizeCaseAndSeparators - $ Array.unsafeCast a - else fmap toDefaultSeparator $ Array.read a - in Array.fromPureStream stream + Array a -> Array a +normaliseWindowsDriveRoot a + | isVerbatimRoot a = a + | isAbsoluteUNC a = + -- XXX We probably do not want to translate UnC etc. to UNC. + -- Such a path should either be rejected in splitRoot or we + -- should not translate that here. + -- XXX if so write test cases for that. + Array.fromPureStream + $ fmap charToWord + $ normalizeLowerCaseAndSeparators + $ Array.unsafeCast a + | otherwise = + Array.fromPureStream + $ fmap charToWord + $ normalizeCaseAndSeparators + $ Array.unsafeCast a -- We have already deduplicated the separators in splitRoot {-# INLINE normalisePlainRoot #-} @@ -2004,12 +2038,12 @@ normalisePlainRoot os a = PlainRootAbs -> Array.fromList [ charToWord (primarySeparator os) ] {-# INLINABLE normaliseRoot #-} -normaliseRoot :: (Unbox a, Integral a) => Bool -> OS -> Array a -> Array a -normaliseRoot _ Posix a = normalisePlainRoot Posix a -normaliseRoot ignCase Windows a = +normaliseRoot :: (Unbox a, Integral a) => OS -> Array a -> Array a +normaliseRoot Posix a = normalisePlainRoot Posix a +normaliseRoot Windows a = case getWindowsRootType a of WindowsPlainRoot -> normalisePlainRoot Windows a - WindowsDriveRoot -> normaliseWindowsDriveRoot ignCase a + WindowsDriveRoot -> normaliseWindowsDriveRoot a {-# INLINE normaliseComponents #-} normaliseComponents :: (Unbox a, Integral a) => @@ -2056,27 +2090,31 @@ appendTrailingSep os arr = normalise :: (Unbox a, Integral a) => (Stream Identity a -> Stream Identity Char) -> OS -> EqCfg -> Array a -> Array a -normalise decoder os eqCfg@EqCfg{..} p = - -- NOTE: _allowRelativeEquality impacts comparison but not normalization - -- of the root. - let (root, body) = splitRoot os p - -- XXX We are writing the array multiple times, for root, for body and - -- then for adding a separator. We can either use a mutarray or stream - -- all the normalized parts once to create array only once. - nRoot = normaliseRoot _ignoreCase os root - nBody = normaliseComponents eqCfg decoder os body - result = joinRootBody os nRoot nBody - -- The body's trailing separator is dropped by normaliseComponents; - -- restore it if it was present in the input and the caller wants it - -- kept. - keepTrailingSep = - not _ignoreTrailingSeparators - && not (Array.null nBody) - && hasTrailingSeparator os p - && not (hasTrailingSeparator os result) - in if keepTrailingSep - then appendTrailingSep os result - else result +normalise decoder os eqCfg@EqCfg{..} p + -- Verbatim "\\?\..." paths bypass all normalisation, regardless of the + -- EqCfg flags. + | os == Windows && isVerbatimRoot p = p + | otherwise = + -- NOTE: _allowRelativeEquality impacts comparison but not normalization + -- of the root. + let (root, body) = splitRoot os p + -- XXX We are writing the array multiple times, for root, for body + -- and then for adding a separator. We can either use a mutarray or + -- stream all the normalized parts once to create array only once. + nRoot = normaliseRoot os root + nBody = normaliseComponents eqCfg decoder os body + result = joinRootBody os nRoot nBody + -- The body's trailing separator is dropped by normaliseComponents; + -- restore it if it was present in the input and the caller wants + -- it kept. + keepTrailingSep = + not _ignoreTrailingSeparators + && not (Array.null nBody) + && hasTrailingSeparator os p + && not (hasTrailingSeparator os result) + in if keepTrailingSep + then appendTrailingSep os result + else result ------------------------------------------------------------------------------ -- Path prefix @@ -2097,13 +2135,17 @@ takeCommonPrefix decoder os EqCfg{..} a b = rootsMatch = if _allowRelativeEquality - then eqRootLax _ignoreCase os rootA rootB - else eqRootStrict _ignoreCase os rootA rootB + then eqRootLax os rootA rootB + else eqRootStrict os rootA rootB + + commonRoot = normaliseRoot os rootA - commonRoot = normaliseRoot _ignoreCase os rootA + -- Verbatim paths must never have their bytes altered, including case + -- folding, regardless of the EqCfg setting. + verbatim = os == Windows && (isVerbatimRoot a || isVerbatimRoot b) compEq x y = - if _ignoreCase + if _ignoreCase && not verbatim then runIdentity $ Stream.eqBy (==) (normalizeCaseWith decoder x) (normalizeCaseWith decoder y) @@ -2140,11 +2182,17 @@ stripPrefix decoder os EqCfg{..} prefix path = rootsMatch = if _allowRelativeEquality - then eqRootLax _ignoreCase os rootPre rootPath - else eqRootStrict _ignoreCase os rootPre rootPath + then eqRootLax os rootPre rootPath + else eqRootStrict os rootPre rootPath + + -- Verbatim paths must never have their bytes altered, including case + -- folding, regardless of the EqCfg setting. + verbatim = + os == Windows + && (isVerbatimRoot prefix || isVerbatimRoot path) compEq x y = - if _ignoreCase + if _ignoreCase && not verbatim then runIdentity $ Stream.eqBy (==) (normalizeCaseWith decoder x) (normalizeCaseWith decoder y) diff --git a/core/src/Streamly/Internal/FileSystem/PosixPath.hs b/core/src/Streamly/Internal/FileSystem/PosixPath.hs index 531c0890da..0c0df1a7e0 100644 --- a/core/src/Streamly/Internal/FileSystem/PosixPath.hs +++ b/core/src/Streamly/Internal/FileSystem/PosixPath.hs @@ -1483,7 +1483,15 @@ takeDirectory x = splitFile x >>= fst -- Path equality ------------------------------------------------------------------------------ -#ifndef IS_WINDOWS +-- NOTE: Default path equality is strict lexical equality, including case. +-- Filesystem case sensitivity is filesystem-specific, not OS-specific; +-- e.g. macOS paths are often case-insensitive despite being POSIX. +-- Even on case-insensitive filesystems, case is usually preserved, so +-- comparing case retains information instead of discarding it. A strict +-- default keeps equality deterministic, pure, and independent of runtime +-- filesystem semantics. Users can opt in to less strict/platform-specific +-- comparison semantics if needed. + -- | Default equality check configuration. -- -- >>> :{ @@ -1493,26 +1501,11 @@ takeDirectory x = splitFile x >>= fst -- . Path.allowRelativeEquality False -- :} -- -#else --- | Default equality check configuration. --- --- >>> :{ --- eqCfg = --- Path.ignoreTrailingSeparators False --- . Path.ignoreCase True --- . Path.allowRelativeEquality False --- :} --- -#endif eqCfg :: EqCfg eqCfg = Common.EqCfg { _ignoreTrailingSeparators = False , _allowRelativeEquality = False -#ifndef IS_WINDOWS , _ignoreCase = False -#else - , _ignoreCase = True -#endif } -- | When set to 'False' (default): @@ -1537,9 +1530,12 @@ ignoreTrailingSeparators val conf = conf { _ignoreTrailingSeparators = val } -- | When set to 'False', comparison is case sensitive. -- --- /Posix Default/: False +-- On Windows this flag controls only the case-sensitivity of non-root path +-- segments. The drive letter and UNC server\/share name are /always/ compared +-- case-insensitively. Verbatim @\\\\?\\@ paths are always compared +-- case-sensitively (byte-for-byte), independent of this flag. -- --- /Windows Default/: True +-- /Default/: False ignoreCase :: Bool -> EqCfg -> EqCfg ignoreCase val conf = conf { _ignoreCase = val } diff --git a/core/src/Streamly/Internal/FileSystem/WindowsPath.hs b/core/src/Streamly/Internal/FileSystem/WindowsPath.hs index 856e954263..d3b2d42567 100644 --- a/core/src/Streamly/Internal/FileSystem/WindowsPath.hs +++ b/core/src/Streamly/Internal/FileSystem/WindowsPath.hs @@ -234,21 +234,31 @@ joinDir -- -- On Windows, the following is different: -- --- * paths are normalized by replacing forward slash path separators by --- backslashes. --- * default configuration uses case-insensitive comparison. +-- * forward slash and backslash are treated as equivalent path separators. +-- * the drive letter and UNC server/share name are /always/ compared +-- case-insensitively, regardless of the 'ignoreCase' setting, because +-- Windows file systems treat these case-insensitively. Only the rest of +-- the path follows the 'ignoreCase' setting. +-- * verbatim @\\\\?\\@ device paths are compared byte-for-byte. They bypass +-- all normalisation, including case folding, separator translation and +-- trailing separator handling, regardless of the 'EqCfg' settings. -- -- >>> :{ -- eq a b = Path.eqPath id (Path.fromString_ a) (Path.fromString_ b) -- :} -- --- The cases that are different from Posix: +-- Separators are interchangeable: -- -- >>> eq "x\\y" "x/y" -- True -- +-- The default is case-sensitive for non-root path components, matching Posix: +-- -- >>> eq "x" "X" --- True +-- False +-- +-- Drive-only paths are relative and so are not equal under the default +-- (which has @allowRelativeEquality@ set to 'False'): -- -- >>> eq "c:" "C:" -- False @@ -259,6 +269,22 @@ joinDir -- >>> eq "c:x" "c:x" -- False -- +-- Drive letters compare case-insensitively when paths are absolute: +-- +-- >>> eq "c:/x" "C:/x" +-- True +-- +-- UNC authority is also case-insensitive: +-- +-- >>> eq "\\\\Server\\Share\\x" "\\\\server\\share\\x" +-- True +-- +-- Verbatim @\\\\?\\@ paths are compared byte-for-byte, so they are +-- case-sensitive even on the drive letter and authority parts: +-- +-- >>> eq "\\\\?\\C:\\x" "\\\\?\\c:\\x" +-- False +-- -- >>> :{ -- cfg = Path.ignoreTrailingSeparators True -- . Path.ignoreCase True @@ -287,6 +313,11 @@ joinDir -- >>> eq "x" "x" -- True -- +-- Even with @ignoreCase True@ the verbatim path is not case-folded: +-- +-- >>> eq "\\\\?\\C:\\x" "\\\\?\\c:\\x" +-- False +-- eqPath :: (EqCfg -> EqCfg) -> OS_PATH_TYPE -> OS_PATH_TYPE -> Bool eqPath cfg (OS_PATH a) (OS_PATH b) = Common.eqPath Unicode.UNICODE_DECODER From 0813f66d6e364368d64767719dd5dcf4c301f9e4 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sat, 16 May 2026 22:15:00 +0530 Subject: [PATCH 4/5] Split path tests into PosixPath and WindowsPath suites --- .../Internal/FileSystem/Path/Common.hs | 16 +- .../Streamly/Internal/FileSystem/PosixPath.hs | 113 +++- .../Internal/FileSystem/WindowsPath.hs | 11 +- .../Test/FileSystem/{Path.hs => PosixPath.hs} | 261 ++++++++- test/Streamly/Test/FileSystem/WindowsPath.hs | 529 ++++++++++++++++++ test/streamly-tests.cabal | 14 +- 6 files changed, 916 insertions(+), 28 deletions(-) rename test/Streamly/Test/FileSystem/{Path.hs => PosixPath.hs} (57%) create mode 100644 test/Streamly/Test/FileSystem/WindowsPath.hs diff --git a/core/src/Streamly/Internal/FileSystem/Path/Common.hs b/core/src/Streamly/Internal/FileSystem/Path/Common.hs index 4b4acf64ef..ebf59bb4c5 100644 --- a/core/src/Streamly/Internal/FileSystem/Path/Common.hs +++ b/core/src/Streamly/Internal/FileSystem/Path/Common.hs @@ -1869,9 +1869,13 @@ isVerbatimRoot a = -- not be a plain root. If not then this function will not work correctly e.g. -- it might change \/ to // making the path a share name from a normal path. -- --- The drive letter and UNC server/share name are always compared --- case-insensitively (Windows file systems are case-insensitive on these). --- Verbatim @\\\\?\\@ paths are compared byte-for-byte with no normalisation. +-- The drive letter (and the UNC server name that 'splitRoot' returns as the +-- root) is always compared case-insensitively. Verbatim @\\\\?\\@ paths are +-- compared byte-for-byte with no normalisation. +-- +-- Note: 'splitRoot' currently treats the UNC share name as the first body +-- component, not as part of the root. The share name therefore follows the +-- body's 'ignoreCase' rule, not this root-only rule. eqWindowsRootWithDrive :: (Unbox a, Integral a) => Array a -> Array a -> Bool eqWindowsRootWithDrive a b @@ -2005,8 +2009,10 @@ eqPath decoder os eqCfg@(EqCfg{..}) a b -- Canonicalisation rules: -- -- * Drive root: the drive letter is upper-cased (e.g. @c:\\@ -> @C:\\@). --- * UNC root: the entire root (server and share name) is lower-cased --- (e.g. @\\\\Server\\Share\\@ -> @\\\\server\\share\\@). +-- * UNC root: the root (currently just the server name) is lower-cased +-- (e.g. @\\\\Server\\@ -> @\\\\server\\@). The share name is treated as +-- the first body component by 'splitRoot' and is normalised by +-- 'normaliseComponents' instead. -- * Verbatim @\\\\?\\@ device paths are left untouched. -- -- Separators in non-verbatim roots are normalised to the primary separator. diff --git a/core/src/Streamly/Internal/FileSystem/PosixPath.hs b/core/src/Streamly/Internal/FileSystem/PosixPath.hs index 0c0df1a7e0..983408b215 100644 --- a/core/src/Streamly/Internal/FileSystem/PosixPath.hs +++ b/core/src/Streamly/Internal/FileSystem/PosixPath.hs @@ -1531,9 +1531,11 @@ ignoreTrailingSeparators val conf = conf { _ignoreTrailingSeparators = val } -- | When set to 'False', comparison is case sensitive. -- -- On Windows this flag controls only the case-sensitivity of non-root path --- segments. The drive letter and UNC server\/share name are /always/ compared --- case-insensitively. Verbatim @\\\\?\\@ paths are always compared --- case-sensitively (byte-for-byte), independent of this flag. +-- segments. The drive letter (and the UNC server name that 'splitRoot' +-- returns as the root) is /always/ compared case-insensitively. The UNC +-- share name is currently treated as a body segment and so follows this +-- flag. Verbatim @\\\\?\\@ paths are always compared case-sensitively +-- (byte-for-byte), independent of this flag. -- -- /Default/: False ignoreCase :: Bool -> EqCfg -> EqCfg @@ -1701,11 +1703,12 @@ collapseDotDots :: OS_PATH_TYPE -> OS_PATH_TYPE collapseDotDots (OS_PATH p) = OS_PATH $ Common.collapseDotDots Common.OS_NAME p +#ifndef IS_WINDOWS -- | Convert the path to an equivalent but standard format for reliable -- comparison. Collapses redundant separators and removes @.@ components, --- normalises the root (including separator style on Windows), and optionally --- folds case per the 'EqCfg' options. Does /not/ collapse @..@ segments, as --- that is unsafe in the presence of symlinks. +-- normalises the root, and optionally folds case per the 'EqCfg' options. +-- Does /not/ collapse @..@ segments, as that is unsafe in the presence of +-- symlinks. -- -- A trailing separator is preserved unless 'ignoreTrailingSeparators' is set -- in the 'EqCfg'. @@ -1740,6 +1743,50 @@ collapseDotDots (OS_PATH p) = -- >>> f "x/../y" -- "x/../y" -- +#else +-- | Convert the path to an equivalent but standard format for reliable +-- comparison. Collapses redundant separators and removes @.@ components, +-- normalises the root (drive letter upper-cased, UNC server name +-- lower-cased, forward separators converted to backslash), and optionally +-- folds case per the 'EqCfg' options. Verbatim @\\\\?\\@ paths are left +-- untouched. Does /not/ collapse @..@ segments, as that is unsafe in the +-- presence of symlinks. +-- +-- A trailing separator is preserved unless 'ignoreTrailingSeparators' is set +-- in the 'EqCfg'. +-- +-- >>> f = Path.toString . Path.normalise id . Path.fromString_ +-- +-- Forward separators are normalised to backslash; redundant separators are +-- collapsed: +-- +-- >>> f "x//y" +-- "x\\y" +-- +-- >>> f "x/./y" +-- "x\\y" +-- +-- Drive letter is upper-cased: +-- +-- >>> f "c:\\x" +-- "C:\\x" +-- +-- UNC server name is lower-cased; rest of the path follows ignoreCase: +-- +-- >>> f "\\\\Server\\share\\x" +-- "\\\\server\\share\\x" +-- +-- Verbatim paths are left untouched: +-- +-- >>> f "\\\\?\\C:\\Foo" +-- "\\\\?\\C:\\Foo" +-- +-- @..@ components are not collapsed: +-- +-- >>> f "x/../y" +-- "x\\..\\y" +-- +#endif normalise :: (EqCfg -> EqCfg) -> OS_PATH_TYPE -> OS_PATH_TYPE normalise cfg (OS_PATH p) = OS_PATH $ Common.normalise @@ -1750,6 +1797,7 @@ normalise cfg (OS_PATH p) = -- Path prefix ------------------------------------------------------------------------------ +#ifndef IS_WINDOWS -- | Return the longest common non-empty prefix of two paths at a path segment -- boundary. The common prefix is normalised: redundant separators and @.@ -- components are removed. @..@ components are not collapsed. @@ -1780,6 +1828,32 @@ normalise cfg (OS_PATH p) = -- >>> f "/x//y" "/x/y/z" -- Just "/x/y" -- +#else +-- | Return the longest common non-empty prefix of two paths at a path segment +-- boundary. The common prefix is normalised: redundant separators and @.@ +-- components are removed. @..@ components are not collapsed. +-- +-- Returns 'Nothing' if the two paths share no common prefix (e.g. they have +-- different roots) or if the entire common body is empty. +-- +-- >>> f a b = fmap Path.toString $ Path.takeCommonPrefix id (Path.fromString_ a) (Path.fromString_ b) +-- +-- Same drive, common segments under it: +-- +-- >>> f "C:\\x\\y\\z" "C:\\x\\y\\w" +-- Just "C:\\x\\y" +-- +-- Drive letter case differs but drive is case-insensitive: +-- +-- >>> f "c:\\x\\y" "C:\\x\\z" +-- Just "C:\\x" +-- +-- Different drives share no common prefix: +-- +-- >>> f "C:\\x" "D:\\x" +-- Nothing +-- +#endif takeCommonPrefix :: (EqCfg -> EqCfg) -> OS_PATH_TYPE -> OS_PATH_TYPE -> Maybe OS_PATH_TYPE takeCommonPrefix cfg (OS_PATH a) (OS_PATH b) = @@ -1792,6 +1866,7 @@ takeCommonPrefix cfg (OS_PATH a) (OS_PATH b) = -- equal? If we throw an exception we can distringuish the two cases as -- NoCommonPrefix, and NotProperPrefix. +#ifndef IS_WINDOWS -- | Strip a prefix from a path at a path segment boundary. Returns the -- remaining suffix if the first argument is a prefix of the second, or -- 'Nothing' if it is not or if stripping the prefix leaves an empty remainder @@ -1824,6 +1899,32 @@ takeCommonPrefix cfg (OS_PATH a) (OS_PATH b) = -- >>> f "/x//y" "/x/y/z" -- Just "z" -- +#else +-- | Strip a prefix from a path at a path segment boundary. Returns the +-- remaining suffix if the first argument is a prefix of the second, or +-- 'Nothing' if it is not or if stripping the prefix leaves an empty remainder +-- (i.e. the prefix equals the full path). +-- +-- The prefix is compared using the supplied 'EqCfg' normalisation. The drive +-- letter is matched case-insensitively. Verbatim @\\\\?\\@ paths are matched +-- byte-for-byte. +-- +-- >>> f pre p = fmap Path.toString $ Path.stripPrefix id (Path.fromString_ pre) (Path.fromString_ p) +-- +-- >>> f "C:\\x" "C:\\x\\y\\z" +-- Just "y\\z" +-- +-- Drive letter case differs but the drive matches: +-- +-- >>> f "c:\\x" "C:\\x\\y" +-- Just "y" +-- +-- Prefix not present: +-- +-- >>> f "C:\\a" "C:\\x\\y" +-- Nothing +-- +#endif stripPrefix :: (EqCfg -> EqCfg) -> OS_PATH_TYPE -> OS_PATH_TYPE -> Maybe OS_PATH_TYPE stripPrefix cfg (OS_PATH prefix) (OS_PATH p) = diff --git a/core/src/Streamly/Internal/FileSystem/WindowsPath.hs b/core/src/Streamly/Internal/FileSystem/WindowsPath.hs index d3b2d42567..201df48a94 100644 --- a/core/src/Streamly/Internal/FileSystem/WindowsPath.hs +++ b/core/src/Streamly/Internal/FileSystem/WindowsPath.hs @@ -235,10 +235,11 @@ joinDir -- On Windows, the following is different: -- -- * forward slash and backslash are treated as equivalent path separators. --- * the drive letter and UNC server/share name are /always/ compared +-- * the drive letter (and the UNC server name) is /always/ compared -- case-insensitively, regardless of the 'ignoreCase' setting, because --- Windows file systems treat these case-insensitively. Only the rest of --- the path follows the 'ignoreCase' setting. +-- Windows file systems treat them as case-insensitive. The UNC share +-- name is currently treated as a body component by 'splitRoot' and so +-- still follows the 'ignoreCase' setting. -- * verbatim @\\\\?\\@ device paths are compared byte-for-byte. They bypass -- all normalisation, including case folding, separator translation and -- trailing separator handling, regardless of the 'EqCfg' settings. @@ -274,9 +275,9 @@ joinDir -- >>> eq "c:/x" "C:/x" -- True -- --- UNC authority is also case-insensitive: +-- The UNC server name is also case-insensitive: -- --- >>> eq "\\\\Server\\Share\\x" "\\\\server\\share\\x" +-- >>> eq "\\\\Server\\share\\x" "\\\\server\\share\\x" -- True -- -- Verbatim @\\\\?\\@ paths are compared byte-for-byte, so they are diff --git a/test/Streamly/Test/FileSystem/Path.hs b/test/Streamly/Test/FileSystem/PosixPath.hs similarity index 57% rename from test/Streamly/Test/FileSystem/Path.hs rename to test/Streamly/Test/FileSystem/PosixPath.hs index ed36b2358e..5d88f63a5f 100644 --- a/test/Streamly/Test/FileSystem/Path.hs +++ b/test/Streamly/Test/FileSystem/PosixPath.hs @@ -1,28 +1,34 @@ -- | --- Module : Streamly.Test.FileSystem.Path +-- Module : Streamly.Test.FileSystem.PosixPath -- Copyright : (c) 2024 Composewell Technologies -- License : BSD-3-Clause -- Maintainer : streamly@composewell.com -- Stability : experimental -- Portability : GHC +-- +-- Tests for "Streamly.Internal.FileSystem.PosixPath". Posix path semantics +-- are independent of the host OS, so this test suite runs on every platform. -module Streamly.Test.FileSystem.Path (main) where +module Streamly.Test.FileSystem.PosixPath (main) where +import Data.Functor.Identity (Identity, runIdentity) import Data.Maybe (isJust, isNothing) +import Streamly.Internal.FileSystem.PosixPath (PosixPath) import Test.Hspec as H -import qualified Streamly.Internal.FileSystem.Path as Path +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.FileSystem.PosixPath as Path ------------------------------------------------------------------------------- -- Utilities ------------------------------------------------------------------------------- -- | Build a path from a string, failing at runtime if invalid. -p :: String -> Path.Path +p :: String -> PosixPath p = Path.fromString_ -- | Round-trip a path through toString. -str :: Path.Path -> String +str :: PosixPath -> String str = Path.toString @@ -33,11 +39,11 @@ str = Path.toString testFromString :: Spec testFromString = describe "fromString" $ do it "valid absolute path" $ - isJust (Path.fromString "/usr/bin" :: Maybe Path.Path) `shouldBe` True + isJust (Path.fromString "/usr/bin" :: Maybe PosixPath) `shouldBe` True it "valid relative path" $ - isJust (Path.fromString "a/b/c" :: Maybe Path.Path) `shouldBe` True + isJust (Path.fromString "a/b/c" :: Maybe PosixPath) `shouldBe` True it "empty string is invalid" $ - isNothing (Path.fromString "" :: Maybe Path.Path) `shouldBe` True + isNothing (Path.fromString "" :: Maybe PosixPath) `shouldBe` True it "toString . fromString_ roundtrip" $ str (p "/usr/bin") `shouldBe` "/usr/bin" it "relative roundtrip" $ @@ -313,28 +319,265 @@ testStripPrefix = describe "stripPrefix" $ do fmap str (Path.stripPrefix id (p "/a") (p "/a/b/c")) `shouldBe` Just "b/c" +------------------------------------------------------------------------------- +-- Validation +------------------------------------------------------------------------------- + +testValidatePath :: Spec +testValidatePath = describe "validatePath" $ do + let isValid = isJust . Path.validatePath . Path.encodeString + it "empty path invalid" $ isValid "" `shouldBe` False + it "null char invalid" $ isValid "\0" `shouldBe` False + +------------------------------------------------------------------------------- +-- splitPath (with separators kept on dir components) +------------------------------------------------------------------------------- + +splitToList :: (PosixPath -> Stream.Stream Identity PosixPath) -> String -> [String] +splitToList f = runIdentity . Stream.toList . fmap str . f . p + +testSplitPath :: Spec +testSplitPath = describe "splitPath" $ do + let cases = + [ (".", ["."]) + , ("././", ["./"]) + , ("./a/b/.", ["./", "a/", "b/"]) + , ("..", [".."]) + , ("../", ["../"]) + , ("a/..", ["a/", ".."]) + , ("/", ["/"]) + , ("//", ["/"]) + , ("/x", ["/", "x"]) + , ("/./x/", ["/", "x/"]) + , ("/x/./y", ["/", "x/", "y"]) + , ("/x/../y", ["/", "x/", "../", "y"]) + , ("/x///y", ["/", "x/", "y"]) + , ("/x/\\y", ["/", "x/", "\\y"]) + ] + mapM_ + (\(input, expected) -> + it ("splitPath " ++ show input) $ + splitToList Path.splitPath input `shouldBe` expected) + cases + +testSplitPath_ :: Spec +testSplitPath_ = describe "splitPath_ (no separators on dir)" $ do + let cases = + [ (".", ["."]) + , ("././", ["."]) + , (".//", ["."]) + , ("//", ["/"]) + , ("//x/y/", ["/", "x", "y"]) + , ("./a", [".", "a"]) + , ("a/.", ["a"]) + , ("/", ["/"]) + , ("/x", ["/", "x"]) + , ("/./x/", ["/", "x"]) + , ("/x/./y", ["/", "x", "y"]) + , ("/x/../y", ["/", "x", "..", "y"]) + , ("/x///y", ["/", "x", "y"]) + , ("/x/\\y", ["/", "x", "\\y"]) + ] + mapM_ + (\(input, expected) -> + it ("splitPath_ " ++ show input) $ + splitToList Path.splitPath_ input `shouldBe` expected) + cases + +------------------------------------------------------------------------------- +-- Extended splitRoot +------------------------------------------------------------------------------- + +testSplitRootExtended :: Spec +testSplitRootExtended = describe "splitRoot (extended)" $ do + let split = fmap toList . Path.splitRoot . p + toList (a, b) = (str a, fmap str b) + cases = + [ ("/", Just ("/", Nothing)) + , (".", Just (".", Nothing)) + , ("./", Just ("./", Nothing)) + , ("/home", Just ("/", Just "home")) + , ("//", Just ("//", Nothing)) + , ("./home", Just ("./", Just "home")) + , ("home", Nothing) + ] + mapM_ + (\(input, expected) -> + it ("splitRoot " ++ show input) $ split input `shouldBe` expected) + cases + +------------------------------------------------------------------------------- +-- Extended splitFile +------------------------------------------------------------------------------- + +testSplitFileExtended :: Spec +testSplitFileExtended = describe "splitFile (extended)" $ do + let split = fmap toList . Path.splitFile . p + toList (a, b) = (fmap str a, str b) + cases = + [ ("/", Nothing) + , (".", Nothing) + , ("/.", Nothing) + , ("..", Nothing) + , ("/home", Just (Just "/", "home")) + , ("./home", Just (Just "./", "home")) + , ("home", Just (Nothing, "home")) + , ("x/", Nothing) + , ("x/y", Just (Just "x/", "y")) + , ("x//y", Just (Just "x//", "y")) + , ("x/./y", Just (Just "x/./", "y")) + ] + mapM_ + (\(input, expected) -> + it ("splitFile " ++ show input) $ split input `shouldBe` expected) + cases + +------------------------------------------------------------------------------- +-- Extended splitExtension +------------------------------------------------------------------------------- + +testSplitExtensionExtended :: Spec +testSplitExtensionExtended = describe "splitExtension (extended)" $ do + let split = fmap toList . Path.splitExtension . p + toList (a, b) = (str a, str b) + cases = + [ ("/", Nothing) + , (".", Nothing) + , ("..", Nothing) + , ("x", Nothing) + , ("/x", Nothing) + , ("x/", Nothing) + , ("./x", Nothing) + , ("x/.", Nothing) + , ("x/y.", Nothing) + , ("/x.y", Just ("/x", ".y")) + , ("/x.y.", Nothing) + , ("/x.y..", Nothing) + , ("x/.y", Nothing) + , (".x", Nothing) + , ("x.", Nothing) + , (".x.y", Just (".x", ".y")) + , ("x/y.z", Just ("x/y", ".z")) + , ("x.y.z", Just ("x.y", ".z")) + , ("x..y", Just ("x.", ".y")) + , ("...", Nothing) + , ("..x", Just (".", ".x")) + , ("...x", Just ("..", ".x")) + , ("x/y.z/", Nothing) + , ("x/y", Nothing) + ] + mapM_ + (\(input, expected) -> + it ("splitExtension " ++ show input) $ + split input `shouldBe` expected) + cases + +testTakeFileBaseExtended :: Spec +testTakeFileBaseExtended = describe "takeFileBase (extended)" $ do + let tb = fmap str . Path.takeFileBase . p + it "with extension" $ tb "/home/user/file.txt" `shouldBe` Just "file" + it "no extension" $ tb "/home/user/file" `shouldBe` Just "file" + it "leading dot only segment" $ tb "/home/user/.txt" `shouldBe` Just ".txt" + it "trailing separator means no file" $ + tb "/home/user/" `shouldBe` Nothing + +------------------------------------------------------------------------------- +-- unsafeJoin +------------------------------------------------------------------------------- + +testUnsafeJoin :: Spec +testUnsafeJoin = describe "unsafeJoin" $ do + let f a b = str $ Path.unsafeJoin (p a) (p b) + it "x y" $ f "x" "y" `shouldBe` "x/y" + it "x/ y" $ f "x/" "y" `shouldBe` "x/y" + it "x /y" $ f "x" "/y" `shouldBe` "x/y" + it "x/ /y" $ f "x/" "/y" `shouldBe` "x/y" + +------------------------------------------------------------------------------- +-- dropTrailingSeparators / hasTrailingSeparator (extras) +------------------------------------------------------------------------------- + +testDropTrailingSeparatorsExtras :: Spec +testDropTrailingSeparatorsExtras = + describe "dropTrailingSeparators (extras)" $ do + let f = str . Path.dropTrailingSeparators . p + it "./ -> ." $ f "./" `shouldBe` "." + +------------------------------------------------------------------------------- +-- normalise (more cases) +------------------------------------------------------------------------------- + +testNormaliseExtras :: Spec +testNormaliseExtras = describe "normalise (extras)" $ do + let nrm cfg = str . Path.normalise cfg . p + it "ignoreTrailingSeparators False keeps trailing sep" $ + nrm id "a//b/" `shouldBe` "a/b/" + it "leading dot dropped when collapsing dot segments" $ + nrm id "./a/./b" `shouldBe` "a/b" + it "absolute path collapses dot segments" $ + nrm id "/a//./b" `shouldBe` "/a/b" + +------------------------------------------------------------------------------- +-- Path equality edge cases +------------------------------------------------------------------------------- + +testEqPathExtended :: Spec +testEqPathExtended = describe "eqPath (extended)" $ do + let eq = Path.eqPath id + it "/x equals //x" $ eq (p "/x") (p "//x") `shouldBe` True + it "x/y/. equals x/y" $ eq (p "x/y/.") (p "x/y") `shouldBe` True + it ". equal to . is False by default" $ + eq (p ".") (p ".") `shouldBe` False + it "./x equal to ./x is False by default" $ + eq (p "./x") (p "./x") `shouldBe` False + it "./x equal to x is False by default" $ + eq (p "./x") (p "x") `shouldBe` False + it "allowRelativeEquality . . True" $ + Path.eqPath (Path.allowRelativeEquality True) (p ".") (p ".") + `shouldBe` True + it "allowRelativeEquality ./x x True" $ + Path.eqPath (Path.allowRelativeEquality True) (p "./x") (p "x") + `shouldBe` True + it "allowRelativeEquality ./x ././x True" $ + Path.eqPath (Path.allowRelativeEquality True) (p "./x") (p "././x") + `shouldBe` True + it "ignoreTrailingSeparators True" $ + Path.eqPath (Path.ignoreTrailingSeparators True) (p "x/") (p "x") + `shouldBe` True + ------------------------------------------------------------------------------- -- Main ------------------------------------------------------------------------------- moduleName :: String -moduleName = "FileSystem.Path" +moduleName = "FileSystem.PosixPath" main :: IO () main = hspec $ do describe moduleName $ do testFromString + testValidatePath testSeparators + testDropTrailingSeparatorsExtras testRooted testJoin + testUnsafeJoin testSplitRoot + testSplitRootExtended testSplitFile + testSplitFileExtended + testSplitPath + testSplitPath_ testPathView testExtensions + testSplitExtensionExtended + testTakeFileBaseExtended testEqPath + testEqPathExtended testPathDepth testCollapseSeparators testCollapseDotDots testNormalise + testNormaliseExtras testCommonPrefix testStripPrefix diff --git a/test/Streamly/Test/FileSystem/WindowsPath.hs b/test/Streamly/Test/FileSystem/WindowsPath.hs new file mode 100644 index 0000000000..4622749a63 --- /dev/null +++ b/test/Streamly/Test/FileSystem/WindowsPath.hs @@ -0,0 +1,529 @@ +-- | +-- Module : Streamly.Test.FileSystem.WindowsPath +-- Copyright : (c) 2024 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Tests for "Streamly.Internal.FileSystem.WindowsPath". Windows path +-- semantics are independent of the host OS, so this test suite runs on every +-- platform. + +module Streamly.Test.FileSystem.WindowsPath (main) where + +import Control.Exception (SomeException, evaluate, try) +import Data.Either (isLeft) +import Data.Functor.Identity (Identity, runIdentity) +import Data.Maybe (isJust, isNothing) +import Streamly.Internal.FileSystem.WindowsPath (WindowsPath) +import Test.Hspec as H + +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.FileSystem.WindowsPath as Path + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +-- | Build a path from a string, failing at runtime if invalid. +p :: String -> WindowsPath +p = Path.fromString_ + +-- | Round-trip a path through toString. +str :: WindowsPath -> String +str = Path.toString + +-- | True if a pure 'String' value forces to an exception. +fails :: String -> IO Bool +fails x = isLeft <$> (try (evaluate x) :: IO (Either SomeException String)) + +------------------------------------------------------------------------------- +-- Construction and conversion +------------------------------------------------------------------------------- + +testFromString :: Spec +testFromString = describe "fromString" $ do + it "valid drive-absolute path" $ + isJust (Path.fromString "C:\\Users" :: Maybe WindowsPath) + `shouldBe` True + it "valid relative path" $ + isJust (Path.fromString "a\\b\\c" :: Maybe WindowsPath) + `shouldBe` True + it "valid UNC path" $ + isJust (Path.fromString "\\\\server\\share\\x" :: Maybe WindowsPath) + `shouldBe` True + it "valid verbatim path" $ + isJust (Path.fromString "\\\\?\\C:\\x" :: Maybe WindowsPath) + `shouldBe` True + it "empty string is invalid" $ + isNothing (Path.fromString "" :: Maybe WindowsPath) `shouldBe` True + it "toString . fromString_ roundtrip" $ + str (p "C:\\Users") `shouldBe` "C:\\Users" + it "forward slashes preserved on roundtrip" $ + str (p "a/b") `shouldBe` "a/b" + +------------------------------------------------------------------------------- +-- Validation +------------------------------------------------------------------------------- + +testValidatePathStrict :: Spec +testValidatePathStrict = describe "validatePath' (strict)" $ do + let isValid = isJust . Path.validatePath' . Path.encodeString + it "lone double separator invalid" $ + isValid "\\\\" `shouldBe` False + it "UNC server-only invalid" $ + isValid "\\\\server\\" `shouldBe` False + it "UNC server+share valid" $ + isValid "\\\\server\\x" `shouldBe` True + it "\\\\?\\UNC\\server alone invalid" $ + isValid "\\\\?\\UNC\\server" `shouldBe` False + +------------------------------------------------------------------------------- +-- Separators +------------------------------------------------------------------------------- + +testSeparators :: Spec +testSeparators = describe "separators" $ do + it "hasTrailingSeparator backslash" $ + Path.hasTrailingSeparator (p "foo\\") `shouldBe` True + it "hasTrailingSeparator forward slash also counts" $ + Path.hasTrailingSeparator (p "foo/") `shouldBe` True + it "dropTrailingSeparators" $ + str (Path.dropTrailingSeparators (p "foo\\")) `shouldBe` "foo" + it "addTrailingSeparator adds primary separator" $ + Path.hasTrailingSeparator (Path.addTrailingSeparator (p "foo")) + `shouldBe` True + +------------------------------------------------------------------------------- +-- Root detection +------------------------------------------------------------------------------- + +testRooted :: Spec +testRooted = describe "isRooted" $ do + it "drive root is rooted" $ Path.isRooted (p "C:\\") `shouldBe` True + it "drive-only is rooted" $ Path.isRooted (p "C:") `shouldBe` True + it "UNC root is rooted" $ + Path.isRooted (p "\\\\server\\share\\") `shouldBe` True + it "verbatim root is rooted" $ + Path.isRooted (p "\\\\?\\C:\\x") `shouldBe` True + it ". is rooted" $ Path.isRooted (p ".") `shouldBe` True + it "x is unrooted" $ Path.isUnrooted (p "x") `shouldBe` True + +------------------------------------------------------------------------------- +-- Joining +------------------------------------------------------------------------------- + +testJoin :: Spec +testJoin = describe "join" $ do + it "join two segments" $ + str (Path.join (p "C:\\Users") (p "bin")) `shouldBe` "C:\\Users\\bin" + it "trailing separator on first is kept" $ + str (Path.join (p "x\\") (p "y")) `shouldBe` "x\\y" + it "forward separator is preserved if present" $ + str (Path.join (p "x/") (p "y")) `shouldBe` "x/y" + +------------------------------------------------------------------------------- +-- Splitting +------------------------------------------------------------------------------- + +testSplitRoot :: Spec +testSplitRoot = describe "splitRoot" $ do + let split = fmap toList . Path.splitRoot . p + toList (a, b) = (str a, fmap str b) + cases = + [ ("C:", Just ("C:", Nothing)) + , ("C:/", Just ("C:/", Nothing)) + , ("//x/", Just ("//x/", Nothing)) + , ("//x/y", Just ("//x/", Just "y")) + -- Verbatim drive paths + , ("\\\\?\\c:\\", Just ("\\\\?\\c:\\", Nothing)) + , ("\\\\?\\c:\\home", + Just ("\\\\?\\c:\\", Just "home")) + -- Verbatim UNC paths + , ("\\\\?\\UNC\\c:\\x", + Just ("\\\\?\\UNC\\c:\\", Just "x")) + ] + mapM_ + (\(input, expected) -> + it ("splitRoot " ++ show input) $ + split input `shouldBe` expected) + cases + +------------------------------------------------------------------------------- +-- Equality +------------------------------------------------------------------------------- + +eq :: String -> String -> Bool +eq a b = Path.eqPath id (p a) (p b) + +eqWith :: (Path.EqCfg -> Path.EqCfg) -> String -> String -> Bool +eqWith cfg a b = Path.eqPath cfg (p a) (p b) + +testEqPathDefault :: Spec +testEqPathDefault = describe "eqPath default" $ do + it "equal absolute paths" $ eq "C:\\x" "C:\\x" `shouldBe` True + it "forward/backward separators interchangeable" $ + eq "x\\y" "x/y" `shouldBe` True + it "case sensitive for non-root segments" $ + eq "x" "X" `shouldBe` False + it "drive-only paths are relative; not equal by default" $ do + eq "C:" "C:" `shouldBe` False + eq "C:x" "C:x" `shouldBe` False + it "drive-letter case differs but paths are relative" $ + eq "c:" "C:" `shouldBe` False + it "redundant separators ignored" $ + eq "x//y" "x/y" `shouldBe` True + it "dot segments ignored" $ + eq "x/./y" "x/y" `shouldBe` True + it "trailing separator matters" $ + eq "x/" "x" `shouldBe` False + +testEqPathDriveAlwaysIgnoresCase :: Spec +testEqPathDriveAlwaysIgnoresCase = + describe "eqPath drive root is always case-insensitive" $ do + it "absolute drive paths differ only in drive letter case" $ + eq "c:/x" "C:/x" `shouldBe` True + it "UNC server name case-insensitive" $ + eq "\\\\Server\\share\\x" "\\\\server\\share\\x" `shouldBe` True + -- Note: splitRoot currently treats the UNC share name as a body + -- component, so under default ignoreCase=False the share is + -- compared case-sensitively. + it "UNC share case follows ignoreCase (default sensitive)" $ + eq "\\\\server\\Share\\x" "\\\\server\\share\\x" `shouldBe` False + it "Body case still respected with default" $ + eq "C:/X" "C:/x" `shouldBe` False + +testEqPathVerbatim :: Spec +testEqPathVerbatim = describe "eqPath verbatim \\\\?\\ paths" $ do + it "verbatim paths byte-compared - identical equal" $ + eq "\\\\?\\C:\\x" "\\\\?\\C:\\x" `shouldBe` True + it "verbatim paths case-sensitive on drive letter" $ + eq "\\\\?\\C:\\x" "\\\\?\\c:\\x" `shouldBe` False + it "verbatim paths case-sensitive on body" $ + eq "\\\\?\\C:\\x" "\\\\?\\C:\\X" `shouldBe` False + it "verbatim paths separator-sensitive" $ + eq "\\\\?\\C:\\x" "\\\\?\\C:/x" `shouldBe` False + it "verbatim never equal to non-verbatim equivalent" $ + eq "\\\\?\\C:\\x" "C:\\x" `shouldBe` False + it "ignoreCase True still does not affect verbatim" $ + eqWith (Path.ignoreCase True) "\\\\?\\C:\\x" "\\\\?\\c:\\x" + `shouldBe` False + +testEqPathRelaxed :: Spec +testEqPathRelaxed = + describe "eqPath with relaxed config" $ do + let cfg = + Path.ignoreTrailingSeparators True + . Path.ignoreCase True + . Path.allowRelativeEquality True + it "leading dot ignored" $ + eqWith cfg "./x" "x" `shouldBe` True + it "trailing sep ignored" $ + eqWith cfg "X/" "x" `shouldBe` True + it "drive-only relative paths equal" $ + eqWith cfg "C:x" "c:X" `shouldBe` True + it "mixed separators with leading dot" $ + eqWith cfg ".\\x" "./X" `shouldBe` True + it "double sep collapse" $ + eqWith cfg "x//y" "x/y" `shouldBe` True + +------------------------------------------------------------------------------- +-- Normalisation +------------------------------------------------------------------------------- + +testNormalise :: Spec +testNormalise = describe "normalise" $ do + let nrm = str . Path.normalise id . p + it "drive letter uppercased" $ + nrm "c:\\x" `shouldBe` "C:\\x" + it "drive root only uppercased" $ + nrm "c:" `shouldBe` "C:" + -- Note: splitRoot currently treats the UNC share as a body component, so + -- only the server is lowercased by the root normaliser; the share keeps + -- its case unless ignoreCase is also set. + it "UNC server lowercased; share kept (root-only normalisation)" $ + nrm "\\\\Server\\Share\\x" `shouldBe` "\\\\server\\Share\\x" + it "UNC server lowercased even when only root present" $ + nrm "\\\\Server\\Share\\" `shouldBe` "\\\\server\\Share\\" + it "verbatim path untouched" $ + nrm "\\\\?\\C:\\Foo" `shouldBe` "\\\\?\\C:\\Foo" + it "verbatim path with mixed case kept verbatim" $ + nrm "\\\\?\\c:\\Foo" `shouldBe` "\\\\?\\c:\\Foo" + it "separators in non-verbatim normalised to primary" $ + nrm "C:/x/y" `shouldBe` "C:\\x\\y" + it "ignoreCase True does not change verbatim" $ + str (Path.normalise (Path.ignoreCase True) (p "\\\\?\\C:\\Foo")) + `shouldBe` "\\\\?\\C:\\Foo" + +------------------------------------------------------------------------------- +-- Path prefix +------------------------------------------------------------------------------- + +testCommonPrefix :: Spec +testCommonPrefix = describe "takeCommonPrefix" $ do + let cp a b = fmap str $ Path.takeCommonPrefix id (p a) (p b) + it "same drive-absolute path" $ + cp "C:\\a\\b" "C:\\a\\b" `shouldBe` Just "C:\\a\\b" + it "common segments under same drive" $ + cp "C:\\a\\b\\c" "C:\\a\\b\\d" `shouldBe` Just "C:\\a\\b" + it "drive letters differ in case still common" $ + cp "c:\\a" "C:\\a" `shouldBe` Just "C:\\a" + it "verbatim paths byte-equal share full path" $ + cp "\\\\?\\C:\\a" "\\\\?\\C:\\a" `shouldBe` Just "\\\\?\\C:\\a" + it "verbatim paths share the device root when bodies differ" $ + cp "\\\\?\\C:\\Foo" "\\\\?\\C:\\foo" `shouldBe` Just "\\\\?\\C:\\" + +testStripPrefix :: Spec +testStripPrefix = describe "stripPrefix" $ do + let sp a b = fmap str $ Path.stripPrefix id (p a) (p b) + it "strips matching prefix" $ + sp "C:\\a\\b" "C:\\a\\b\\c" `shouldBe` Just "c" + it "drive case-insensitive match" $ + sp "c:\\a" "C:\\a\\b" `shouldBe` Just "b" + it "no match" $ + sp "C:\\a\\x" "C:\\a\\b\\c" `shouldBe` Nothing + it "verbatim prefix byte-strict" $ + sp "\\\\?\\C:\\a" "\\\\?\\C:\\a\\b" `shouldBe` Just "b" + it "verbatim differs in case no strip" $ + sp "\\\\?\\c:\\a" "\\\\?\\C:\\a\\b" `shouldBe` Nothing + +------------------------------------------------------------------------------- +-- Path view +------------------------------------------------------------------------------- + +testPathView :: Spec +testPathView = describe "path view" $ do + it "takeFileName" $ + fmap str (Path.takeFileName (p "C:\\Users\\file.txt")) + `shouldBe` Just "file.txt" + it "takeDirectory" $ + fmap str (Path.takeDirectory (p "C:\\Users\\file.txt")) + `shouldBe` Just "C:\\Users\\" + +------------------------------------------------------------------------------- +-- validatePath (windows-specific) +------------------------------------------------------------------------------- + +testValidatePath :: Spec +testValidatePath = describe "validatePath" $ do + let isValid = isJust . Path.validatePath . Path.encodeString + cases = + [ ("", False) + , ("\0", False) + -- invalid characters + , ("c::", False) + , ("c:\\x:y", False) + , ("x*", False) + , ("x\ty", False) + -- reserved names + , ("pRn.txt", False) + , (" pRn .txt", False) + , ("c:\\x\\pRn", False) + , ("c:\\x\\pRn.txt", False) + , ("c:\\pRn\\x", False) + , ("c:\\ pRn \\x", False) + , ("pRn.x.txt", False) + -- drive root forms + , ("c:", True) + , ("c:a\\b", True) + , ("c:\\", True) + , ("c:\\\\", False) + , ("c:\\/", False) + , ("c:\\\\x", False) + , ("c:\\/x", False) + -- mixed separators + , ("/x\\y", True) + , ("\\/", True) + , ("/\\", True) + , ("\\/x/y", True) + , ("/x/\\y", True) + , ("/x\\/y", True) + -- share path / UNC + , ("\\", True) + , ("\\\\", False) + , ("\\\\\\", False) + , ("\\\\x", False) + , ("\\\\x\\", True) + , ("\\\\x\\y", True) + , ("//x/y", True) + , ("\\\\prn\\y", False) + , ("\\\\x\\\\", False) + , ("\\\\x\\\\x", False) + , ("\\\\\\x", False) + -- short UNC (\\?\C:\) + , ("\\\\?\\c:", False) + , ("\\\\?\\c:\\", True) + , ("\\\\?\\c:x", False) + , ("\\\\?\\c:\\\\", False) + , ("\\\\?\\c:\\x", True) + , ("\\\\?\\c:\\\\\\", False) + , ("\\\\?\\c:\\\\x", False) + -- long UNC (\\?\UNC\) + , ("\\\\?\\UnC\\x", True) -- UnC is treated as share name + , ("\\\\?\\UNC\\x", False) + , ("\\\\?\\UNC\\c:\\x", True) + -- DOS device namespace + , ("\\\\.\\x", True) + , ("\\\\??\\x", True) + ] + mapM_ + (\(input, expected) -> + it ("validatePath " ++ show input) $ + isValid input `shouldBe` expected) + cases + +------------------------------------------------------------------------------- +-- isRooted (windows-specific) +------------------------------------------------------------------------------- + +testIsRootedWindows :: Spec +testIsRootedWindows = describe "isRooted (windows-specific)" $ do + let rooted = Path.isRooted . p + cases = + [ ("/", True) + , ("/x", True) + , (".", True) + , ("./x", True) + , ("c:", True) + , ("c:x", True) + , ("c:/", True) + , ("//x/y", True) + ] + mapM_ + (\(input, expected) -> + it ("isRooted " ++ show input) $ + rooted input `shouldBe` expected) + cases + +------------------------------------------------------------------------------- +-- unsafeJoin / join (windows-specific) +------------------------------------------------------------------------------- + +testUnsafeJoin :: Spec +testUnsafeJoin = describe "unsafeJoin" $ do + let f a b = str $ Path.unsafeJoin (p a) (p b) + it "x y" $ f "x" "y" `shouldBe` "x\\y" + it "x/ y" $ f "x/" "y" `shouldBe` "x/y" + it "x /y" $ f "x" "/y" `shouldBe` "x/y" + it "x/ /y" $ f "x/" "/y" `shouldBe` "x/y" + -- joinDrive-equivalent cases + it "c: /x" $ f "c:" "/x" `shouldBe` "c:/x" + it "//x/ /y" $ f "//x/" "/y" `shouldBe` "//x/y" + +testJoinWindows :: Spec +testJoinWindows = describe "join (windows-specific)" $ do + let f a b = str $ Path.join (p a) (p b) + it "x y" $ f "x" "y" `shouldBe` "x\\y" + it "c: y" $ f "c:" "y" `shouldBe` "c:y" + it "c:x y" $ f "c:x" "y" `shouldBe` "c:x\\y" + it "\\x y" $ f "\\x" "y" `shouldBe` "\\x\\y" + it "c:/ y" $ f "c:/" "y" `shouldBe` "c:/y" + it "//x/ y" $ f "//x/" "y" `shouldBe` "//x/y" + it "trailing forward slash kept" $ f "x/" "y" `shouldBe` "x/y" + it "second-path /y rejected for any first" $ do + mapM_ + (\a -> fails (f a "/y") >>= (`shouldBe` True)) + ["c:/", "c:/x", "c:", "c:x", "/x", "x", "//x/"] + it "second-path c:/ rejected" $ fails (f "c:" "c:/") >>= (`shouldBe` True) + +------------------------------------------------------------------------------- +-- splitPath / splitPath_ (windows-specific) +------------------------------------------------------------------------------- + +splitToList :: + (WindowsPath -> Stream.Stream Identity WindowsPath) + -> String -> [String] +splitToList f = runIdentity . Stream.toList . fmap str . f . p + +testSplitPath_ :: Spec +testSplitPath_ = describe "splitPath_ (windows-specific)" $ do + let cases = + [ ("c:x", ["c:", "x"]) + , ("c:/", ["c:/"]) + , ("c:/x", ["c:/", "x"]) + , ("//x/y/", ["//x", "y"]) + , ("./a", [".", "a"]) + , ("c:./a", ["c:", "a"]) + , ("a/.", ["a"]) + , ("/x", ["/", "x"]) + , ("/x/\\y", ["/", "x", "y"]) + , ("\\x/\\y", ["\\", "x", "y"]) + ] + mapM_ + (\(input, expected) -> + it ("splitPath_ " ++ show input) $ + splitToList Path.splitPath_ input `shouldBe` expected) + cases + +testSplitPath :: Spec +testSplitPath = describe "splitPath (windows-specific)" $ do + let cases = + [ ("/x", ["/", "x"]) + , ("/x/\\y", ["/", "x/", "y"]) + , ("\\x/\\y", ["\\", "x/", "y"]) + ] + mapM_ + (\(input, expected) -> + it ("splitPath " ++ show input) $ + splitToList Path.splitPath input `shouldBe` expected) + cases + +------------------------------------------------------------------------------- +-- splitExtension (windows-specific) +------------------------------------------------------------------------------- + +testSplitExtensionWindows :: Spec +testSplitExtensionWindows = describe "splitExtension (windows-specific)" $ do + let split = fmap toList . Path.splitExtension . p + toList (a, b) = (str a, str b) + it "drive-only-relative x:y has no extension" $ + split "x:y" `shouldBe` Nothing + it "drive-only-relative x:.y has no extension" $ + split "x:.y" `shouldBe` Nothing + +------------------------------------------------------------------------------- +-- readArray / showArray round-trip +------------------------------------------------------------------------------- + +testReadArray :: Spec +testReadArray = describe "readArray/showArray round-trip" $ + it "round-trip via show + read" $ do + let arr = Path.encodeString "hello" + -- The doctest in the source uses: readArray $ show arr + shown = show arr + Path.showArray (Path.readArray shown :: WindowsPath) + `shouldBe` "fromList [104,101,108,108,111]" + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "FileSystem.WindowsPath" + +main :: IO () +main = hspec $ do + describe moduleName $ do + testFromString + testValidatePath + testValidatePathStrict + testSeparators + testRooted + testIsRootedWindows + testJoin + testJoinWindows + testUnsafeJoin + testSplitRoot + testSplitPath + testSplitPath_ + testSplitExtensionWindows + testEqPathDefault + testEqPathDriveAlwaysIgnoresCase + testEqPathVerbatim + testEqPathRelaxed + testNormalise + testCommonPrefix + testStripPrefix + testPathView + testReadArray diff --git a/test/streamly-tests.cabal b/test/streamly-tests.cabal index 502811d40d..b2fa31abc8 100644 --- a/test/streamly-tests.cabal +++ b/test/streamly-tests.cabal @@ -550,11 +550,19 @@ test-suite FileSystem.Handle if flag(use-streamly-core) buildable: False -test-suite FileSystem.Path +test-suite FileSystem.PosixPath import: test-options type: exitcode-stdio-1.0 - main-is: Streamly/Test/FileSystem/Path.hs - ghc-options: -main-is Streamly.Test.FileSystem.Path.main + main-is: Streamly/Test/FileSystem/PosixPath.hs + ghc-options: -main-is Streamly.Test.FileSystem.PosixPath.main + if flag(use-streamly-core) + buildable: False + +test-suite FileSystem.WindowsPath + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/FileSystem/WindowsPath.hs + ghc-options: -main-is Streamly.Test.FileSystem.WindowsPath.main if flag(use-streamly-core) buildable: False From 53596e21d38c4d14c3608be945968c69d6f9cfbe Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sat, 16 May 2026 22:36:48 +0530 Subject: [PATCH 5/5] Change default for allowRelativeEquality to True --- core/docs/Changelog.md | 5 ++ .../Internal/FileSystem/Path/Common.hs | 4 +- .../Streamly/Internal/FileSystem/PosixPath.hs | 56 +++++++++---------- .../Internal/FileSystem/WindowsPath.hs | 18 ++++-- test/Streamly/Test/FileSystem/PosixPath.hs | 38 ++++++------- test/Streamly/Test/FileSystem/WindowsPath.hs | 13 +++-- 6 files changed, 71 insertions(+), 63 deletions(-) diff --git a/core/docs/Changelog.md b/core/docs/Changelog.md index 6f0201dd3e..ebdbffca7a 100644 --- a/core/docs/Changelog.md +++ b/core/docs/Changelog.md @@ -4,6 +4,11 @@ * Breaking: In `FileSystem.Path` module the default for `eqPath` changed on Windows to case-sensitive comparison. +* Breaking: In `FileSystem.Path` module the default for `eqPath` changed + on both Posix and Windows so that `allowRelativeEquality` is `True` by + default. Literally identical relative paths (e.g. `./x` and `./x`, or + `c:` and `c:` on Windows) now compare equal. Pass + `allowRelativeEquality False` to restore the previous strict behaviour. * Bug fix: Fixed `followSymlinks` option not working correctly on macOS. ## 0.3.0 diff --git a/core/src/Streamly/Internal/FileSystem/Path/Common.hs b/core/src/Streamly/Internal/FileSystem/Path/Common.hs index ebf59bb4c5..4c24fb45ae 100644 --- a/core/src/Streamly/Internal/FileSystem/Path/Common.hs +++ b/core/src/Streamly/Internal/FileSystem/Path/Common.hs @@ -1824,14 +1824,14 @@ eqPathBytes = Array.byteEq -- >>> :{ -- defaultMod = ignoreTrailingSeparators False -- . ignoreCase False --- . allowRelativeEquality False +-- . allowRelativeEquality True -- :} -- data EqCfg = EqCfg { _ignoreTrailingSeparators :: Bool -- ^ Allows "x\/" == "x" , _ignoreCase :: Bool -- ^ Allows "x" == \"X\" - -- XXX _compareRelative, default True + -- XXX _compareRelative , _allowRelativeEquality :: Bool -- ^ A leading dot is ignored, thus ".\/x" == ".\/x" and ".\/x" == "x". -- On Windows allows "\/x" == \/x" and "C:x == C:x" diff --git a/core/src/Streamly/Internal/FileSystem/PosixPath.hs b/core/src/Streamly/Internal/FileSystem/PosixPath.hs index 983408b215..60a60471dd 100644 --- a/core/src/Streamly/Internal/FileSystem/PosixPath.hs +++ b/core/src/Streamly/Internal/FileSystem/PosixPath.hs @@ -1498,13 +1498,13 @@ takeDirectory x = splitFile x >>= fst -- eqCfg = -- Path.ignoreTrailingSeparators False -- . Path.ignoreCase False --- . Path.allowRelativeEquality False +-- . Path.allowRelativeEquality True -- :} -- eqCfg :: EqCfg eqCfg = Common.EqCfg { _ignoreTrailingSeparators = False - , _allowRelativeEquality = False + , _allowRelativeEquality = True , _ignoreCase = False } @@ -1555,23 +1555,13 @@ ignoreCase val conf = conf { _ignoreCase = val } -- So we can possibly specify a scope (Directory/System/Universe) for -- comparison rather than using allowRelativeEquality. --- | Allow relative paths to be treated as equal. When this is 'False' relative --- paths will never match even if they are literally equal e.g. "./x" will not --- match "./x" because the meaning of "." in both cases could be different --- depending on what the user meant by current directory in each case. +-- | Allow relative paths to be treated as equal. When this is 'True', +-- literally identical relative paths compare equal even though the meaning +-- of "." (current directory) at each call site could in principle differ. +-- Set to 'False' to require both paths to be absolute (or share-rooted on +-- Windows) for equality. -- --- When set to 'False' (default): --- --- >>> cfg = Path.allowRelativeEquality False --- >>> eq a b = Path.eqPath cfg (Path.fromString_ a) (Path.fromString_ b) --- >>> eq "." "." --- False --- >>> eq "./x" "./x" --- False --- >>> eq "./x" "x" --- False --- --- When set to 'False' (default): +-- When set to 'True' (default): -- -- >>> cfg = Path.allowRelativeEquality True -- >>> eq a b = Path.eqPath cfg (Path.fromString_ a) (Path.fromString_ b) @@ -1585,7 +1575,18 @@ ignoreCase val conf = conf { _ignoreCase = val } -- >>> eq "./x" "././x" -- True -- --- /Default/: False +-- When set to 'False': +-- +-- >>> cfg = Path.allowRelativeEquality False +-- >>> eq a b = Path.eqPath cfg (Path.fromString_ a) (Path.fromString_ b) +-- >>> eq "." "." +-- False +-- >>> eq "./x" "./x" +-- False +-- >>> eq "./x" "x" +-- False +-- +-- /Default/: True allowRelativeEquality :: Bool -> EqCfg -> EqCfg allowRelativeEquality val conf = conf { _allowRelativeEquality = val } @@ -1599,17 +1600,9 @@ allowRelativeEquality val conf = conf { _allowRelativeEquality = val } -- specifically it drops redundant path separators between path segments and -- redundant "\/.\/" components between segments. -- --- Default config options use strict equality, for strict equality both the --- paths must be absolute or both must be path segments without a leading root --- component (e.g. x\/y). Also, both must be files or both must be directories. --- -- In addition to the default config options, the following equality semantics -- are used: -- --- * An absolute path and a path relative to "." may be equal depending on the --- meaning of ".", however this routine treats them as unequal, it does not --- resolve the "." to a concrete path. --- -- * Two paths having ".." components may be equal after processing the ".." -- components even if we determined them to be unequal. However, if we -- determined them to be equal then they must be equal. @@ -1638,14 +1631,15 @@ allowRelativeEquality val conf = conf { _allowRelativeEquality = val } -- >>> eq "x/y/." "x/y" -- True -- --- Leading dot, relative paths are not equal by default: +-- Relative paths compare equal by default; pass +-- @'allowRelativeEquality' False@ to require both paths to be absolute: -- -- >>> eq "." "." --- False +-- True -- >>> eq "./x" "./x" --- False +-- True -- >>> eq "./x" "x" --- False +-- True -- -- Trailing separators are significant by default: -- diff --git a/core/src/Streamly/Internal/FileSystem/WindowsPath.hs b/core/src/Streamly/Internal/FileSystem/WindowsPath.hs index 201df48a94..1580fa6346 100644 --- a/core/src/Streamly/Internal/FileSystem/WindowsPath.hs +++ b/core/src/Streamly/Internal/FileSystem/WindowsPath.hs @@ -258,16 +258,22 @@ joinDir -- >>> eq "x" "X" -- False -- --- Drive-only paths are relative and so are not equal under the default --- (which has @allowRelativeEquality@ set to 'False'): +-- Drive-only paths are relative; under the default they now compare equal +-- (drive letter is case-insensitive): -- -- >>> eq "c:" "C:" --- False +-- True -- -- >>> eq "c:" "c:" --- False +-- True -- -- >>> eq "c:x" "c:x" +-- True +-- +-- Pass @'allowRelativeEquality' False@ to require absolute paths for +-- equality: +-- +-- >>> Path.eqPath (Path.allowRelativeEquality False) (Path.fromString_ "c:") (Path.fromString_ "c:") -- False -- -- Drive letters compare case-insensitively when paths are absolute: @@ -286,10 +292,12 @@ joinDir -- >>> eq "\\\\?\\C:\\x" "\\\\?\\c:\\x" -- False -- +-- With trailing separators ignored and case folded as well +-- (allowRelativeEquality is already True by default): +-- -- >>> :{ -- cfg = Path.ignoreTrailingSeparators True -- . Path.ignoreCase True --- . Path.allowRelativeEquality True -- eq a b = Path.eqPath cfg (Path.fromString_ a) (Path.fromString_ b) -- :} -- diff --git a/test/Streamly/Test/FileSystem/PosixPath.hs b/test/Streamly/Test/FileSystem/PosixPath.hs index 5d88f63a5f..1c47bd129e 100644 --- a/test/Streamly/Test/FileSystem/PosixPath.hs +++ b/test/Streamly/Test/FileSystem/PosixPath.hs @@ -201,11 +201,11 @@ testEqPath = describe "eqPath" $ do `shouldBe` True it "case sensitive by default" $ Path.eqPath id (p "x") (p "X") `shouldBe` False - it "relative paths not equal by default" $ - Path.eqPath id (p ".") (p ".") `shouldBe` False - it "allowRelativeEquality" $ - Path.eqPath (Path.allowRelativeEquality True) (p ".") (p ".") - `shouldBe` True + it "relative paths equal by default" $ + Path.eqPath id (p ".") (p ".") `shouldBe` True + it "allowRelativeEquality False makes relative paths unequal" $ + Path.eqPath (Path.allowRelativeEquality False) (p ".") (p ".") + `shouldBe` False it "eqPathBytes exact match" $ Path.eqPathBytes (p "x//y") (p "x//y") `shouldBe` True it "eqPathBytes differs" $ @@ -526,21 +526,19 @@ testEqPathExtended = describe "eqPath (extended)" $ do let eq = Path.eqPath id it "/x equals //x" $ eq (p "/x") (p "//x") `shouldBe` True it "x/y/. equals x/y" $ eq (p "x/y/.") (p "x/y") `shouldBe` True - it ". equal to . is False by default" $ - eq (p ".") (p ".") `shouldBe` False - it "./x equal to ./x is False by default" $ - eq (p "./x") (p "./x") `shouldBe` False - it "./x equal to x is False by default" $ - eq (p "./x") (p "x") `shouldBe` False - it "allowRelativeEquality . . True" $ - Path.eqPath (Path.allowRelativeEquality True) (p ".") (p ".") - `shouldBe` True - it "allowRelativeEquality ./x x True" $ - Path.eqPath (Path.allowRelativeEquality True) (p "./x") (p "x") - `shouldBe` True - it "allowRelativeEquality ./x ././x True" $ - Path.eqPath (Path.allowRelativeEquality True) (p "./x") (p "././x") - `shouldBe` True + it ". equals . by default" $ + eq (p ".") (p ".") `shouldBe` True + it "./x equals ./x by default" $ + eq (p "./x") (p "./x") `shouldBe` True + it "./x equals x by default" $ + eq (p "./x") (p "x") `shouldBe` True + it "./x equals ././x by default" $ + eq (p "./x") (p "././x") `shouldBe` True + it "allowRelativeEquality False rejects relative equality" $ do + let cfg = Path.allowRelativeEquality False + Path.eqPath cfg (p ".") (p ".") `shouldBe` False + Path.eqPath cfg (p "./x") (p "x") `shouldBe` False + Path.eqPath cfg (p "./x") (p "././x") `shouldBe` False it "ignoreTrailingSeparators True" $ Path.eqPath (Path.ignoreTrailingSeparators True) (p "x/") (p "x") `shouldBe` True diff --git a/test/Streamly/Test/FileSystem/WindowsPath.hs b/test/Streamly/Test/FileSystem/WindowsPath.hs index 4622749a63..2e6441f1ab 100644 --- a/test/Streamly/Test/FileSystem/WindowsPath.hs +++ b/test/Streamly/Test/FileSystem/WindowsPath.hs @@ -167,11 +167,14 @@ testEqPathDefault = describe "eqPath default" $ do eq "x\\y" "x/y" `shouldBe` True it "case sensitive for non-root segments" $ eq "x" "X" `shouldBe` False - it "drive-only paths are relative; not equal by default" $ do - eq "C:" "C:" `shouldBe` False - eq "C:x" "C:x" `shouldBe` False - it "drive-letter case differs but paths are relative" $ - eq "c:" "C:" `shouldBe` False + it "drive-only paths equal under default (allowRelativeEquality True)" $ do + eq "C:" "C:" `shouldBe` True + eq "C:x" "C:x" `shouldBe` True + it "drive letter case-insensitive even for relative drive paths" $ + eq "c:" "C:" `shouldBe` True + it "allowRelativeEquality False rejects drive-only relatives" $ do + eqWith (Path.allowRelativeEquality False) "C:" "C:" `shouldBe` False + eqWith (Path.allowRelativeEquality False) "C:x" "C:x" `shouldBe` False it "redundant separators ignored" $ eq "x//y" "x/y" `shouldBe` True it "dot segments ignored" $