filepath 1.5.0.0 → 1.5.2.0
raw patch · 11 files changed
+330/−256 lines, 11 filesdep +generic-derivingdep +generic-randomdep +tastydep ~basedep ~os-stringPVP ok
version bump matches the API change (PVP)
Dependencies added: generic-deriving, generic-random, tasty, tasty-quickcheck
Dependency ranges changed: base, os-string
API changes (from Hackage documentation)
+ System.OsPath: unsafeEncodeUtf :: HasCallStack => String -> OsString
+ System.OsPath.Internal: unsafeEncodeUtf :: HasCallStack => String -> OsString
+ System.OsPath.Posix: unsafeEncodeUtf :: HasCallStack => String -> PosixString
+ System.OsPath.Windows: unsafeEncodeUtf :: HasCallStack => String -> WindowsString
Files
- System/FilePath/Internal.hs +35/−9
- System/OsPath/Common.hs +4/−0
- System/OsPath/Internal.hs +26/−10
- System/OsPath/Posix.hs +8/−4
- System/OsPath/Windows.hs +8/−4
- changelog.md +6/−0
- filepath.cabal +17/−14
- tests/abstract-filepath/EncodingSpec.hs +0/−170
- tests/abstract-filepath/Test.hs +1/−2
- tests/filepath-equivalent-tests/TestEquiv.hs +219/−43
- tests/filepath-tests/TestGen.hs +6/−0
System/FilePath/Internal.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE MultiWayIf #-} -- This template expects CPP definitions for: -- MODULE_NAME = Posix | Windows@@ -602,6 +603,7 @@ -- > Posix: splitFileName "/" == ("/","") -- > Windows: splitFileName "c:" == ("c:","") -- > Windows: splitFileName "\\\\?\\A:\\fred" == ("\\\\?\\A:\\","fred")+-- > Windows: splitFileName "\\\\?\\A:" == ("\\\\?\\A:","") splitFileName :: FILEPATH -> (STRING, STRING) splitFileName x = if null path then (dotSlash, file)@@ -644,21 +646,44 @@ -- 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+ dropExcessTrailingPathSeparators x+ | hasTrailingPathSeparator x+ , let x' = dropWhileEnd isPathSeparator x+ , otherwise = if | null x' -> singleton (last x)+ | otherwise -> addTrailingPathSeparator x'+ | otherwise = 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 . dropExcessTrailingPathSeparators $ pref+ | otherwise = False+ -- | Set the filename. -- -- > replaceFileName "/directory/other.txt" "file.ext" == "/directory/file.ext"@@ -671,6 +696,7 @@ -- -- > dropFileName "/directory/file.ext" == "/directory/" -- > dropFileName x == fst (splitFileName x)+-- > isPrefixOf (takeDrive x) (dropFileName x) dropFileName :: FILEPATH -> FILEPATH dropFileName = fst . splitFileName
System/OsPath/Common.hs view
@@ -42,6 +42,7 @@ #endif -- * Filepath construction , PS.encodeUtf+ , PS.unsafeEncodeUtf , PS.encodeWith , PS.encodeFS #if defined(WINDOWS) || defined(POSIX)@@ -117,6 +118,7 @@ , decodeFS , pack , encodeUtf+ , unsafeEncodeUtf , encodeWith , encodeFS , unpack@@ -149,6 +151,7 @@ , decodeFS , pack , encodeUtf+ , unsafeEncodeUtf , encodeWith , encodeFS , unpack@@ -165,6 +168,7 @@ , decodeFS , pack , encodeUtf+ , unsafeEncodeUtf , encodeWith , encodeFS , unpack
System/OsPath/Internal.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE ViewPatterns #-} -- needed to quote a view pattern module System.OsPath.Internal where @@ -32,6 +34,7 @@ import qualified System.OsPath.Posix as PF import GHC.IO.Encoding.UTF8 ( mkUTF8 ) #endif+import GHC.Stack (HasCallStack) @@ -40,10 +43,18 @@ -- On windows this encodes as UTF16-LE (strictly), which is a pretty good guess. -- On unix this encodes as UTF8 (strictly), which is a good guess. ----- Throws a 'EncodingException' if encoding fails.+-- Throws an 'EncodingException' if encoding fails. If the input does not+-- contain surrogate chars, you can use 'unsafeEncodeUtf'. encodeUtf :: MonadThrow m => FilePath -> m OsPath encodeUtf = OS.encodeUtf +-- | Unsafe unicode friendly encoding.+--+-- Like 'encodeUtf', except it crashes when the input contains+-- surrogate chars. For sanitized input, this can be useful.+unsafeEncodeUtf :: HasCallStack => String -> OsString+unsafeEncodeUtf = OS.unsafeEncodeUtf+ -- | Encode a 'FilePath' with the specified encoding. encodeWith :: TextEncoding -- ^ unix text encoding -> TextEncoding -- ^ windows text encoding@@ -111,7 +122,8 @@ -- | QuasiQuote an 'OsPath'. This accepts Unicode characters -- and encodes as UTF-8 on unix and UTF-16LE on windows. Runs 'isValid'--- on the input.+-- on the input. If used as a pattern, requires turning on the @ViewPatterns@+-- extension. osp :: QuasiQuoter osp = QuasiQuoter #if defined(mingw32_HOST_OS) || defined(__MINGW32__)@@ -119,24 +131,28 @@ osp' <- either (fail . show) (pure . OsString) . PF.encodeWith (mkUTF16le ErrorOnCodingFailure) $ s when (not $ isValid osp') $ fail ("filepath not valid: " ++ show osp') lift osp'- , quotePat = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"+ , quotePat = \s -> do+ osp' <- either (fail . show) (pure . OsString) . PF.encodeWith (mkUTF16le ErrorOnCodingFailure) $ s+ when (not $ isValid osp') $ fail ("filepath not valid: " ++ show osp')+ [p|((==) osp' -> True)|] , quoteType = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a type)"+ fail "illegal QuasiQuote (allowed as expression or pattern only, used as a type)" , quoteDec = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a declaration)"+ fail "illegal QuasiQuote (allowed as expression or pattern only, used as a declaration)" } #else { quoteExp = \s -> do osp' <- either (fail . show) (pure . OsString) . PF.encodeWith (mkUTF8 ErrorOnCodingFailure) $ s when (not $ isValid osp') $ fail ("filepath not valid: " ++ show osp') lift osp'- , quotePat = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"+ , quotePat = \s -> do+ osp' <- either (fail . show) (pure . OsString) . PF.encodeWith (mkUTF8 ErrorOnCodingFailure) $ s+ when (not $ isValid osp') $ fail ("filepath not valid: " ++ show osp')+ [p|((==) osp' -> True)|] , quoteType = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a type)"+ fail "illegal QuasiQuote (allowed as expression or pattern only, used as a type)" , quoteDec = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a declaration)"+ fail "illegal QuasiQuote (allowed as expression or pattern only, used as a declaration)" } #endif
System/OsPath/Posix.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE ViewPatterns #-} #undef WINDOWS #define POSIX@@ -18,10 +20,12 @@ ps <- either (fail . show) pure $ encodeWith (mkUTF8 ErrorOnCodingFailure) s when (not $ isValid ps) $ fail ("filepath not valid: " ++ show ps) lift ps- , quotePat = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"+ , quotePat = \s -> do+ osp' <- either (fail . show) pure . encodeWith (mkUTF8 ErrorOnCodingFailure) $ s+ when (not $ isValid osp') $ fail ("filepath not valid: " ++ show osp')+ [p|((==) osp' -> True)|] , quoteType = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a type)"+ fail "illegal QuasiQuote (allowed as expression or pattern only, used as a type)" , quoteDec = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a declaration)"+ fail "illegal QuasiQuote (allowed as expression or pattern only, used as a declaration)" }
System/OsPath/Windows.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE ViewPatterns #-} #undef POSIX #define IS_WINDOWS True@@ -19,10 +21,12 @@ ps <- either (fail . show) pure $ encodeWith (mkUTF16le ErrorOnCodingFailure) s when (not $ isValid ps) $ fail ("filepath not valid: " ++ show ps) lift ps- , quotePat = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"+ , quotePat = \s -> do+ osp' <- either (fail . show) pure . encodeWith (mkUTF16le ErrorOnCodingFailure) $ s+ when (not $ isValid osp') $ fail ("filepath not valid: " ++ show osp')+ [p|((==) osp' -> True)|] , quoteType = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a type)"+ fail "illegal QuasiQuote (allowed as expression or pattern only, used as a type)" , quoteDec = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a declaration)"+ fail "illegal QuasiQuote (allowed as expression or pattern only, used as a declaration)" }
changelog.md view
@@ -2,6 +2,12 @@ _Note: below all `FilePath` values are unquoted, so `\\` really means two backslashes._ +## 1.5.2.0 *Jan 2024*++* Fix a bug in `[splitFileName](https://github.com/haskell/filepath/issues/219)`+* make `osp :: QuasiQuoter` valid as a pattern wrt [#210](https://github.com/haskell/filepath/pull/210)+* Add `unsafeEncodeUtf` from os-string+ ## 1.5.0.0 *Nov 2023* * remove `OsString` modules
filepath.cabal view
@@ -1,13 +1,13 @@ cabal-version: 2.2 name: filepath-version: 1.5.0.0+version: 1.5.2.0 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause license-file: LICENSE author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Julian Ospald <hasufell@posteo.de>-copyright: Neil Mitchell 2005-2020, Julain Ospald 2021-2022+copyright: Neil Mitchell 2005-2020, Julian Ospald 2021-2022 bug-reports: https://github.com/haskell/filepath/issues homepage: https://github.com/haskell/filepath/blob/master/README.md@@ -16,14 +16,14 @@ build-type: Simple synopsis: Library for manipulating FilePaths in a cross platform way. tested-with:- GHC ==8.0.2- || ==8.2.2- || ==8.4.4- || ==8.6.5+ GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2- || ==9.2.3+ || ==9.2.8+ || ==9.4.8+ || ==9.6.3+ || ==9.8.1 description: This package provides functionality for manipulating @FilePath@ values, and is shipped with <https://www.haskell.org/ghc/ GHC>. It provides two variants for filepaths:@@ -91,12 +91,12 @@ default-language: Haskell2010 build-depends:- , base >=4.9 && <4.20+ , base >=4.12.0.0 && <4.20 , bytestring >=0.11.3.0 , deepseq , exceptions , template-haskell- , os-string >=2.0.0+ , os-string >=2.0.1 ghc-options: -Wall @@ -116,7 +116,7 @@ , base , bytestring >=0.11.3.0 , filepath- , os-string >=2.0.0+ , os-string >=2.0.1 , QuickCheck >=2.7 && <2.15 default-language: Haskell2010@@ -138,8 +138,12 @@ , base , bytestring >=0.11.3.0 , filepath- , os-string >=2.0.0+ , generic-random+ , generic-deriving+ , os-string >=2.0.1 , QuickCheck >=2.7 && <2.15+ , tasty+ , tasty-quickcheck test-suite abstract-filepath default-language: Haskell2010@@ -149,7 +153,6 @@ hs-source-dirs: tests tests/abstract-filepath other-modules: Arbitrary- EncodingSpec OsPathSpec TestUtil @@ -158,7 +161,7 @@ , bytestring >=0.11.3.0 , deepseq , filepath- , os-string >=2.0.0+ , os-string >=2.0.1 , QuickCheck >=2.7 && <2.15 , quickcheck-classes-base ^>=0.6.2 @@ -173,7 +176,7 @@ , bytestring >=0.11.3.0 , deepseq , filepath- , os-string >=2.0.0+ , os-string >=2.0.1 , tasty-bench ghc-options: -with-rtsopts=-A32m
− tests/abstract-filepath/EncodingSpec.hs
@@ -1,170 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeApplications #-}--module EncodingSpec where--import Data.ByteString ( ByteString )-import qualified Data.ByteString as BS--import Arbitrary-import Test.QuickCheck--import Data.Either ( isRight )-import qualified System.OsString.Data.ByteString.Short as BS8-import qualified System.OsString.Data.ByteString.Short.Word16 as BS16-import System.OsString.Encoding.Internal-import GHC.IO (unsafePerformIO)-import GHC.IO.Encoding ( setFileSystemEncoding )-import System.IO- ( utf16le )-import Control.Exception-import Control.DeepSeq-import Data.Bifunctor ( first )-import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )-import GHC.IO.Encoding.UTF16 ( mkUTF16le )-import GHC.IO.Encoding.UTF8 ( mkUTF8 )---tests :: [(String, Property)]-tests =- [ ("ucs2le_decode . ucs2le_encode == id",- property $ \(padEven -> ba) ->- let decoded = decodeWithTE ucs2le (BS8.toShort ba)- encoded = encodeWithTE ucs2le =<< decoded- in (BS8.fromShort <$> encoded) === Right ba)- , ("utf16 doesn't handle invalid surrogate pairs",- property $- let str = [toEnum 55296, toEnum 55297]- encoded = encodeWithTE utf16le str- decoded = decodeWithTE utf16le =<< encoded-#if __GLASGOW_HASKELL__ >= 904- in decoded === Left (EncodingError ("recoverEncode: invalid argument (cannot encode character " <> show (head str) <> ")") Nothing))-#else- in decoded === Left (EncodingError "recoverEncode: invalid argument (invalid character)" Nothing))-#endif- , ("ucs2 handles invalid surrogate pairs",- property $- let str = [toEnum 55296, toEnum 55297]- encoded = encodeWithTE ucs2le str- decoded = decodeWithTE ucs2le =<< encoded- in decoded === Right str)- , ("can roundtrip arbitrary bytes through utf-8 (with RoundtripFailure)",- property $- \bs ->- let decoded = decodeWithTE (mkUTF8 RoundtripFailure) (BS8.toShort bs)- encoded = encodeWithTE (mkUTF8 RoundtripFailure) =<< decoded- in (either (const 0) BS8.length encoded, encoded) === (BS8.length (BS8.toShort bs), Right (BS8.toShort bs)))-- , ("can decode arbitrary strings through utf-8 (with RoundtripFailure)",- property $- \(NonNullSurrogateString str) ->- let encoded = encodeWithTE (mkUTF8 RoundtripFailure) str- decoded = decodeWithTE (mkUTF8 RoundtripFailure) =<< encoded- in expectFailure $ (either (const 0) length decoded, decoded) === (length str, Right str))-- , ("utf-8 roundtrip encode cannot deal with some surrogates",- property $- let str = [toEnum 0xDFF0, toEnum 0xDFF2]- encoded = encodeWithTE (mkUTF8 RoundtripFailure) str- decoded = decodeWithTE (mkUTF8 RoundtripFailure) =<< encoded-#if __GLASGOW_HASKELL__ >= 904- in decoded === Left (EncodingError ("recoverEncode: invalid argument (cannot encode character " <> show (head str) <> ")") Nothing))-#else- in decoded === Left (EncodingError "recoverEncode: invalid argument (invalid character)" Nothing))-#endif-- , ("cannot roundtrip arbitrary bytes through utf-16 (with RoundtripFailure)",- property $- \(padEven -> bs) ->- let decoded = decodeWithTE (mkUTF16le RoundtripFailure) (BS8.toShort bs)- encoded = encodeWithTE (mkUTF16le RoundtripFailure) =<< decoded- in expectFailure $ (either (const 0) BS8.length encoded, encoded) === (BS8.length (BS8.toShort bs), Right (BS8.toShort bs)))- , ("encodeWithTE/decodeWithTE ErrorOnCodingFailure fails (utf16le)",- property $- \(padEven -> bs) ->- let decoded = decodeWithTE (mkUTF16le ErrorOnCodingFailure) (BS8.toShort bs)- encoded = encodeWithTE (mkUTF16le ErrorOnCodingFailure) =<< decoded- in expectFailure $ (isRight encoded, isRight decoded) === (True, True))- , ("encodeWithTE/decodeWithTE ErrorOnCodingFailure fails (utf8)",- property $- \bs ->- let decoded = decodeWithTE (mkUTF8 ErrorOnCodingFailure) (BS8.toShort bs)- encoded = encodeWithTE (mkUTF8 ErrorOnCodingFailure) =<< decoded- in expectFailure $ (isRight encoded, isRight decoded) === (True, True))- , ("encodeWithTE/decodeWithTE TransliterateCodingFailure never fails (utf16le)",- property $- \(padEven -> bs) ->- let decoded = decodeWithTE (mkUTF16le TransliterateCodingFailure) (BS8.toShort bs)- encoded = encodeWithTE (mkUTF16le TransliterateCodingFailure) =<< decoded- in (isRight encoded, isRight decoded) === (True, True))- , ("encodeWithTE/decodeWithTE TransliterateCodingFailure never fails (utf8)",- property $- \bs ->- let decoded = decodeWithTE (mkUTF8 TransliterateCodingFailure) (BS8.toShort bs)- encoded = encodeWithTE (mkUTF8 TransliterateCodingFailure) =<< decoded- in (isRight encoded, isRight decoded) === (True, True))- , ("encodeWithBaseWindows/decodeWithBaseWindows never fails (utf16le)",- property $- \(padEven -> bs) ->- let decoded = decodeW' (BS8.toShort bs)- encoded = encodeW' =<< decoded- in (isRight encoded, isRight decoded) === (True, True))- , ("encodeWithBasePosix/decodeWithBasePosix never fails (utf8b)",- property $- \bs -> ioProperty $ do- setFileSystemEncoding (mkUTF8 TransliterateCodingFailure)- let decoded = decodeP' (BS8.toShort bs)- encoded = encodeP' =<< decoded- pure $ (isRight encoded, isRight decoded) === (True, True))-- , ("decodeWithBaseWindows == utf16le_b",- property $- \(BS8.toShort . padEven -> bs) ->- let decoded = decodeW' bs- decoded' = first displayException $ decodeWithTE (mkUTF16le_b ErrorOnCodingFailure) bs- in decoded === decoded')-- , ("encodeWithBaseWindows == utf16le_b",- property $- \(NonNullSurrogateString str) ->- let decoded = encodeW' str- decoded' = first displayException $ encodeWithTE (mkUTF16le_b ErrorOnCodingFailure) str- in decoded === decoded')-- , ("encodeWithTE/decodeWithTE never fails (utf16le_b)",- property $- \(padEven -> bs) ->- let decoded = decodeWithTE (mkUTF16le_b ErrorOnCodingFailure) (BS8.toShort bs)- encoded = encodeWithTE (mkUTF16le_b ErrorOnCodingFailure) =<< decoded- in (isRight encoded, isRight decoded) === (True, True))- ]---padEven :: ByteString -> ByteString-padEven bs- | even (BS.length bs) = bs- | otherwise = bs `BS.append` BS.pack [70]---decodeP' :: BS8.ShortByteString -> Either String String-decodeP' ba = unsafePerformIO $ do- r <- try @SomeException $ decodeWithBasePosix ba- evaluate $ force $ first displayException r--encodeP' :: String -> Either String BS8.ShortByteString-encodeP' str = unsafePerformIO $ do- r <- try @SomeException $ encodeWithBasePosix str- evaluate $ force $ first displayException r--decodeW' :: BS16.ShortByteString -> Either String String-decodeW' ba = unsafePerformIO $ do- r <- try @SomeException $ decodeWithBaseWindows ba- evaluate $ force $ first displayException r--encodeW' :: String -> Either String BS8.ShortByteString-encodeW' str = unsafePerformIO $ do- r <- try @SomeException $ encodeWithBaseWindows str- evaluate $ force $ first displayException r-
tests/abstract-filepath/Test.hs view
@@ -1,8 +1,7 @@ module Main (main) where import qualified OsPathSpec-import qualified EncodingSpec import TestUtil main :: IO ()-main = runTests (EncodingSpec.tests ++ OsPathSpec.tests)+main = runTests (OsPathSpec.tests)
tests/filepath-equivalent-tests/TestEquiv.hs view
@@ -1,24 +1,200 @@ {-# 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++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)++-- 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 +225,41 @@ ) , ( "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 +267,105 @@ ) , ( "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
tests/filepath-tests/TestGen.hs view
@@ -458,6 +458,8 @@ ,("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 @@ ,("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"))