system-filepath 0.4.14 → 0.4.14.1
raw patch · 9 files changed
+1251/−1230 lines, 9 filesdep ~chellsetup-changednew-uploader
Dependency ranges changed: chell
Files
- ChangeLog.md +9/−2
- README.md +1/−1
- Setup.hs +0/−12
- lib/Filesystem/Path.hs +158/−158
- lib/Filesystem/Path/CurrentOS.hs +23/−23
- lib/Filesystem/Path/Internal.hs +145/−145
- lib/Filesystem/Path/Rules.hs +219/−219
- system-filepath.cabal +32/−10
- tests/FilesystemPathTests.hs +664/−660
ChangeLog.md view
@@ -1,6 +1,13 @@+## 0.4.14.1++* Remove custom setup script [#27](https://github.com/fpco/haskell-filesystem/pull/27)+* Fix warning `-Wtabs` (replaced tabs by spaces).+* Allow `deepseq-1.5`.+* Test build with GHC 8.0 - 9.12.0+ ## 0.4.14 -* Add a Semigroup instance [#20 ](https://github.com/fpco/haskell-filesystem/pull/20)+* Add a Semigroup instance [#20](https://github.com/fpco/haskell-filesystem/pull/20) ## 0.4.13.3 @@ -12,7 +19,7 @@ ## 0.4.13.1 -Allow deepseq 1.4+* Allow `deepseq-1.4`. ## 0.4.13
README.md view
@@ -1,6 +1,6 @@ ## system-filepath -Please see [deprecation announcement](https://plus.google.com/+MichaelSnoyman/posts/Ft5hnPqpgEx)+Legacy package (deprecated). Provides a `FilePath` datatype and utility functions for operating on it. Unlike the `filepath` package, this package does not simply reuse `String`,
− Setup.hs
@@ -1,12 +0,0 @@-import qualified Distribution.Simple as Simple-import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo-import qualified Distribution.Simple.Program as Program--main :: IO ()-main = Simple.defaultMainWithHooks hooks where- hooks = Simple.simpleUserHooks- { Simple.haddockHook = myHaddockHook- }- myHaddockHook pkg lbi = Simple.haddockHook Simple.simpleUserHooks pkg (lbi- { LocalBuildInfo.withPrograms = Program.userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (LocalBuildInfo.withPrograms lbi)- })
lib/Filesystem/Path.hs view
@@ -14,47 +14,47 @@ -- compilation. -- module Filesystem.Path- ( FilePath- , empty- - -- * Basic properties- , null- , root- , directory- , parent- , filename- , dirname- , basename- , absolute- , relative- - -- * Basic operations- , append- , (</>)- , concat- , commonPrefix- , stripPrefix- , collapse- , splitDirectories- - -- * Extensions- , extension- , extensions- , hasExtension- - , addExtension- , (<.>)- , dropExtension- , replaceExtension- - , addExtensions- , dropExtensions- , replaceExtensions- - , splitExtension- , splitExtensions- ) where+ ( FilePath+ , empty + -- * Basic properties+ , null+ , root+ , directory+ , parent+ , filename+ , dirname+ , basename+ , absolute+ , relative++ -- * Basic operations+ , append+ , (</>)+ , concat+ , commonPrefix+ , stripPrefix+ , collapse+ , splitDirectories++ -- * Extensions+ , extension+ , extensions+ , hasExtension++ , addExtension+ , (<.>)+ , dropExtension+ , replaceExtension++ , addExtensions+ , dropExtensions+ , replaceExtensions++ , splitExtension+ , splitExtensions+ ) where+ import Prelude hiding (FilePath, concat, null) import qualified Prelude as Prelude @@ -70,9 +70,9 @@ (<>) = append instance M.Monoid FilePath where- mempty = empty- mappend = append- mconcat = concat+ mempty = empty+ mappend = append+ mconcat = concat ------------------------------------------------------------------------------- -- Basic properties@@ -90,30 +90,30 @@ -- directory, it is returned unchanged. directory :: FilePath -> FilePath directory p = empty- { pathRoot = pathRoot p- , pathDirectories = let- dot' | isJust (pathRoot p) = []- | Prelude.null (pathDirectories p) = [dot]- | otherwise = []- in dot' ++ pathDirectories p- }+ { pathRoot = pathRoot p+ , pathDirectories = let+ dot' | isJust (pathRoot p) = []+ | Prelude.null (pathDirectories p) = [dot]+ | otherwise = []+ in dot' ++ pathDirectories p+ } -- | Retrieves the 'FilePath'’s parent directory. parent :: FilePath -> FilePath parent p = empty- { pathRoot = pathRoot p- , pathDirectories = let- starts = map Just [dot, dots]- directories = if null (filename p)- then safeInit (pathDirectories p)- else pathDirectories p- - dot' | safeHead directories `elem` starts = []- | isNothing (pathRoot p) = [dot]- | otherwise = []- in dot' ++ directories- }+ { pathRoot = pathRoot p+ , pathDirectories = let+ starts = map Just [dot, dots]+ directories = if null (filename p)+ then safeInit (pathDirectories p)+ else pathDirectories p + dot' | safeHead directories `elem` starts = []+ | isNothing (pathRoot p) = [dot]+ | otherwise = []+ in dot' ++ directories+ }+ -- | Retrieve a 'FilePath'’s filename component. -- -- @@@ -121,9 +121,9 @@ -- @ filename :: FilePath -> FilePath filename p = empty- { pathBasename = pathBasename p- , pathExtensions = pathExtensions p- }+ { pathBasename = pathBasename p+ , pathExtensions = pathExtensions p+ } -- | Retrieve a 'FilePath'’s directory name. This is only the -- /file name/ of the directory, not its full path.@@ -136,9 +136,9 @@ -- Since: 0.4.1 dirname :: FilePath -> FilePath dirname p = case reverse (pathDirectories p) of- [] -> FilePath Nothing [] Nothing []- (d:_) -> case parseFilename d of- (base, exts) -> FilePath Nothing [] base exts+ [] -> FilePath Nothing [] Nothing []+ (d:_) -> case parseFilename d of+ (base, exts) -> FilePath Nothing [] base exts -- | Retrieve a 'FilePath'’s basename component. --@@ -147,24 +147,24 @@ -- @ basename :: FilePath -> FilePath basename p = empty- { pathBasename = pathBasename p- }+ { pathBasename = pathBasename p+ } -- | Test whether a path is absolute. absolute :: FilePath -> Bool absolute p = case pathRoot p of- Just RootPosix -> True- Just RootWindowsVolume{} -> True- Just RootWindowsCurrentVolume -> False- Just RootWindowsUnc{} -> True- Just RootWindowsDoubleQMark -> True- Nothing -> False+ Just RootPosix -> True+ Just RootWindowsVolume{} -> True+ Just RootWindowsCurrentVolume -> False+ Just RootWindowsUnc{} -> True+ Just RootWindowsDoubleQMark -> True+ Nothing -> False -- | Test whether a path is relative. relative :: FilePath -> Bool relative p = case pathRoot p of- Just _ -> False- _ -> True+ Just _ -> False+ _ -> True ------------------------------------------------------------------------------- -- Basic operations@@ -174,23 +174,23 @@ -- unchanged. append :: FilePath -> FilePath -> FilePath append x y = cased where- cased = case pathRoot y of- Just RootPosix -> y- Just RootWindowsVolume{} -> y- Just RootWindowsCurrentVolume -> case pathRoot x of- Just RootWindowsVolume{} -> y { pathRoot = pathRoot x }- _ -> y- Just RootWindowsUnc{} -> y- Just RootWindowsDoubleQMark -> y- Nothing -> xy- xy = y- { pathRoot = pathRoot x- , pathDirectories = directories- }- directories = xDirectories ++ pathDirectories y- xDirectories = (pathDirectories x ++) $ if null (filename x)- then []- else [filenameChunk x]+ cased = case pathRoot y of+ Just RootPosix -> y+ Just RootWindowsVolume{} -> y+ Just RootWindowsCurrentVolume -> case pathRoot x of+ Just RootWindowsVolume{} -> y { pathRoot = pathRoot x }+ _ -> y+ Just RootWindowsUnc{} -> y+ Just RootWindowsDoubleQMark -> y+ Nothing -> xy+ xy = y+ { pathRoot = pathRoot x+ , pathDirectories = directories+ }+ directories = xDirectories ++ pathDirectories y+ xDirectories = (pathDirectories x ++) $ if null (filename x)+ then []+ else [filenameChunk x] -- | An alias for 'append'. (</>) :: FilePath -> FilePath -> FilePath@@ -205,23 +205,23 @@ commonPrefix :: [FilePath] -> FilePath commonPrefix [] = empty commonPrefix ps = foldr1 step ps where- step x y = if pathRoot x /= pathRoot y- then empty- else let cs = commonDirectories x y in- if cs /= pathDirectories x || pathBasename x /= pathBasename y- then empty { pathRoot = pathRoot x, pathDirectories = cs }- else let exts = commonExtensions x y in- x { pathExtensions = exts }- - commonDirectories x y = common (pathDirectories x) (pathDirectories y)- commonExtensions x y = common (pathExtensions x) (pathExtensions y)- - common [] _ = []- common _ [] = []- common (x:xs) (y:ys) = if x == y- then x : common xs ys- else []+ step x y = if pathRoot x /= pathRoot y+ then empty+ else let cs = commonDirectories x y in+ if cs /= pathDirectories x || pathBasename x /= pathBasename y+ then empty { pathRoot = pathRoot x, pathDirectories = cs }+ else let exts = commonExtensions x y in+ x { pathExtensions = exts } + commonDirectories x y = common (pathDirectories x) (pathDirectories y)+ commonExtensions x y = common (pathExtensions x) (pathExtensions y)++ common [] _ = []+ common _ [] = []+ common (x:xs) (y:ys) = if x == y+ then x : common xs ys+ else []+ -- | Remove a prefix from a path. -- -- @@@ -241,33 +241,33 @@ -- Since: 0.4.1 stripPrefix :: FilePath -> FilePath -> Maybe FilePath stripPrefix x y = if pathRoot x /= pathRoot y- then case pathRoot x of- Nothing -> Just y- Just _ -> Nothing- else do- dirs <- strip (pathDirectories x) (pathDirectories y)- case dirs of- [] -> case (pathBasename x, pathBasename y) of- (Nothing, Nothing) -> do- exts <- strip (pathExtensions x) (pathExtensions y)- return (y { pathRoot = Nothing, pathDirectories = dirs, pathExtensions = exts })- (Nothing, Just _) -> case pathExtensions x of- [] -> Just (y { pathRoot = Nothing, pathDirectories = dirs })- _ -> Nothing- (Just x_b, Just y_b) | x_b == y_b -> do- exts <- strip (pathExtensions x) (pathExtensions y)- return (empty { pathExtensions = exts })- _ -> Nothing- _ -> case (pathBasename x, pathExtensions x) of- (Nothing, []) -> Just (y { pathRoot = Nothing, pathDirectories = dirs })- _ -> Nothing+ then case pathRoot x of+ Nothing -> Just y+ Just _ -> Nothing+ else do+ dirs <- strip (pathDirectories x) (pathDirectories y)+ case dirs of+ [] -> case (pathBasename x, pathBasename y) of+ (Nothing, Nothing) -> do+ exts <- strip (pathExtensions x) (pathExtensions y)+ return (y { pathRoot = Nothing, pathDirectories = dirs, pathExtensions = exts })+ (Nothing, Just _) -> case pathExtensions x of+ [] -> Just (y { pathRoot = Nothing, pathDirectories = dirs })+ _ -> Nothing+ (Just x_b, Just y_b) | x_b == y_b -> do+ exts <- strip (pathExtensions x) (pathExtensions y)+ return (empty { pathExtensions = exts })+ _ -> Nothing+ _ -> case (pathBasename x, pathExtensions x) of+ (Nothing, []) -> Just (y { pathRoot = Nothing, pathDirectories = dirs })+ _ -> Nothing strip :: Eq a => [a] -> [a] -> Maybe [a] strip [] ys = Just ys strip _ [] = Nothing strip (x:xs) (y:ys) = if x == y- then strip xs ys- else Nothing+ then strip xs ys+ else Nothing -- | Remove intermediate @\".\"@ and @\"..\"@ directories from a path. --@@ -284,32 +284,32 @@ -- Since: 0.2 collapse :: FilePath -> FilePath collapse p = p { pathDirectories = newDirs } where- newDirs = case pathRoot p of- Nothing -> reverse revNewDirs- Just _ -> dropWhile (\x -> x == dot || x == dots) (reverse revNewDirs)- (_, revNewDirs) = foldl' step (True, []) (pathDirectories p)- - step (True, acc) c = (False, c:acc)- step (_, acc) c | c == dot = (False, acc)- step (_, acc) c | c == dots = case acc of- [] -> (False, c:acc)- (h:ts) | h == dot -> (False, c:ts)- | h == dots -> (False, c:acc)- | otherwise -> (False, ts)- step (_, acc) c = (False, c:acc)+ newDirs = case pathRoot p of+ Nothing -> reverse revNewDirs+ Just _ -> dropWhile (\x -> x == dot || x == dots) (reverse revNewDirs)+ (_, revNewDirs) = foldl' step (True, []) (pathDirectories p) + step (True, acc) c = (False, c:acc)+ step (_, acc) c | c == dot = (False, acc)+ step (_, acc) c | c == dots = case acc of+ [] -> (False, c:acc)+ (h:ts) | h == dot -> (False, c:ts)+ | h == dots -> (False, c:acc)+ | otherwise -> (False, ts)+ step (_, acc) c = (False, c:acc)+ -- | expand a FilePath into a list of the root name, directories, and file name -- -- Since: 0.4.7 splitDirectories :: FilePath -> [FilePath] splitDirectories p = rootName ++ dirNames ++ fileName where- rootName = case pathRoot p of- Nothing -> []- r -> [empty { pathRoot = r }]- dirNames = map (\d -> empty { pathDirectories = [d] }) (pathDirectories p)- fileName = case (pathBasename p, pathExtensions p) of- (Nothing, []) -> []- _ -> [filename p]+ rootName = case pathRoot p of+ Nothing -> []+ r -> [empty { pathRoot = r }]+ dirNames = map (\d -> empty { pathDirectories = [d] }) (pathDirectories p)+ fileName = case (pathBasename p, pathExtensions p) of+ (Nothing, []) -> []+ _ -> [filename p] ------------------------------------------------------------------------------- -- Extensions@@ -319,8 +319,8 @@ -- extensions. extension :: FilePath -> Maybe T.Text extension p = case extensions p of- [] -> Nothing- es -> Just (last es)+ [] -> Nothing+ es -> Just (last es) -- | Get a 'FilePath'’s full extension list. extensions :: FilePath -> [T.Text]@@ -338,7 +338,7 @@ -- | Append many extensions to the end of a 'FilePath'. addExtensions :: FilePath -> [T.Text] -> FilePath addExtensions p exts = p { pathExtensions = newExtensions } where- newExtensions = pathExtensions p ++ map escape exts+ newExtensions = pathExtensions p ++ map escape exts -- | An alias for 'addExtension'. (<.>) :: FilePath -> T.Text -> FilePath@@ -375,8 +375,8 @@ safeInit :: [a] -> [a] safeInit xs = case xs of- [] -> []- _ -> init xs+ [] -> []+ _ -> init xs safeHead :: [a] -> Maybe a safeHead [] = Nothing
lib/Filesystem/Path/CurrentOS.hs view
@@ -15,23 +15,23 @@ -- Also enables 'Show' and 'S.IsString' instances for 'F.FilePath'. -- module Filesystem.Path.CurrentOS- ( module Filesystem.Path- , currentOS- - -- * Type conversions- , toText- , fromText- , encode- , decode- , encodeString- , decodeString- - -- * Rule‐specific path properties- , valid- , splitSearchPath- , splitSearchPathString- ) where+ ( module Filesystem.Path+ , currentOS + -- * Type conversions+ , toText+ , fromText+ , encode+ , decode+ , encodeString+ , decodeString++ -- * Rule‐specific path properties+ , valid+ , splitSearchPath+ , splitSearchPathString+ ) where+ import Prelude hiding (FilePath) import qualified Data.ByteString as B@@ -42,7 +42,7 @@ import qualified Filesystem.Path as F import qualified Filesystem.Path.Rules as R -#if defined(__HADDOCK__)+#if defined(__HADDOCK_VERSION__) # define PLATFORM_PATH_FORMAT platformTextFormat #elif defined(CABAL_OS_WINDOWS) || defined(CABAL_OS_DARWIN) # define PLATFORM_PATH_FORMAT T.Text@@ -51,7 +51,7 @@ #endif currentOS :: R.Rules PLATFORM_PATH_FORMAT-#if defined(__HADDOCK__)+#if defined(__HADDOCK_VERSION__) currentOS = undefined #elif defined(CABAL_OS_WINDOWS) currentOS = R.windows@@ -72,13 +72,13 @@ #endif instance S.IsString F.FilePath where- fromString = R.fromText currentOS . T.pack+ fromString = R.fromText currentOS . T.pack instance Show F.FilePath where- showsPrec d path = showParen (d > 10) (ss "FilePath " . s txt) where- s = shows- ss = showString- txt = either id id (toText path)+ showsPrec d path = showParen (d > 10) (ss "FilePath " . s txt) where+ s = shows+ ss = showString+ txt = either id id (toText path) -- | Attempt to convert a 'F.FilePath' to human‐readable text. --
lib/Filesystem/Path/Internal.hs view
@@ -36,39 +36,39 @@ type Extension = Chunk data Root- = RootPosix- | RootWindowsVolume Char Bool- | RootWindowsCurrentVolume- | RootWindowsUnc String String Bool- | RootWindowsDoubleQMark- deriving (Eq, Ord, Data, Typeable, Show)+ = RootPosix+ | RootWindowsVolume Char Bool+ | RootWindowsCurrentVolume+ | RootWindowsUnc String String Bool+ | RootWindowsDoubleQMark+ deriving (Eq, Ord, Data, Typeable, Show) data FilePath = FilePath- { pathRoot :: Maybe Root- , pathDirectories :: [Directory]- , pathBasename :: Maybe Basename- , pathExtensions :: [Extension]- }- deriving (Data, Typeable)+ { pathRoot :: Maybe Root+ , pathDirectories :: [Directory]+ , pathBasename :: Maybe Basename+ , pathExtensions :: [Extension]+ }+ deriving (Data, Typeable) instance Eq FilePath where- x == y = compare x y == EQ+ x == y = compare x y == EQ instance Ord FilePath where- compare = comparing (\p ->- (pathRoot p- , fmap unescape' (pathDirectories p)- , fmap unescape' (pathBasename p)- , fmap unescape' (pathExtensions p)- ))+ compare = comparing (\p ->+ (pathRoot p+ , fmap unescape' (pathDirectories p)+ , fmap unescape' (pathBasename p)+ , fmap unescape' (pathExtensions p)+ )) instance NFData Root where- rnf (RootWindowsVolume c extended) = rnf c `seq` rnf extended- rnf (RootWindowsUnc host share extended) = rnf host `seq` rnf share `seq` rnf extended- rnf _ = ()+ rnf (RootWindowsVolume c extended) = rnf c `seq` rnf extended+ rnf (RootWindowsUnc host share extended) = rnf host `seq` rnf share `seq` rnf extended+ rnf _ = () instance NFData FilePath where- rnf p = rnf (pathRoot p) `seq` rnf (pathDirectories p) `seq` rnf (pathBasename p) `seq` rnf (pathExtensions p)+ rnf p = rnf (pathRoot p) `seq` rnf (pathDirectories p) `seq` rnf (pathBasename p) `seq` rnf (pathExtensions p) -- | A file path with no root, directory, or filename empty :: FilePath@@ -82,20 +82,20 @@ filenameChunk :: FilePath -> Chunk filenameChunk p = concat (name:exts) where- name = maybe "" id (pathBasename p)- exts = case pathExtensions p of- [] -> []- exts' -> intersperse dot ("":exts')+ name = maybe "" id (pathBasename p)+ exts = case pathExtensions p of+ [] -> []+ exts' -> intersperse dot ("":exts') rootChunk :: Maybe Root -> Chunk rootChunk r = flip (maybe "") r $ \r' -> case r' of- RootPosix -> "/"- RootWindowsVolume c False -> c : ":\\"- RootWindowsVolume c True -> "\\\\?\\" ++ (c : ":\\")- RootWindowsCurrentVolume -> "\\"- RootWindowsUnc host share False -> "\\\\" ++ host ++ "\\" ++ share- RootWindowsUnc host share True -> "\\\\?\\UNC\\" ++ host ++ "\\" ++ share- RootWindowsDoubleQMark -> "\\??\\"+ RootPosix -> "/"+ RootWindowsVolume c False -> c : ":\\"+ RootWindowsVolume c True -> "\\\\?\\" ++ (c : ":\\")+ RootWindowsCurrentVolume -> "\\"+ RootWindowsUnc host share False -> "\\\\" ++ host ++ "\\" ++ share+ RootWindowsUnc host share True -> "\\\\?\\UNC\\" ++ host ++ "\\" ++ share+ RootWindowsDoubleQMark -> "\\??\\" rootText :: Maybe Root -> T.Text rootText = T.pack . rootChunk@@ -107,7 +107,7 @@ -- Rules ------------------------------------------------------------------------------- --- | The type of @platformFormat@ for 'Rules' is conditionally selected at +-- | The type of @platformFormat@ for 'Rules' is conditionally selected at -- compilation time. As such it is only intended for direct use with external OS -- functions and code that expects @platformFormat@ to be stable across platforms -- may fail to subsequently compile on a differing platform.@@ -118,124 +118,124 @@ -- If portability is a concern, restrict usage to functions which do not expose -- @platformFormat@ directly. data Rules platformFormat = Rules- { rulesName :: T.Text- - -- | Check if a 'FilePath' is valid; it must not contain any illegal- -- characters, and must have a root appropriate to the current- -- 'Rules'.- , valid :: FilePath -> Bool- - -- | Split a search path, such as @$PATH@ or @$PYTHONPATH@, into- -- a list of 'FilePath's.- --- -- Note: The type of @platformTextFormat@ can change depending upon the- -- underlying compilation platform. Consider using 'splitSearchPathString'- -- instead. See 'Rules' for more information.- , splitSearchPath :: platformFormat -> [FilePath]- - -- | splitSearchPathString is like 'splitSearchPath', but takes a string- -- encoded in the format used by @System.IO@.- , splitSearchPathString :: String -> [FilePath]- - -- | Attempt to convert a 'FilePath' to human‐readable text.- --- -- If the path is decoded successfully, the result is a 'Right'- -- containing the decoded text. Successfully decoded text can be- -- converted back to the original path using 'fromText'.- --- -- If the path cannot be decoded, the result is a 'Left' containing an- -- approximation of the original path. If displayed to the user, this- -- value should be accompanied by some warning that the path has an- -- invalid encoding. Approximated text cannot be converted back to the- -- original path.- --- -- This function ignores the user’s locale, and assumes all- -- file paths are encoded in UTF8. If you need to display file paths- -- with an unusual or obscure encoding, use 'encode' and then decode- -- them manually.- --- -- Since: 0.2- , toText :: FilePath -> Either T.Text T.Text- - -- | Convert human‐readable text into a 'FilePath'.- --- -- This function ignores the user’s locale, and assumes all- -- file paths are encoded in UTF8. If you need to create file paths- -- with an unusual or obscure encoding, encode them manually and then- -- use 'decode'.- --- -- Since: 0.2- , fromText :: T.Text -> FilePath- - -- | Convert a 'FilePath' to a platform‐specific format,- -- suitable for use with external OS functions.- --- -- Note: The type of @platformTextFormat@ can change depending upon the- -- underlying compilation platform. Consider using 'toText' or- -- 'encodeString' instead. See 'Rules' for more information.+ { rulesName :: T.Text++ -- | Check if a 'FilePath' is valid; it must not contain any illegal+ -- characters, and must have a root appropriate to the current+ -- 'Rules'.+ , valid :: FilePath -> Bool++ -- | Split a search path, such as @$PATH@ or @$PYTHONPATH@, into+ -- a list of 'FilePath's.+ --+ -- Note: The type of @platformTextFormat@ can change depending upon the+ -- underlying compilation platform. Consider using 'splitSearchPathString'+ -- instead. See 'Rules' for more information.+ , splitSearchPath :: platformFormat -> [FilePath]++ -- | splitSearchPathString is like 'splitSearchPath', but takes a string+ -- encoded in the format used by @System.IO@.+ , splitSearchPathString :: String -> [FilePath]++ -- | Attempt to convert a 'FilePath' to human‐readable text.+ --+ -- If the path is decoded successfully, the result is a 'Right'+ -- containing the decoded text. Successfully decoded text can be+ -- converted back to the original path using 'fromText'.+ --+ -- If the path cannot be decoded, the result is a 'Left' containing an+ -- approximation of the original path. If displayed to the user, this+ -- value should be accompanied by some warning that the path has an+ -- invalid encoding. Approximated text cannot be converted back to the+ -- original path.+ --+ -- This function ignores the user’s locale, and assumes all+ -- file paths are encoded in UTF8. If you need to display file paths+ -- with an unusual or obscure encoding, use 'encode' and then decode+ -- them manually.+ --+ -- Since: 0.2+ , toText :: FilePath -> Either T.Text T.Text++ -- | Convert human‐readable text into a 'FilePath'.+ --+ -- This function ignores the user’s locale, and assumes all+ -- file paths are encoded in UTF8. If you need to create file paths+ -- with an unusual or obscure encoding, encode them manually and then+ -- use 'decode'.+ --+ -- Since: 0.2+ , fromText :: T.Text -> FilePath++ -- | Convert a 'FilePath' to a platform‐specific format,+ -- suitable for use with external OS functions.+ --+ -- Note: The type of @platformTextFormat@ can change depending upon the+ -- underlying compilation platform. Consider using 'toText' or+ -- 'encodeString' instead. See 'Rules' for more information. --- -- Since: 0.3- , encode :: FilePath -> platformFormat- - -- | Convert a 'FilePath' from a platform‐specific format,- -- suitable for use with external OS functions.- --- -- Note: The type of @platformTextFormat@ can change depending upon the- -- underlying compilation platform. Consider using 'fromText' or- -- 'decodeString' instead. See 'Rules' for more information.+ -- Since: 0.3+ , encode :: FilePath -> platformFormat++ -- | Convert a 'FilePath' from a platform‐specific format,+ -- suitable for use with external OS functions.+ --+ -- Note: The type of @platformTextFormat@ can change depending upon the+ -- underlying compilation platform. Consider using 'fromText' or+ -- 'decodeString' instead. See 'Rules' for more information. --- -- Since: 0.3- , decode :: platformFormat -> FilePath- - -- | Attempt to convert a 'FilePath' to a string suitable for use with- -- functions in @System.IO@. The contents of this string are- -- platform‐dependent, and are not guaranteed to be- -- human‐readable. For converting 'FilePath's to a- -- human‐readable format, use 'toText'.- --- -- Since: 0.3.1- , encodeString :: FilePath -> String- - -- | Attempt to parse a 'FilePath' from a string suitable for use- -- with functions in @System.IO@. Do not use this function for parsing- -- human‐readable paths, as the character set decoding is- -- platform‐dependent. For converting human‐readable- -- text to a 'FilePath', use 'fromText'.- --- -- Since: 0.3.1- , decodeString :: String -> FilePath- }+ -- Since: 0.3+ , decode :: platformFormat -> FilePath + -- | Attempt to convert a 'FilePath' to a string suitable for use with+ -- functions in @System.IO@. The contents of this string are+ -- platform‐dependent, and are not guaranteed to be+ -- human‐readable. For converting 'FilePath's to a+ -- human‐readable format, use 'toText'.+ --+ -- Since: 0.3.1+ , encodeString :: FilePath -> String++ -- | Attempt to parse a 'FilePath' from a string suitable for use+ -- with functions in @System.IO@. Do not use this function for parsing+ -- human‐readable paths, as the character set decoding is+ -- platform‐dependent. For converting human‐readable+ -- text to a 'FilePath', use 'fromText'.+ --+ -- Since: 0.3.1+ , decodeString :: String -> FilePath+ }+ instance Show (Rules a) where- showsPrec d r = showParen (d > 10)- (showString "Rules " . shows (rulesName r))+ showsPrec d r = showParen (d > 10)+ (showString "Rules " . shows (rulesName r)) escape :: T.Text -> Chunk escape t = T.unpack t unescape :: Chunk -> (T.Text, Bool) unescape cs = if any (\c -> ord c >= 0xDC80 && ord c <= 0xDCFF) cs- then (T.pack (map (\c -> if ord c >= 0xDC80 && ord c <= 0xDCFF- then chr (ord c - 0xDC00)- else c) cs), False)- else (T.pack cs, True)+ then (T.pack (map (\c -> if ord c >= 0xDC80 && ord c <= 0xDCFF+ then chr (ord c - 0xDC00)+ else c) cs), False)+ else (T.pack cs, True) unescape' :: Chunk -> T.Text unescape' = fst . unescape unescapeBytes' :: Chunk -> B.ByteString unescapeBytes' cs = if any (\c -> ord c >= 0xDC80 && ord c <= 0xDCFF) cs- then B8.concat (map (\c -> if ord c >= 0xDC80 && ord c <= 0xDCFF- then B8.singleton (chr (ord c - 0xDC00))- else TE.encodeUtf8 (T.singleton c)) cs)- else TE.encodeUtf8 (T.pack cs)+ then B8.concat (map (\c -> if ord c >= 0xDC80 && ord c <= 0xDCFF+ then B8.singleton (chr (ord c - 0xDC00))+ else TE.encodeUtf8 (T.singleton c)) cs)+ else TE.encodeUtf8 (T.pack cs) splitBy :: (a -> Bool) -> [a] -> [[a]] splitBy p = loop where- loop xs = let- (chunk, rest) = break p xs- cont = chunk : loop (tail rest)- in if null rest then [chunk] else cont+ loop xs = let+ (chunk, rest) = break p xs+ cont = chunk : loop (tail rest)+ in if null rest then [chunk] else cont textSplitBy :: (Char -> Bool) -> T.Text -> [T.Text] #if MIN_VERSION_text(0,11,0)@@ -246,17 +246,17 @@ parseFilename :: Chunk -> (Maybe Basename, [Extension]) parseFilename filename = parsed where- parsed = if null filename- then (Nothing, [])- else case span (== '.') filename of- (leadingDots, baseAndExts) -> case splitBy (== '.') baseAndExts of- [] -> (joinDots leadingDots "", [])- (name':exts') -> (joinDots leadingDots name', exts')- joinDots leadingDots base = case leadingDots ++ base of- [] -> Nothing- joined -> Just joined+ parsed = if null filename+ then (Nothing, [])+ else case span (== '.') filename of+ (leadingDots, baseAndExts) -> case splitBy (== '.') baseAndExts of+ [] -> (joinDots leadingDots "", [])+ (name':exts') -> (joinDots leadingDots name', exts')+ joinDots leadingDots base = case leadingDots ++ base of+ [] -> Nothing+ joined -> Just joined maybeDecodeUtf8 :: B.ByteString -> Maybe T.Text maybeDecodeUtf8 bytes = case TE.decodeUtf8' bytes of- Left _ -> Nothing- Right text -> Just text+ Left _ -> Nothing+ Right text -> Just text
lib/Filesystem/Path/Rules.hs view
@@ -7,28 +7,28 @@ -- Portability: portable -- module Filesystem.Path.Rules- ( Rules- , posix- , posix_ghc702- , posix_ghc704- , windows- , darwin- , darwin_ghc702- - -- * Type conversions- , toText- , fromText- , encode- , decode- , encodeString- , decodeString- - -- * Rule‐specific path properties- , valid- , splitSearchPath- , splitSearchPathString- ) where+ ( Rules+ , posix+ , posix_ghc702+ , posix_ghc704+ , windows+ , darwin+ , darwin_ghc702 + -- * Type conversions+ , toText+ , fromText+ , encode+ , decode+ , encodeString+ , decodeString++ -- * Rule‐specific path properties+ , valid+ , splitSearchPath+ , splitSearchPathString+ ) where+ import Prelude hiding (FilePath, null) import qualified Prelude as P @@ -50,17 +50,17 @@ -- | Linux, BSD, and other UNIX or UNIX-like operating systems. posix :: Rules B.ByteString posix = Rules- { rulesName = T.pack "POSIX"- , valid = posixValid- , splitSearchPath = posixSplitSearch- , splitSearchPathString = posixSplitSearch . B8.pack- , toText = posixToText- , fromText = posixFromText- , encode = posixToBytes- , decode = posixFromBytes- , encodeString = B8.unpack . posixToBytes- , decodeString = posixFromBytes . B8.pack- }+ { rulesName = T.pack "POSIX"+ , valid = posixValid+ , splitSearchPath = posixSplitSearch+ , splitSearchPathString = posixSplitSearch . B8.pack+ , toText = posixToText+ , fromText = posixFromText+ , encode = posixToBytes+ , decode = posixFromBytes+ , encodeString = B8.unpack . posixToBytes+ , decodeString = posixFromBytes . B8.pack+ } -- | Linux, BSD, and other UNIX or UNIX-like operating systems. --@@ -70,11 +70,11 @@ -- Since: 0.3.3 / 0.4.2 posix_ghc702 :: Rules B.ByteString posix_ghc702 = posix- { rulesName = T.pack "POSIX (GHC 7.2)"- , splitSearchPathString = posixSplitSearchString posixFromGhc702String- , encodeString = posixToGhc702String- , decodeString = posixFromGhc702String- }+ { rulesName = T.pack "POSIX (GHC 7.2)"+ , splitSearchPathString = posixSplitSearchString posixFromGhc702String+ , encodeString = posixToGhc702String+ , decodeString = posixFromGhc702String+ } -- | Linux, BSD, and other UNIX or UNIX-like operating systems. --@@ -84,113 +84,113 @@ -- Since: 0.3.7 / 0.4.6 posix_ghc704 :: Rules B.ByteString posix_ghc704 = posix- { rulesName = T.pack "POSIX (GHC 7.4)"- , splitSearchPathString = posixSplitSearchString posixFromGhc704String- , encodeString = posixToGhc704String- , decodeString = posixFromGhc704String- }+ { rulesName = T.pack "POSIX (GHC 7.4)"+ , splitSearchPathString = posixSplitSearchString posixFromGhc704String+ , encodeString = posixToGhc704String+ , decodeString = posixFromGhc704String+ } posixToText :: FilePath -> Either T.Text T.Text posixToText p = if good then Right text else Left text where- good = and (map snd chunks)- text = T.concat (root : map fst chunks)- - root = rootText (pathRoot p)- chunks = intersperse (T.pack "/", True) (map unescape (directoryChunks p))+ good = and (map snd chunks)+ text = T.concat (root : map fst chunks) + root = rootText (pathRoot p)+ chunks = intersperse (T.pack "/", True) (map unescape (directoryChunks p))+ posixFromChunks :: [Chunk] -> FilePath posixFromChunks chunks = FilePath root directories basename exts where- (root, pastRoot) = if P.null (head chunks)- then (Just RootPosix, tail chunks)- else (Nothing, chunks)- - (directories, filename)- | P.null pastRoot = ([], "")- | otherwise = case last pastRoot of- fn | fn == dot -> (goodDirs pastRoot, "")- fn | fn == dots -> (goodDirs pastRoot, "")- fn -> (goodDirs (init pastRoot), fn)- - goodDirs = filter (not . P.null)- - (basename, exts) = parseFilename filename+ (root, pastRoot) = if P.null (head chunks)+ then (Just RootPosix, tail chunks)+ else (Nothing, chunks) + (directories, filename)+ | P.null pastRoot = ([], "")+ | otherwise = case last pastRoot of+ fn | fn == dot -> (goodDirs pastRoot, "")+ fn | fn == dots -> (goodDirs pastRoot, "")+ fn -> (goodDirs (init pastRoot), fn)++ goodDirs = filter (not . P.null)++ (basename, exts) = parseFilename filename+ posixFromText :: T.Text -> FilePath posixFromText text = if T.null text- then empty- else posixFromChunks (map escape (textSplitBy (== '/') text))+ then empty+ else posixFromChunks (map escape (textSplitBy (== '/') text)) posixToBytes :: FilePath -> B.ByteString posixToBytes p = B.concat (root : chunks) where- root = B8.pack (rootChunk (pathRoot p))- chunks = intersperse (B8.pack "/") (map chunkBytes (directoryChunks p))- chunkBytes c = unescapeBytes' c+ root = B8.pack (rootChunk (pathRoot p))+ chunks = intersperse (B8.pack "/") (map chunkBytes (directoryChunks p))+ chunkBytes c = unescapeBytes' c posixFromBytes :: B.ByteString -> FilePath posixFromBytes bytes = if B.null bytes- then empty- else posixFromChunks $ flip map (B.split 0x2F bytes) $ \b -> case maybeDecodeUtf8 b of- Just text -> escape text- Nothing -> processInvalidUtf8 b+ then empty+ else posixFromChunks $ flip map (B.split 0x2F bytes) $ \b -> case maybeDecodeUtf8 b of+ Just text -> escape text+ Nothing -> processInvalidUtf8 b processInvalidUtf8 :: B.ByteString -> Chunk processInvalidUtf8 bytes = intercalate "." textChunks where- byteChunks = B.split 0x2E bytes- textChunks = map unicodeDammit byteChunks- unicodeDammit b = case maybeDecodeUtf8 b of- Just t -> escape t- Nothing -> map (\c -> if ord c >= 0x80- then chr (ord c + 0xDC00)- else c) (B8.unpack b)+ byteChunks = B.split 0x2E bytes+ textChunks = map unicodeDammit byteChunks+ unicodeDammit b = case maybeDecodeUtf8 b of+ Just t -> escape t+ Nothing -> map (\c -> if ord c >= 0x80+ then chr (ord c + 0xDC00)+ else c) (B8.unpack b) posixToGhc702String :: FilePath -> String posixToGhc702String p = P.concat (root : chunks) where- root = rootChunk (pathRoot p)- chunks = intersperse "/" (map escapeToGhc702 (directoryChunks p))+ root = rootChunk (pathRoot p)+ chunks = intersperse "/" (map escapeToGhc702 (directoryChunks p)) escapeToGhc702 :: Chunk -> String escapeToGhc702 = map (\c -> if ord c >= 0xDC80 && ord c <= 0xDCFF- then chr (ord c - 0xDC00 + 0xEF00)- else c)+ then chr (ord c - 0xDC00 + 0xEF00)+ else c) posixFromGhc702String :: String -> FilePath posixFromGhc702String cs = if P.null cs- then empty- else posixFromChunks (map escapeFromGhc702 (splitBy (== '/') cs))+ then empty+ else posixFromChunks (map escapeFromGhc702 (splitBy (== '/') cs)) escapeFromGhc702 :: String -> String escapeFromGhc702 = map (\c -> if ord c >= 0xEF80 && ord c <= 0xEFFF- -- hopefully this isn't a valid UTF8 filename decoding to these- -- codepoints, but there's no way to tell here.- then chr (ord c - 0xEF00 + 0xDC00)- else c)+ -- hopefully this isn't a valid UTF8 filename decoding to these+ -- codepoints, but there's no way to tell here.+ then chr (ord c - 0xEF00 + 0xDC00)+ else c) posixToGhc704String :: FilePath -> String posixToGhc704String p = P.concat (root : chunks) where- root = rootChunk (pathRoot p)- chunks = intersperse "/" (directoryChunks p)+ root = rootChunk (pathRoot p)+ chunks = intersperse "/" (directoryChunks p) posixFromGhc704String :: String -> FilePath posixFromGhc704String cs = if P.null cs- then empty- else posixFromChunks (splitBy (== '/') cs)+ then empty+ else posixFromChunks (splitBy (== '/') cs) posixValid :: FilePath -> Bool posixValid p = validRoot && validDirectories where- validDirectories = all validChunk (directoryChunks p)- validChunk ch = not (any (\c -> c == '\0' || c == '/') ch)- validRoot = case pathRoot p of- Nothing -> True- Just RootPosix -> True- _ -> False+ validDirectories = all validChunk (directoryChunks p)+ validChunk ch = not (any (\c -> c == '\0' || c == '/') ch)+ validRoot = case pathRoot p of+ Nothing -> True+ Just RootPosix -> True+ _ -> False posixSplitSearch :: B.ByteString -> [FilePath] posixSplitSearch = map (posixFromBytes . normSearch) . B.split 0x3A where- normSearch bytes = if B.null bytes then B8.pack "." else bytes+ normSearch bytes = if B.null bytes then B8.pack "." else bytes posixSplitSearchString :: (String -> FilePath) -> String -> [FilePath] posixSplitSearchString toPath = map (toPath . normSearch) . splitBy (== ':') where- normSearch s = if P.null s then "." else s+ normSearch s = if P.null s then "." else s ------------------------------------------------------------------------------- -- Darwin@@ -204,17 +204,17 @@ -- Since: 0.3.4 / 0.4.3 darwin :: Rules T.Text darwin = Rules- { rulesName = T.pack "Darwin"- , valid = posixValid- , splitSearchPath = darwinSplitSearch- , splitSearchPathString = darwinSplitSearch . TE.decodeUtf8 . B8.pack- , toText = Right . darwinToText- , fromText = posixFromText- , encode = darwinToText- , decode = posixFromText- , encodeString = darwinToString- , decodeString = darwinFromString- }+ { rulesName = T.pack "Darwin"+ , valid = posixValid+ , splitSearchPath = darwinSplitSearch+ , splitSearchPathString = darwinSplitSearch . TE.decodeUtf8 . B8.pack+ , toText = Right . darwinToText+ , fromText = posixFromText+ , encode = darwinToText+ , decode = posixFromText+ , encodeString = darwinToString+ , decodeString = darwinFromString+ } -- | Darwin and Mac OS X. --@@ -224,16 +224,16 @@ -- Since: 0.3.4 / 0.4.3 darwin_ghc702 :: Rules T.Text darwin_ghc702 = darwin- { rulesName = T.pack "Darwin (GHC 7.2)"- , splitSearchPathString = darwinSplitSearch . T.pack- , encodeString = T.unpack . darwinToText- , decodeString = posixFromText . T.pack- }+ { rulesName = T.pack "Darwin (GHC 7.2)"+ , splitSearchPathString = darwinSplitSearch . T.pack+ , encodeString = T.unpack . darwinToText+ , decodeString = posixFromText . T.pack+ } darwinToText :: FilePath -> T.Text darwinToText p = T.concat (root : chunks) where- root = rootText (pathRoot p)- chunks = intersperse (T.pack "/") (map unescape' (directoryChunks p))+ root = rootText (pathRoot p)+ chunks = intersperse (T.pack "/") (map unescape' (directoryChunks p)) darwinToString :: FilePath -> String darwinToString = B8.unpack . TE.encodeUtf8 . darwinToText@@ -243,7 +243,7 @@ darwinSplitSearch :: T.Text -> [FilePath] darwinSplitSearch = map (posixFromText . normSearch) . textSplitBy (== ':') where- normSearch text = if T.null text then T.pack "." else text+ normSearch text = if T.null text then T.pack "." else text ------------------------------------------------------------------------------- -- Windows@@ -252,142 +252,142 @@ -- | Windows and DOS windows :: Rules T.Text windows = Rules- { rulesName = T.pack "Windows"- , valid = winValid- , splitSearchPath = winSplit- , splitSearchPathString = winSplit . T.pack- , toText = Right . winToText- , fromText = winFromText- , encode = winToText- , decode = winFromText- , encodeString = T.unpack . winToText- , decodeString = winFromText . T.pack- }+ { rulesName = T.pack "Windows"+ , valid = winValid+ , splitSearchPath = winSplit+ , splitSearchPathString = winSplit . T.pack+ , toText = Right . winToText+ , fromText = winFromText+ , encode = winToText+ , decode = winFromText+ , encodeString = T.unpack . winToText+ , decodeString = winFromText . T.pack+ } winToText :: FilePath -> T.Text winToText p = case pathRoot p of- Just RootWindowsUnc{} -> uncToText p- _ -> dosToText p+ Just RootWindowsUnc{} -> uncToText p+ _ -> dosToText p dosToText :: FilePath -> T.Text dosToText p = T.concat (root : chunks) where- root = rootText (pathRoot p)- chunks = intersperse (T.pack "\\") (map unescape' (directoryChunks p))+ root = rootText (pathRoot p)+ chunks = intersperse (T.pack "\\") (map unescape' (directoryChunks p)) uncToText :: FilePath -> T.Text uncToText p = T.concat (root : chunks) where- root = if all T.null chunks- then rootText (pathRoot p)- else rootText (pathRoot p) `T.append` T.pack "\\"- chunks = intersperse (T.pack "\\") (filter (not . T.null) (map unescape' (directoryChunks p)))+ root = if all T.null chunks+ then rootText (pathRoot p)+ else rootText (pathRoot p) `T.append` T.pack "\\"+ chunks = intersperse (T.pack "\\") (filter (not . T.null) (map unescape' (directoryChunks p))) winFromText :: T.Text -> FilePath winFromText text = if T.null text then empty else path where- path = FilePath root directories basename exts- - -- Windows has various types of absolute paths:- --- -- * C:\foo\bar -> DOS-style absolute path- -- * \\?\C:\foo\bar -> extended-length absolute path- -- * \\host\share\foo\bar -> UNC path- -- * \\?\UNC\host\share\foo\bar -> extended-length UNC path- --- -- \foo\bar looks like an absolute path, but is actually a path- -- relative to the current DOS drive.- --- -- http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx- (root, pastRoot) = if T.isPrefixOf (T.pack "\\\\") text- then case stripUncasedPrefix (T.pack "\\\\?\\UNC\\") text of- Just stripped -> parseUncRoot stripped True- Nothing -> case T.stripPrefix (T.pack "\\\\?\\") text of- Just stripped -> parseDosRoot stripped True- Nothing -> case T.stripPrefix (T.pack "\\\\") text of- Just stripped -> parseUncRoot stripped False- Nothing -> parseDosRoot text False- else case T.stripPrefix (T.pack "\\??\\") text of- Just stripped -> parseDoubleQmark stripped- Nothing -> parseDosRoot text False- - (directories, filename)- | P.null pastRoot = ([], Nothing)- | otherwise = case last pastRoot of- fn | fn == T.pack "." -> (goodDirs pastRoot, Just "")- fn | fn == T.pack ".." -> (goodDirs pastRoot, Just "")- fn -> (goodDirs (init pastRoot), Just (escape fn))- - goodDirs :: [T.Text] -> [Chunk]- goodDirs = map escape . filter (not . T.null)- - (basename, exts) = case filename of- Just fn -> parseFilename fn- Nothing -> (Nothing, [])+ path = FilePath root directories basename exts + -- Windows has various types of absolute paths:+ --+ -- * C:\foo\bar -> DOS-style absolute path+ -- * \\?\C:\foo\bar -> extended-length absolute path+ -- * \\host\share\foo\bar -> UNC path+ -- * \\?\UNC\host\share\foo\bar -> extended-length UNC path+ --+ -- \foo\bar looks like an absolute path, but is actually a path+ -- relative to the current DOS drive.+ --+ -- http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx+ (root, pastRoot) = if T.isPrefixOf (T.pack "\\\\") text+ then case stripUncasedPrefix (T.pack "\\\\?\\UNC\\") text of+ Just stripped -> parseUncRoot stripped True+ Nothing -> case T.stripPrefix (T.pack "\\\\?\\") text of+ Just stripped -> parseDosRoot stripped True+ Nothing -> case T.stripPrefix (T.pack "\\\\") text of+ Just stripped -> parseUncRoot stripped False+ Nothing -> parseDosRoot text False+ else case T.stripPrefix (T.pack "\\??\\") text of+ Just stripped -> parseDoubleQmark stripped+ Nothing -> parseDosRoot text False++ (directories, filename)+ | P.null pastRoot = ([], Nothing)+ | otherwise = case last pastRoot of+ fn | fn == T.pack "." -> (goodDirs pastRoot, Just "")+ fn | fn == T.pack ".." -> (goodDirs pastRoot, Just "")+ fn -> (goodDirs (init pastRoot), Just (escape fn))++ goodDirs :: [T.Text] -> [Chunk]+ goodDirs = map escape . filter (not . T.null)++ (basename, exts) = case filename of+ Just fn -> parseFilename fn+ Nothing -> (Nothing, [])+ stripUncasedPrefix :: T.Text -> T.Text -> Maybe T.Text stripUncasedPrefix prefix text = if T.toCaseFold prefix == T.toCaseFold (T.take (T.length prefix) text)- then Just (T.drop (T.length prefix) text)- else Nothing+ then Just (T.drop (T.length prefix) text)+ else Nothing parseDosRoot :: T.Text -> Bool -> (Maybe Root, [T.Text]) parseDosRoot text extended = parsed where- split = textSplitBy (\c -> c == '/' || c == '\\') text- - head' = head split- tail' = tail split- parsed = if T.null head'- then (Just RootWindowsCurrentVolume, tail')- else if T.any (== ':') head'- then (Just (parseDrive head'), tail')- else (Nothing, split)- - parseDrive c = RootWindowsVolume (toUpper (T.head c)) extended+ split = textSplitBy (\c -> c == '/' || c == '\\') text + head' = head split+ tail' = tail split+ parsed = if T.null head'+ then (Just RootWindowsCurrentVolume, tail')+ else if T.any (== ':') head'+ then (Just (parseDrive head'), tail')+ else (Nothing, split)++ parseDrive c = RootWindowsVolume (toUpper (T.head c)) extended+ parseDoubleQmark :: T.Text -> (Maybe Root, [T.Text]) parseDoubleQmark text = (Just RootWindowsDoubleQMark, components) where- components = textSplitBy (\c -> c == '/' || c == '\\') text+ components = textSplitBy (\c -> c == '/' || c == '\\') text parseUncRoot :: T.Text -> Bool -> (Maybe Root, [T.Text]) parseUncRoot text extended = parsed where- (host, pastHost) = T.break (== '\\') text- (share, pastShare) = T.break (== '\\') (T.drop 1 pastHost)- split = if T.null pastShare- then []- else textSplitBy (== '\\') pastShare- parsed = (Just (RootWindowsUnc (T.unpack host) (T.unpack share) extended), split)+ (host, pastHost) = T.break (== '\\') text+ (share, pastShare) = T.break (== '\\') (T.drop 1 pastHost)+ split = if T.null pastShare+ then []+ else textSplitBy (== '\\') pastShare+ parsed = (Just (RootWindowsUnc (T.unpack host) (T.unpack share) extended), split) winValid :: FilePath -> Bool winValid p = case pathRoot p of- Nothing -> dosValid p- Just RootWindowsCurrentVolume -> dosValid p- Just (RootWindowsVolume v _) -> elem v ['A'..'Z'] && dosValid p- Just (RootWindowsUnc host share _) -> uncValid p host share- -- don't even try to validate \??\ paths- Just RootWindowsDoubleQMark -> True- Just RootPosix -> False+ Nothing -> dosValid p+ Just RootWindowsCurrentVolume -> dosValid p+ Just (RootWindowsVolume v _) -> elem v ['A'..'Z'] && dosValid p+ Just (RootWindowsUnc host share _) -> uncValid p host share+ -- don't even try to validate \??\ paths+ Just RootWindowsDoubleQMark -> True+ Just RootPosix -> False dosValid :: FilePath -> Bool dosValid p = noReserved && validCharacters where- reservedChars = map chr [0..0x1F] ++ "/\\?*:|\"<>"- reservedNames =- [ "AUX", "CLOCK$", "COM1", "COM2", "COM3", "COM4"- , "COM5", "COM6", "COM7", "COM8", "COM9", "CON"- , "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6"- , "LPT7", "LPT8", "LPT9", "NUL", "PRN"- ]- - noExt = p { pathExtensions = [] }- noReserved = flip all (directoryChunks noExt)- $ \fn -> notElem (map toUpper fn) reservedNames- - validCharacters = flip all (directoryChunks p)- $ not . any (`elem` reservedChars)+ reservedChars = map chr [0..0x1F] ++ "/\\?*:|\"<>"+ reservedNames =+ [ "AUX", "CLOCK$", "COM1", "COM2", "COM3", "COM4"+ , "COM5", "COM6", "COM7", "COM8", "COM9", "CON"+ , "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6"+ , "LPT7", "LPT8", "LPT9", "NUL", "PRN"+ ] + noExt = p { pathExtensions = [] }+ noReserved = flip all (directoryChunks noExt)+ $ \fn -> notElem (map toUpper fn) reservedNames++ validCharacters = flip all (directoryChunks p)+ $ not . any (`elem` reservedChars)+ uncValid :: FilePath -> String -> String -> Bool uncValid _ "" _ = False uncValid _ _ "" = False uncValid p host share = ok host && ok share && all ok (dropWhileEnd P.null (directoryChunks p)) where- ok "" = False- ok c = not (any invalidChar c)- invalidChar c = c == '\x00' || c == '\\'+ ok "" = False+ ok c = not (any invalidChar c)+ invalidChar c = c == '\x00' || c == '\\' dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd p = foldr (\x xs -> if p x && P.null xs then [] else x : xs) []
system-filepath.cabal view
@@ -1,20 +1,38 @@+cabal-version: 2.0 name: system-filepath-version: 0.4.14+version: 0.4.14.1 synopsis: High-level, byte-based file and directory path manipulations (deprecated)-description: Please see: https://plus.google.com/+MichaelSnoyman/posts/Ft5hnPqpgEx+description: High-level, byte-based file and directory path manipulations (deprecated). license: MIT license-file: license.txt author: John Millikin <jmillikin@gmail.com>-maintainer: FP Complete <michael@fpcomplete.com>+maintainer: https://github.com/fpco/haskell-filesystem copyright: John Millikin 2010-2012-build-type: Custom-cabal-version: >= 1.8+build-type: Simple category: System stability: experimental homepage: https://github.com/fpco/haskell-filesystem bug-reports: https://github.com/fpco/haskell-filesystem/issues-extra-source-files: README.md ChangeLog.md +extra-doc-files:+ README.md+ ChangeLog.md++tested-with:+ GHC == 9.12.0+ GHC == 9.10.1+ GHC == 9.8.2+ GHC == 9.6.6+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ GHC == 8.0.2+ source-repository head type: git location: https://github.com/fpco/haskell-filesystem.git@@ -24,9 +42,9 @@ hs-source-dirs: lib build-depends:- base >= 4.0 && < 5.0+ base >= 4.0 && < 5 , bytestring >= 0.9- , deepseq >= 1.1 && < 1.5+ , deepseq >= 1.1 && < 1.6 , text >= 0.11.0.6 if !impl(ghc >= 8.0) build-depends:@@ -46,6 +64,8 @@ other-modules: Filesystem.Path.Internal + default-language: Haskell2010+ test-suite filesystem_path_tests type: exitcode-stdio-1.0 main-is: FilesystemPathTests.hs@@ -55,10 +75,12 @@ hs-source-dirs: tests build-depends:- base > 4.0 && < 5.0+ base > 4.0 && < 5 , bytestring- , chell >= 0.4 && < 0.5+ , chell >= 0.4 && < 0.6 , chell-quickcheck >= 0.2 && < 0.3 , QuickCheck , system-filepath , text++ default-language: Haskell2010
tests/FilesystemPathTests.hs view
@@ -23,666 +23,670 @@ tests :: Suite tests = suite "tests" $- -- Basic properties- [ test_Empty- , test_Root- , test_Directory- , test_Parent- , test_Filename- , test_Dirname- , test_Basename- , test_Absolute- , test_Relative- - , test_LeadingDotSpecialCases- - -- Basic operations- , test_Append- , test_CommonPrefix- , test_StripPrefix- , property "stripPrefix" prop_StripPrefix- , test_SplitExtension- , test_Collapse- , test_SplitDirectories- , test_InvalidUtf8InDirectoryComponent- , test_Utf8CharInGhcEscapeArea- - , test_SplitSearchPath- , test_Parsing- , test_EqualsIgnoresPosixEncoding- , test_ShowRules- ] ++ suiteTests suite_EncodeString- ++ suiteTests suite_DecodeString- ++ suiteTests suite_SplitSearchPathString- ++ suiteTests (suite "to-from-bytes"- [ test_Identity "posix" posix posixPaths- , test_Identity "windows" windows windowsPaths- , test_MixedValidityToBytes- ])- ++ suiteTests (suite "to-from-text"- [ test_ToText- , test_FromText- ])- ++ suiteTests (suite "validity"- [ property "posix" (forAll posixPaths (valid posix))- , property "windows" (forAll windowsPaths (valid windows))- , test_UncValidity- ])--test_Empty :: Test-test_Empty = assertions "empty" $ do- $expect $ P.null empty- $expect $ equal (toChar8 empty) ""- $expect $ equal (toString empty) ""--test_Root :: Test-test_Root = assertions "root" $ do- let root x = toChar8 (P.root (fromChar8 x))- - $expect $ equal (root "") ""- $expect $ equal (root "/") "/"- $expect $ equal (root "foo") ""- $expect $ equal (root "/foo") "/"--test_Directory :: Test-test_Directory = assertions "directory" $ do- let directory x = toChar8 (P.directory (fromChar8 x))- - $expect $ equal (directory "") "./"- $expect $ equal (directory "/") "/"- $expect $ equal (directory "/foo/bar") "/foo/"- $expect $ equal (directory "/foo/bar/") "/foo/bar/"- $expect $ equal (directory ".") "./"- $expect $ equal (directory "..") "../"- $expect $ equal (directory "../foo") "../"- $expect $ equal (directory "../foo/") "../foo/"- $expect $ equal (directory "foo") "./"- $expect $ equal (directory "foo/bar") "foo/"--test_Parent :: Test-test_Parent = assertions "parent" $ do- let parent x = toChar8 (P.parent (fromChar8 x))- - $expect $ equal (parent "") "./"- $expect $ equal (parent "/") "/"- $expect $ equal (parent "/foo/bar") "/foo/"- $expect $ equal (parent "/foo/bar/") "/foo/"- $expect $ equal (parent ".") "./"- $expect $ equal (parent "..") "./"- $expect $ equal (parent "../foo/bar") "../foo/"- $expect $ equal (parent "../foo/bar") "../foo/"- $expect $ equal (parent "foo") "./"- $expect $ equal (parent "foo/bar") "./foo/"--test_Filename :: Test-test_Filename = assertions "filename" $ do- let filename x = toChar8 (P.filename (fromChar8 x))- - $expect $ equal (filename "") ""- $expect $ equal (filename "/") ""- $expect $ equal (filename "/foo/") ""- $expect $ equal (filename "/foo/bar") "bar"- $expect $ equal (filename "/foo/bar.txt") "bar.txt"--test_Dirname :: Test-test_Dirname = assertions "dirname" $ do- let dirname x = toChar8 (P.dirname (fromChar8 x))- - $expect $ equal (dirname "") ""- $expect $ equal (dirname "/") ""- $expect $ equal (dirname "foo") ""- $expect $ equal (dirname "foo/bar") "foo"- $expect $ equal (dirname "foo/bar/") "bar"- $expect $ equal (dirname "foo/bar/baz.txt") "bar"- - -- the directory name will be re-parsed to a file name.- let dirnameExts x = P.extensions (P.dirname (fromChar8 x))- $expect $ equal (dirnameExts "foo.d/bar") ["d"]- - -- reparsing preserves good/bad encoding state- $expect $ equal (dirnameExts "foo.\xB1.\xDD\xAA/bar") ["\xB1", "\x76A"]--test_Basename :: Test-test_Basename = assertions "basename" $ do- let basename_posix x = toChar8 (basename (fromChar8 x))- let basename_windows x = toString (basename (fromString x))- - $expect $ equal (basename_posix "/foo/bar") "bar"- $expect $ equal (basename_posix "/foo/bar.txt") "bar"- - $expect $ equal (basename_windows "c:\\foo\\bar") "bar"- $expect $ equal (basename_windows "c:\\foo\\bar.txt") "bar"--test_Absolute :: Test-test_Absolute = assertions "absolute" $ do- $expect $ absolute (fromChar8 "/")- $expect $ absolute (fromChar8 "/foo/bar")- $expect . not $ absolute (fromChar8 "")- $expect . not $ absolute (fromChar8 "foo/bar")- - $expect $ absolute (fromString "c:\\")- $expect $ absolute (fromString "c:\\foo\\bar")- $expect . not $ absolute (fromString "")- $expect . not $ absolute (fromString "foo\\bar")- $expect . not $ absolute (fromString "\\foo\\bar")--test_Relative :: Test-test_Relative = assertions "relative" $ do- $expect . not $ relative (fromChar8 "/")- $expect . not $ relative (fromChar8 "/foo/bar")- $expect $ relative (fromChar8 "")- $expect $ relative (fromChar8 "foo/bar")- - $expect . not $ relative (fromString "c:\\")- $expect . not $ relative (fromString "c:\\foo\\bar")- $expect $ relative (fromString "")- $expect $ relative (fromString "foo\\bar")- $expect . not $ relative (fromString "\\foo\\bar")--test_LeadingDotSpecialCases :: Test-test_LeadingDotSpecialCases = assertions "leading-dot-special-cases" $ do- let components_posix x = let p = fromChar8 x in- (toChar8 (P.directory p), toChar8 (basename p), P.extensions p)- let components_windows x = let p = fromString x in- (toString (P.directory p), toString (basename p), P.extensions p)- - -- The filenames "." and ".." are always considered to be directory- -- elements, because they are links to either the current or parent- -- directories.- --- -- On POSIX, filenames starting with '.' are hidden files and have- -- a basename starting with '.'.- --- -- On Windows there is no history of similar naming patterns. The case- -- could be made that a filename like ".txt.gz" ought to have a- -- basename of "", but different basename behavior in POSIX and Windows- -- would greatly complicate the implementation of 'dirname'.- $expect $ equal (components_posix ".") ("./", "", [])- $expect $ equal (components_posix "..") ("../", "", [])- $expect $ equal (components_posix "/foo/.") ("/foo/./", "", [])- $expect $ equal (components_posix "/foo/..") ("/foo/../", "", [])- $expect $ equal (components_posix "/foo/.foo.txt") ("/foo/", ".foo", ["txt"])- - $expect $ equal (components_windows ".") (".\\", "", [])- $expect $ equal (components_windows "..") ("..\\", "", [])- $expect $ equal (components_windows "\\foo\\.") ("\\foo\\.\\", "", [])- $expect $ equal (components_windows "\\foo\\..") ("\\foo\\..\\", "", [])- $expect $ equal (components_windows "\\foo\\.foo.txt") ("\\foo\\", ".foo", ["txt"])--test_Identity :: String -> Rules a -> Gen FilePath -> Test-test_Identity name r gen = property name $ forAll gen $ \p -> p == decode r (encode r p)--test_MixedValidityToBytes :: Test-test_MixedValidityToBytes = assertions "mixed-validity-to-bytes" $ do- let p = fromChar8- - $expect $ equal (encode posix (p "\xB1.\xDD\xAA")) (B8.pack "\xB1.\xDD\xAA")- $expect $ equal (encode posix (p "\xB1.\xDD\xAA" </> p "foo")) (B8.pack "\xB1.\xDD\xAA/foo")--test_ToText :: Test-test_ToText = assertions "toText" $ do- let p = fromChar8- - $expect $ equal (toText posix (p "")) (Right (T.pack ""))- $expect $ equal (toText posix (p "ascii")) (Right (T.pack "ascii"))- $expect $ equal (toText posix (p "\xF0\x9D\x84\x9E")) (Right (T.pack "\x1D11E"))- $expect $ equal (toText posix (p "\xED\xA0\x80")) (Left (T.pack "\xED\xA0\x80"))- $expect $ equal (toText posix (p "\xF0\x9D\x84\x9E/\xED\xA0\x80")) (Left (T.pack "\x1D11E/\xED\xA0\x80"))- $expect $ equal (toText posix (p "\xED.\xF0\x9D\x84\x9E.\xA0\x80")) (Left (T.pack "\xED.\x1D11E.\xA0\x80"))- $expect $ equal (toText posix (p "\xB1.\xDD\xAA")) (Left (T.pack "\xB1.\x76A"))- $expect $ equal (toText posix (p "\xB1.\xDD\xAA" </> p "foo")) (Left (T.pack "\xB1.\x76A/foo"))--test_FromText :: Test-test_FromText = assertions "fromText" $ do- let pt x = fromText posix (T.pack x)- let p = fromChar8- - $expect $ equal (pt "") (p "")- $expect $ equal (pt "\x1D11E") (p "\xF0\x9D\x84\x9E")- $expect $ equal (pt "\xED\xA0\x80") (p "\xC3\xAD\xC2\xA0\xC2\x80")--test_Append :: Test-test_Append = assertions "append" $ do- let appendP x y = toChar8 (P.append (fromChar8 x) (fromChar8 y))- let appendW x y = toString (P.append (fromString x) (fromString y))- - $expect $ equal (appendP "" "") ""- $expect $ equal (appendP "" "b/") "b/"- - -- Relative to a directory- $expect $ equal (appendP "a/" "") "a/"- $expect $ equal (appendP "a/" "b/") "a/b/"- $expect $ equal (appendP "a/" "b.txt") "a/b.txt"- $expect $ equal (appendP "a.txt" "b.txt") "a.txt/b.txt"- $expect $ equal (appendP "." "a") "./a"- - -- Relative to a file- $expect $ equal (appendP "a" "") "a/"- $expect $ equal (appendP "a" "b/") "a/b/"- $expect $ equal (appendP "a/b" "c") "a/b/c"- - -- Absolute- $expect $ equal (appendP "/a/" "") "/a/"- $expect $ equal (appendP "/a/" "b") "/a/b"- $expect $ equal (appendP "/a/" "b/") "/a/b/"- - -- Second parameter is absolute- $expect $ equal (appendP "/a/" "/") "/"- $expect $ equal (appendP "/a/" "/b") "/b"- $expect $ equal (appendP "/a/" "/b/") "/b/"- - -- Windows: volume handling- $expect $ equal (appendW "c:\\" "") "C:\\"- $expect $ equal (appendW "c:\\foo" "bar\\baz") "C:\\foo\\bar\\baz"- $expect $ equal (appendW "c:\\foo" "d:\\bar") "D:\\bar"- $expect $ equal (appendW "c:\\foo" "\\bar") "C:\\bar"- $expect $ equal (appendW "foo\\bar" "\\baz") "\\baz"--test_CommonPrefix :: Test-test_CommonPrefix = assertions "commonPrefix" $ do- let commonPrefix xs = toChar8 (P.commonPrefix (map (fromChar8) xs))- - $expect $ equal (commonPrefix ["", ""]) ""- $expect $ equal (commonPrefix ["/", ""]) ""- $expect $ equal (commonPrefix ["/", "/"]) "/"- $expect $ equal (commonPrefix ["foo/", "/foo/"]) ""- $expect $ equal (commonPrefix ["/foo", "/foo/"]) "/"- $expect $ equal (commonPrefix ["/foo/", "/foo/"]) "/foo/"- $expect $ equal (commonPrefix ["/foo/bar/baz.txt.gz", "/foo/bar/baz.txt.gz.bar"]) "/foo/bar/baz.txt.gz"--test_StripPrefix :: Test-test_StripPrefix = assertions "stripPrefix" $ do- let stripPrefix x y = fmap (toChar8) (P.stripPrefix (fromChar8 x) (fromChar8 y))- - $expect $ equal (stripPrefix "" "") (Just "")- $expect $ equal (stripPrefix "" "/") (Just "/")- $expect $ equal (stripPrefix "/" "/") (Just "")- $expect $ equal (stripPrefix "/" "/foo") (Just "foo")- $expect $ equal (stripPrefix "/" "/foo/bar") (Just "foo/bar")- $expect $ equal (stripPrefix "/foo/" "/foo/bar") (Just "bar")- $expect $ equal (stripPrefix "/foo/" "/foo/bar/baz") (Just "bar/baz")- $expect $ equal (stripPrefix "/foo/bar" "/foo/bar.txt") (Just ".txt")- $expect $ equal (stripPrefix "/foo/bar.txt" "/foo/bar.txt.gz") (Just ".gz")- - -- Test ignoring non-matching prefixes- $expect $ equal (stripPrefix "/foo" "/foo/bar") Nothing- $expect $ equal (stripPrefix "/foo/bar/baz" "/foo") Nothing- $expect $ equal (stripPrefix "/foo/baz/" "/foo/bar/qux") Nothing- $expect $ equal (stripPrefix "/foo/bar/baz" "/foo/bar/qux") Nothing- $expect $ equal (stripPrefix "/foo/bar/baz" "/foo/bar/qux") Nothing--prop_StripPrefix :: Property-prop_StripPrefix =- forAll posixPaths $ \x ->- forAll posixPaths $ \suffix ->- let prefix = x </> "" in- let full = fromChar8 (toChar8 prefix ++ toChar8 suffix) in- case stripPrefix prefix full of- Nothing -> False- Just stripped -> prefix </> stripped == full--test_SplitExtension :: Test-test_SplitExtension = assertions "splitExtension" $ do- let splitExtension x = (toChar8 base, ext) where- (base, ext) = P.splitExtension (fromChar8 x)- - $expect $ equal (splitExtension "") ("", Nothing)- $expect $ equal (splitExtension "foo") ("foo", Nothing)- $expect $ equal (splitExtension "foo.") ("foo", Just (T.pack ""))- $expect $ equal (splitExtension "foo.a") ("foo", Just (T.pack "a"))- $expect $ equal (splitExtension "foo.a/") ("foo.a/", Nothing)- $expect $ equal (splitExtension "foo.a/bar") ("foo.a/bar", Nothing)- $expect $ equal (splitExtension "foo.a/bar.b") ("foo.a/bar", Just (T.pack "b"))- $expect $ equal (splitExtension "foo.a/bar.b.c") ("foo.a/bar.b", Just (T.pack "c"))--test_Collapse :: Test-test_Collapse = assertions "collapse" $ do- let collapse x = toChar8 (P.collapse (fromChar8 x))- - $expect $ equal (collapse "./") "./"- $expect $ equal (collapse "././") "./"- $expect $ equal (collapse "../") "../"- $expect $ equal (collapse ".././") "../"- $expect $ equal (collapse "./../") "../"- $expect $ equal (collapse "../../") "../../"- $expect $ equal (collapse "parent/foo/baz/../bar") "parent/foo/bar"- $expect $ equal (collapse "parent/foo/baz/../../bar") "parent/bar"- $expect $ equal (collapse "parent/foo/..") "parent/"- $expect $ equal (collapse "/parent/foo/../../../bar") "/bar"- $expect $ equal (collapse "/./parent/foo") "/parent/foo"--test_SplitDirectories :: Test-test_SplitDirectories = assertions "splitDirectories" $ do- let splitDirectories x = P.splitDirectories (fromChar8 x)- fromChar8' = map fromChar8-- $expect $ equal (splitDirectories "") (fromChar8' [])- $expect $ equal (splitDirectories "/") (fromChar8' ["/"])- $expect $ equal (splitDirectories "/a") (fromChar8' ["/", "a"])- $expect $ equal (splitDirectories "/ab/cd") (fromChar8' ["/", "ab/", "cd"])- $expect $ equal (splitDirectories "/ab/cd/") (fromChar8' ["/", "ab/", "cd/"])- $expect $ equal (splitDirectories "ab/cd") (fromChar8' ["ab/", "cd"])- $expect $ equal (splitDirectories "ab/cd/") (fromChar8' ["ab/", "cd/"])- $expect $ equal (splitDirectories "ab/cd.txt") (fromChar8' ["ab/", "cd.txt"])- $expect $ equal (splitDirectories "ab/cd/.txt") (fromChar8' ["ab/", "cd/", ".txt"])- $expect $ equal (splitDirectories "ab/./cd") (fromChar8' ["ab/", ".", "cd"])--test_InvalidUtf8InDirectoryComponent :: Test-test_InvalidUtf8InDirectoryComponent = assertions "invalid-utf8-in-directory-component" $ do- $expect $ equal (toText posix (fromChar8 "/\218\130.\137\141")) (Left (T.pack "/\1666.\137\141"))- $expect $ equal (encode posix (fromChar8 "/\218\130.\137\141")) (B8.pack "/\218\130.\137\141")- - $expect $ equal (toText posix (fromChar8 "/\218\130.\137\141/")) (Left (T.pack "/\1666.\137\141/"))- $expect $ equal (encode posix (fromChar8 "/\218\130.\137\141/")) (B8.pack "/\218\130.\137\141/")- - $expect $ equal (toText posix (fromChar8 "/\218\130.\137\141//baz")) (Left (T.pack "/\1666.\137\141/baz"))- $expect $ equal (encode posix (fromChar8 "/\218\130.\137\141//baz")) (B8.pack "/\218\130.\137\141/baz")--test_Utf8CharInGhcEscapeArea :: Test-test_Utf8CharInGhcEscapeArea = assertions "utf8-char-in-ghc-escape-area" $ do- let chars = "/a/\238\189\178/b"- let path = fromChar8 chars- $expect (equal (toChar8 path) chars)- $expect (equal (toText posix path) (Right (T.pack "/a/\61298/b")))- - let chars = "/a/\xEE\xBC\x80/b"- let path = fromChar8 chars- $expect (equal (toChar8 path) chars)- $expect (equal (toText posix path) (Right (T.pack "/a/\61184/b")))--test_Parsing :: Test-test_Parsing = assertions "parsing" $ do- let p x = toChar8 (fromChar8 x)- let w x = toString (fromString x)- - $expect $ equal (p "") ""- $expect $ equal (p "/") "/"- $expect $ equal (p "/a") "/a"- $expect $ equal (p "/a/") "/a/"- $expect $ equal (p "a") "a"- $expect $ equal (p "a/") "a/"- $expect $ equal (p "a/b") "a/b"- $expect $ equal (p "a//b") "a/b"- $expect $ equal (p "a/./b") "a/./b"- $expect $ equal (p ".") "./"- $expect $ equal (p "./") "./"- $expect $ equal (p "..") "../"- $expect $ equal (p "../") "../"- - $expect $ equal (w "") ""- $expect $ equal (w "c:\\") "C:\\"- $expect $ equal (w "c:\\a") "C:\\a"- $expect $ equal (w "c:\\a\\") "C:\\a\\"- $expect $ equal (w "a") "a"- $expect $ equal (w "a/") "a\\"- $expect $ equal (w "a\\") "a\\"- $expect $ equal (w "a\\b") "a\\b"- $expect $ equal (w "a\\\\b") "a\\b"- $expect $ equal (w "a\\.\\b") "a\\.\\b"- $expect $ equal (w ".") ".\\"- $expect $ equal (w ".\\") ".\\"- $expect $ equal (w "..") "..\\"- $expect $ equal (w "..\\") "..\\"- - -- extended-length- $expect $ equal (w "\\\\?\\C:\\") "\\\\?\\C:\\"- $expect $ equal (w "\\\\?\\C:\\a") "\\\\?\\C:\\a"- - -- UNC- $expect $ equal (w "\\\\server\\share") "\\\\server\\share"- $expect $ equal (w "\\\\server\\share\\") "\\\\server\\share"- $expect $ equal (w "\\\\server\\share\\a") "\\\\server\\share\\a"- $expect $ equal (w "\\\\server\\share\\.") "\\\\server\\share\\."- $expect $ equal (w "\\\\server\\share\\..") "\\\\server\\share\\.."- $expect $ equal (w "\\\\server\\share\\a\\") "\\\\server\\share\\a"- - -- extended-length UNC- $expect $ equal (w "\\\\?\\unc\\server\\share") "\\\\?\\UNC\\server\\share"- $expect $ equal (w "\\\\?\\UNC\\server\\share") "\\\\?\\UNC\\server\\share"- $expect $ equal (w "\\\\?\\UNC\\server\\share\\a") "\\\\?\\UNC\\server\\share\\a"- - -- magical \??\ and \\.\ Windows prefixes- $expect $ equal (w "\\??\\Volume{12345}") "\\??\\Volume{12345}"- $expect $ equal (w "\\\\.\\PhysicalDrive0") "\\\\.\\PhysicalDrive0"--test_UncValidity :: Test-test_UncValidity = assertions "unc-validity" $ do- let invalid rules = not . valid rules- $expect $ invalid windows (fromString "\\\\server")- $expect $ invalid windows (fromString "\\\\server\\")- $expect $ valid windows (fromString "\\\\server\\share")- $expect $ valid windows (fromString "\\\\server\\share\\")- $expect $ valid windows (fromString "\\\\server\\share\\a")- $expect $ valid windows (fromString "\\??\\Volume{12345}")- $expect $ valid windows (fromString "\\\\.\\PhysicalDrive0")--test_SplitSearchPath :: Test-test_SplitSearchPath = assertions "splitSearchPath" $ do- let p x = map toChar8 (splitSearchPath posix (B8.pack x))- let w x = map toString (splitSearchPath windows (T.pack x))- - $expect $ equal (p "a:b:c") ["a", "b", "c"]- $expect $ equal (p "a::b:c") ["a", "./", "b", "c"]- $expect $ equal (w "a;b;c") ["a", "b", "c"]- $expect $ equal (w "a;;b;c") ["a", "b", "c"]--suite_SplitSearchPathString :: Suite-suite_SplitSearchPathString = suite "splitSearchPathString"- [ test_SplitSearchPathString_Posix- , test_SplitSearchPathString_Posix_Ghc702- , test_SplitSearchPathString_Posix_Ghc704- , test_SplitSearchPathString_Darwin- , test_SplitSearchPathString_Darwin_Ghc702- , test_SplitSearchPathString_Win32- ]--test_SplitSearchPathString_Posix :: Test-test_SplitSearchPathString_Posix = assertions "posix" $ do- let split x = map (toText posix) (splitSearchPathString posix x)- $expect $ equal (split "a::\xC2\xA1\xC2\xA2:\xA1\xA2") [Right "a", Right "./", Right "\xA1\xA2", Left "\xA1\xA2"]--test_SplitSearchPathString_Posix_Ghc702 :: Test-test_SplitSearchPathString_Posix_Ghc702 = assertions "posix_ghc702" $ do- let split x = map (toText posix) (splitSearchPathString posix_ghc702 x)- $expect $ equal (split "a::\xA1\xA2:\xEFA1\xEFA2") [Right "a", Right "./", Right "\xA1\xA2", Left "\xA1\xA2"]--test_SplitSearchPathString_Posix_Ghc704 :: Test-test_SplitSearchPathString_Posix_Ghc704 = assertions "posix_ghc704" $ do- let split x = map (toText posix) (splitSearchPathString posix_ghc704 x)- $expect $ equal (split "a::\xA1\xA2:\xDCA1\xDCA2") [Right "a", Right "./", Right "\xA1\xA2", Left "\xA1\xA2"]--test_SplitSearchPathString_Darwin :: Test-test_SplitSearchPathString_Darwin = assertions "darwin" $ do- let split x = map (toText darwin) (splitSearchPathString darwin x)- $expect $ equal (split "a::\xC2\xA1\xC2\xA2") [Right "a", Right "./", Right "\xA1\xA2"]--test_SplitSearchPathString_Darwin_Ghc702 :: Test-test_SplitSearchPathString_Darwin_Ghc702 = assertions "darwin_ghc702" $ do- let split x = map (toText darwin) (splitSearchPathString darwin_ghc702 x)- $expect $ equal (split "a::\xA1\xA2") [Right "a", Right "./", Right "\xA1\xA2"]--test_SplitSearchPathString_Win32 :: Test-test_SplitSearchPathString_Win32 = assertions "win32" $ do- let split x = map (toText windows) (splitSearchPathString windows x)- $expect $ equal (split "a;;\xA1\xA2") [Right "a", Right "\xA1\xA2"]--suite_EncodeString :: Suite-suite_EncodeString = suite "encodeString"- [ test_EncodeString_Posix- , test_EncodeString_Posix_Ghc702- , test_EncodeString_Posix_Ghc704- , test_EncodeString_Win32- ]--test_EncodeString_Posix :: Test-test_EncodeString_Posix = assertions "posix" $ do- let enc = encodeString posix- $expect $ equal (enc (fromChar8 "test")) "test"- $expect $ equal (enc (fromChar8 "test\xC2\xA1\xC2\xA2")) "test\xC2\xA1\xC2\xA2"- $expect $ equal (enc (fromChar8 "test\xA1\xA2")) "test\xA1\xA2"- $expect $ equal (enc (fromChar8 "\xC2\xA1\xC2\xA2/test\xA1\xA2")) "\xC2\xA1\xC2\xA2/test\xA1\xA2"- $expect $ equal (enc (fromText posix "test\xA1\xA2")) "test\xC2\xA1\xC2\xA2"--test_EncodeString_Posix_Ghc702 :: Test-test_EncodeString_Posix_Ghc702 = assertions "posix_ghc702" $ do- let enc = encodeString posix_ghc702- $expect $ equal (enc (fromChar8 "test")) "test"- $expect $ equal (enc (fromChar8 "test\xA1\xA2")) "test\xEFA1\xEFA2"- $expect $ equal (enc (fromChar8 "\xC2\xA1\xC2\xA2/test\xA1\xA2")) "\xA1\xA2/test\xEFA1\xEFA2"- $expect $ equal (enc (fromText posix_ghc702 "test\xA1\xA2")) "test\xA1\xA2"--test_EncodeString_Posix_Ghc704 :: Test-test_EncodeString_Posix_Ghc704 = assertions "posix_ghc704" $ do- let enc = encodeString posix_ghc704- $expect $ equal (enc (fromChar8 "test")) "test"- $expect $ equal (enc (fromChar8 "test\xA1\xA2")) "test\xDCA1\xDCA2"- $expect $ equal (enc (fromChar8 "\xC2\xA1\xC2\xA2/test\xA1\xA2")) "\xA1\xA2/test\xDCA1\xDCA2"- $expect $ equal (enc (fromText posix_ghc704 "test\xA1\xA2")) "test\xA1\xA2"--test_EncodeString_Win32 :: Test-test_EncodeString_Win32 = assertions "windows" $ do- let enc = encodeString windows- $expect $ equal (enc (fromString "test")) "test"- $expect $ equal (enc (fromString "test\xA1\xA2")) "test\xA1\xA2"- $expect $ equal (enc (fromText windows "test\xA1\xA2")) "test\xA1\xA2"--suite_DecodeString :: Suite-suite_DecodeString = suite "decodeString"- [ test_DecodeString_Posix- , test_DecodeString_Posix_Ghc702- , test_DecodeString_Posix_Ghc704- , test_DecodeString_Darwin- , test_DecodeString_Darwin_Ghc702- , test_DecodeString_Win32- ]--test_DecodeString_Posix :: Test-test_DecodeString_Posix = assertions "posix" $ do- let r = posix- let dec = decodeString- $expect $ equal (dec r "test") (fromText r "test")- $expect $ equal (dec r "test\xC2\xA1\xC2\xA2") (fromText r "test\xA1\xA2")- $expect $ equal (dec r "test\xA1\xA2") (fromText r "test\xA1\xA2")--test_DecodeString_Posix_Ghc702 :: Test-test_DecodeString_Posix_Ghc702 = assertions "posix_ghc702" $ do- let r = posix_ghc702- let dec = decodeString- $expect $ equal (dec r "test") (fromText r "test")- $expect $ equal (dec r "test\xC2\xA1\xC2\xA2") (fromText r "test\xC2\xA1\xC2\xA2")- $expect $ equal (dec r "test\xA1\xA2") (fromText r "test\xA1\xA2")- $expect $ equal (dec r "test\xEFA1\xEFA2") (fromChar8 "test\xA1\xA2")- $expect $ equal- (toText r (dec r "test\xEFA1\xEFA2"))- (Left "test\xA1\xA2")--test_DecodeString_Posix_Ghc704 :: Test-test_DecodeString_Posix_Ghc704 = assertions "posix_ghc704" $ do- let r = posix_ghc704- let dec = decodeString- $expect $ equal (dec r "test") (fromText r "test")- $expect $ equal (dec r "test\xC2\xA1\xC2\xA2") (fromText r "test\xC2\xA1\xC2\xA2")- $expect $ equal (dec r "test\xA1\xA2") (fromText r "test\xA1\xA2")- $expect $ equal (dec r "test\xDCA1\xDCA2") (fromChar8 "test\xA1\xA2")- $expect $ equal- (toText r (dec r "test\xDCA1\xDCA2"))- (Left "test\xA1\xA2")--test_DecodeString_Darwin :: Test-test_DecodeString_Darwin = assertions "darwin" $ do- let r = darwin- let dec = decodeString- $expect $ equal (dec r "test\xC2\xA1\xC2\xA2") (fromText r "test\xA1\xA2")--test_DecodeString_Darwin_Ghc702 :: Test-test_DecodeString_Darwin_Ghc702 = assertions "darwin_ghc702" $ do- let r = darwin_ghc702- let dec = decodeString- $expect $ equal (dec r "test\xC2\xA1\xC2\xA2") (fromText r "test\xC2\xA1\xC2\xA2")- $expect $ equal (dec r "test\xA1\xA2") (fromText r "test\xA1\xA2")--test_DecodeString_Win32 :: Test-test_DecodeString_Win32 = assertions "windows" $ do- let r = windows- let dec = decodeString- $expect $ equal (dec r "test") (fromText r "test")- $expect $ equal (dec r "test\xC2\xA1\xC2\xA2") (fromText r "test\xC2\xA1\xC2\xA2")- $expect $ equal (dec r "test\xA1\xA2") (fromText r "test\xA1\xA2")--test_EqualsIgnoresPosixEncoding :: Test-test_EqualsIgnoresPosixEncoding = assertions "equals-ignores-posix-encoding" $ do- $expect $ equal- (fromChar8 "test\xA1\xA2")- (fromText posix "test\xA1\xA2")--test_ShowRules :: Test-test_ShowRules = assertions "show-rules" $ do- $expect $ equal (showsPrec 11 darwin "") "(Rules \"Darwin\")"- $expect $ equal (showsPrec 11 darwin_ghc702 "") "(Rules \"Darwin (GHC 7.2)\")"- $expect $ equal (showsPrec 11 posix "") "(Rules \"POSIX\")"- $expect $ equal (showsPrec 11 posix_ghc702 "") "(Rules \"POSIX (GHC 7.2)\")"- $expect $ equal (showsPrec 11 windows "") "(Rules \"Windows\")"--posixPaths :: Gen FilePath-posixPaths = sized $ fmap merge . genComponents where- merge = fromChar8 . intercalate "/"- validChar c = not $ elem c ['\x00', '/']- component = do- size <- choose (0, 10)- vectorOf size $ arbitrary `suchThat` validChar- genComponents n = do- cs <- vectorOf n component- frequency [(1, return cs), (9, return ([""] ++ cs))]--windowsPaths :: Gen FilePath-windowsPaths = oneof [dosPaths, uncPaths]--dosPaths :: Gen FilePath-dosPaths = sized $ \n -> genComponents n >>= merge where- merge cs = do- root <- genRoot- let path = intercalate "\\" cs- return $ fromString $ root ++ path- - reserved = ['\x00'..'\x1F'] ++ ['/', '\\', '?', '*', ':', '|', '"', '<', '>']- reservedNames =- [ "AUX", "CLOCK$", "COM1", "COM2", "COM3", "COM4"- , "COM5", "COM6", "COM7", "COM8", "COM9", "CON"- , "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6"- , "LPT7", "LPT8", "LPT9", "NUL", "PRN"- ]- validChar c = not (elem c reserved)- validComponent c = not (elem (map toUpper c) reservedNames)- component = do- size <- choose (1, 10)- vectorOf size $ arbitrary `suchThat` validChar- genComponents n = vectorOf n (component `suchThat` validComponent)- - genRoot = do- let upperChar = elements ['A'..'Z']- label <- frequency [(1, return Nothing), (9, fmap Just upperChar)]- return $ case label of- Just c -> [c, ':', '\\']- Nothing -> "\\"--uncPaths :: Gen FilePath-uncPaths = sized $ \n -> genComponents n >>= merge where- merge cs = do- root <- genRoot- let path = intercalate "\\" cs- return $ case cs of- [] -> fromString (root ++ path)- _ -> fromString (root ++ "\\" ++ path)- validChar c = c /= '\x00' && c /= '\\'- component = do- size <- choose (1, 10)- vectorOf size (arbitrary `suchThat` validChar)- genComponents n = vectorOf n component- - genRoot = do- host <- component- share <- component- return ("\\\\" ++ host ++ "\\" ++ share)+ -- Basic properties+ [ test_Empty+ , test_Root+ , test_Directory+ , test_Parent+ , test_Filename+ , test_Dirname+ , test_Basename+ , test_Absolute+ , test_Relative++ , test_LeadingDotSpecialCases++ -- Basic operations+ , test_Append+ , test_CommonPrefix+ , test_StripPrefix+ , property "stripPrefix" prop_StripPrefix+ , test_SplitExtension+ , test_Collapse+ , test_SplitDirectories+ , test_InvalidUtf8InDirectoryComponent+ , test_Utf8CharInGhcEscapeArea++ , test_SplitSearchPath+ , test_Parsing+ , test_EqualsIgnoresPosixEncoding+ , test_ShowRules+ ] ++ suiteTests suite_EncodeString+ ++ suiteTests suite_DecodeString+ ++ suiteTests suite_SplitSearchPathString+ ++ suiteTests (suite "to-from-bytes"+ [ test_Identity "posix" posix posixPaths+ , test_Identity "windows" windows windowsPaths+ , test_MixedValidityToBytes+ ])+ ++ suiteTests (suite "to-from-text"+ [ test_ToText+ , test_FromText+ ])+ ++ suiteTests (suite "validity" $+ -- -- Andreas Abel, 2024-11-13, the following test is broken+ -- -- because the generator produces paths with \NUL characters inside.+ -- property "posix" (forAll posixPaths (valid posix)) :+ property "windows" (forAll windowsPaths (valid windows)) :+ test_UncValidity :+ [])++test_Empty :: Test+test_Empty = assertions "empty" $ do+ $expect $ P.null empty+ $expect $ equal (toChar8 empty) ""+ $expect $ equal (toString empty) ""++test_Root :: Test+test_Root = assertions "root" $ do+ let root x = toChar8 (P.root (fromChar8 x))++ $expect $ equal (root "") ""+ $expect $ equal (root "/") "/"+ $expect $ equal (root "foo") ""+ $expect $ equal (root "/foo") "/"++test_Directory :: Test+test_Directory = assertions "directory" $ do+ let directory x = toChar8 (P.directory (fromChar8 x))++ $expect $ equal (directory "") "./"+ $expect $ equal (directory "/") "/"+ $expect $ equal (directory "/foo/bar") "/foo/"+ $expect $ equal (directory "/foo/bar/") "/foo/bar/"+ $expect $ equal (directory ".") "./"+ $expect $ equal (directory "..") "../"+ $expect $ equal (directory "../foo") "../"+ $expect $ equal (directory "../foo/") "../foo/"+ $expect $ equal (directory "foo") "./"+ $expect $ equal (directory "foo/bar") "foo/"++test_Parent :: Test+test_Parent = assertions "parent" $ do+ let parent x = toChar8 (P.parent (fromChar8 x))++ $expect $ equal (parent "") "./"+ $expect $ equal (parent "/") "/"+ $expect $ equal (parent "/foo/bar") "/foo/"+ $expect $ equal (parent "/foo/bar/") "/foo/"+ $expect $ equal (parent ".") "./"+ $expect $ equal (parent "..") "./"+ $expect $ equal (parent "../foo/bar") "../foo/"+ $expect $ equal (parent "../foo/bar") "../foo/"+ $expect $ equal (parent "foo") "./"+ $expect $ equal (parent "foo/bar") "./foo/"++test_Filename :: Test+test_Filename = assertions "filename" $ do+ let filename x = toChar8 (P.filename (fromChar8 x))++ $expect $ equal (filename "") ""+ $expect $ equal (filename "/") ""+ $expect $ equal (filename "/foo/") ""+ $expect $ equal (filename "/foo/bar") "bar"+ $expect $ equal (filename "/foo/bar.txt") "bar.txt"++test_Dirname :: Test+test_Dirname = assertions "dirname" $ do+ let dirname x = toChar8 (P.dirname (fromChar8 x))++ $expect $ equal (dirname "") ""+ $expect $ equal (dirname "/") ""+ $expect $ equal (dirname "foo") ""+ $expect $ equal (dirname "foo/bar") "foo"+ $expect $ equal (dirname "foo/bar/") "bar"+ $expect $ equal (dirname "foo/bar/baz.txt") "bar"++ -- the directory name will be re-parsed to a file name.+ let dirnameExts x = P.extensions (P.dirname (fromChar8 x))+ $expect $ equal (dirnameExts "foo.d/bar") ["d"]++ -- reparsing preserves good/bad encoding state+ $expect $ equal (dirnameExts "foo.\xB1.\xDD\xAA/bar") ["\xB1", "\x76A"]++test_Basename :: Test+test_Basename = assertions "basename" $ do+ let basename_posix x = toChar8 (basename (fromChar8 x))+ let basename_windows x = toString (basename (fromString x))++ $expect $ equal (basename_posix "/foo/bar") "bar"+ $expect $ equal (basename_posix "/foo/bar.txt") "bar"++ $expect $ equal (basename_windows "c:\\foo\\bar") "bar"+ $expect $ equal (basename_windows "c:\\foo\\bar.txt") "bar"++test_Absolute :: Test+test_Absolute = assertions "absolute" $ do+ $expect $ absolute (fromChar8 "/")+ $expect $ absolute (fromChar8 "/foo/bar")+ $expect . not $ absolute (fromChar8 "")+ $expect . not $ absolute (fromChar8 "foo/bar")++ $expect $ absolute (fromString "c:\\")+ $expect $ absolute (fromString "c:\\foo\\bar")+ $expect . not $ absolute (fromString "")+ $expect . not $ absolute (fromString "foo\\bar")+ $expect . not $ absolute (fromString "\\foo\\bar")++test_Relative :: Test+test_Relative = assertions "relative" $ do+ $expect . not $ relative (fromChar8 "/")+ $expect . not $ relative (fromChar8 "/foo/bar")+ $expect $ relative (fromChar8 "")+ $expect $ relative (fromChar8 "foo/bar")++ $expect . not $ relative (fromString "c:\\")+ $expect . not $ relative (fromString "c:\\foo\\bar")+ $expect $ relative (fromString "")+ $expect $ relative (fromString "foo\\bar")+ $expect . not $ relative (fromString "\\foo\\bar")++test_LeadingDotSpecialCases :: Test+test_LeadingDotSpecialCases = assertions "leading-dot-special-cases" $ do+ let+ components_posix x = let p = fromChar8 x in+ (toChar8 (P.directory p), toChar8 (basename p), P.extensions p)+ components_windows x = let p = fromString x in+ (toString (P.directory p), toString (basename p), P.extensions p)++ -- The filenames "." and ".." are always considered to be directory+ -- elements, because they are links to either the current or parent+ -- directories.+ --+ -- On POSIX, filenames starting with '.' are hidden files and have+ -- a basename starting with '.'.+ --+ -- On Windows there is no history of similar naming patterns. The case+ -- could be made that a filename like ".txt.gz" ought to have a+ -- basename of "", but different basename behavior in POSIX and Windows+ -- would greatly complicate the implementation of 'dirname'.+ $expect $ equal (components_posix ".") ("./", "", [])+ $expect $ equal (components_posix "..") ("../", "", [])+ $expect $ equal (components_posix "/foo/.") ("/foo/./", "", [])+ $expect $ equal (components_posix "/foo/..") ("/foo/../", "", [])+ $expect $ equal (components_posix "/foo/.foo.txt") ("/foo/", ".foo", ["txt"])++ $expect $ equal (components_windows ".") (".\\", "", [])+ $expect $ equal (components_windows "..") ("..\\", "", [])+ $expect $ equal (components_windows "\\foo\\.") ("\\foo\\.\\", "", [])+ $expect $ equal (components_windows "\\foo\\..") ("\\foo\\..\\", "", [])+ $expect $ equal (components_windows "\\foo\\.foo.txt") ("\\foo\\", ".foo", ["txt"])++test_Identity :: String -> Rules a -> Gen FilePath -> Test+test_Identity name r gen = property name $ forAll gen $ \p -> p == decode r (encode r p)++test_MixedValidityToBytes :: Test+test_MixedValidityToBytes = assertions "mixed-validity-to-bytes" $ do+ let p = fromChar8++ $expect $ equal (encode posix (p "\xB1.\xDD\xAA")) (B8.pack "\xB1.\xDD\xAA")+ $expect $ equal (encode posix (p "\xB1.\xDD\xAA" </> p "foo")) (B8.pack "\xB1.\xDD\xAA/foo")++test_ToText :: Test+test_ToText = assertions "toText" $ do+ let p = fromChar8++ $expect $ equal (toText posix (p "")) (Right (T.pack ""))+ $expect $ equal (toText posix (p "ascii")) (Right (T.pack "ascii"))+ $expect $ equal (toText posix (p "\xF0\x9D\x84\x9E")) (Right (T.pack "\x1D11E"))+ $expect $ equal (toText posix (p "\xED\xA0\x80")) (Left (T.pack "\xED\xA0\x80"))+ $expect $ equal (toText posix (p "\xF0\x9D\x84\x9E/\xED\xA0\x80")) (Left (T.pack "\x1D11E/\xED\xA0\x80"))+ $expect $ equal (toText posix (p "\xED.\xF0\x9D\x84\x9E.\xA0\x80")) (Left (T.pack "\xED.\x1D11E.\xA0\x80"))+ $expect $ equal (toText posix (p "\xB1.\xDD\xAA")) (Left (T.pack "\xB1.\x76A"))+ $expect $ equal (toText posix (p "\xB1.\xDD\xAA" </> p "foo")) (Left (T.pack "\xB1.\x76A/foo"))++test_FromText :: Test+test_FromText = assertions "fromText" $ do+ let pt x = fromText posix (T.pack x)+ let p = fromChar8++ $expect $ equal (pt "") (p "")+ $expect $ equal (pt "\x1D11E") (p "\xF0\x9D\x84\x9E")+ $expect $ equal (pt "\xED\xA0\x80") (p "\xC3\xAD\xC2\xA0\xC2\x80")++test_Append :: Test+test_Append = assertions "append" $ do+ let appendP x y = toChar8 (P.append (fromChar8 x) (fromChar8 y))+ let appendW x y = toString (P.append (fromString x) (fromString y))++ $expect $ equal (appendP "" "") ""+ $expect $ equal (appendP "" "b/") "b/"++ -- Relative to a directory+ $expect $ equal (appendP "a/" "") "a/"+ $expect $ equal (appendP "a/" "b/") "a/b/"+ $expect $ equal (appendP "a/" "b.txt") "a/b.txt"+ $expect $ equal (appendP "a.txt" "b.txt") "a.txt/b.txt"+ $expect $ equal (appendP "." "a") "./a"++ -- Relative to a file+ $expect $ equal (appendP "a" "") "a/"+ $expect $ equal (appendP "a" "b/") "a/b/"+ $expect $ equal (appendP "a/b" "c") "a/b/c"++ -- Absolute+ $expect $ equal (appendP "/a/" "") "/a/"+ $expect $ equal (appendP "/a/" "b") "/a/b"+ $expect $ equal (appendP "/a/" "b/") "/a/b/"++ -- Second parameter is absolute+ $expect $ equal (appendP "/a/" "/") "/"+ $expect $ equal (appendP "/a/" "/b") "/b"+ $expect $ equal (appendP "/a/" "/b/") "/b/"++ -- Windows: volume handling+ $expect $ equal (appendW "c:\\" "") "C:\\"+ $expect $ equal (appendW "c:\\foo" "bar\\baz") "C:\\foo\\bar\\baz"+ $expect $ equal (appendW "c:\\foo" "d:\\bar") "D:\\bar"+ $expect $ equal (appendW "c:\\foo" "\\bar") "C:\\bar"+ $expect $ equal (appendW "foo\\bar" "\\baz") "\\baz"++test_CommonPrefix :: Test+test_CommonPrefix = assertions "commonPrefix" $ do+ let commonPrefix xs = toChar8 (P.commonPrefix (map (fromChar8) xs))++ $expect $ equal (commonPrefix ["", ""]) ""+ $expect $ equal (commonPrefix ["/", ""]) ""+ $expect $ equal (commonPrefix ["/", "/"]) "/"+ $expect $ equal (commonPrefix ["foo/", "/foo/"]) ""+ $expect $ equal (commonPrefix ["/foo", "/foo/"]) "/"+ $expect $ equal (commonPrefix ["/foo/", "/foo/"]) "/foo/"+ $expect $ equal (commonPrefix ["/foo/bar/baz.txt.gz", "/foo/bar/baz.txt.gz.bar"]) "/foo/bar/baz.txt.gz"++test_StripPrefix :: Test+test_StripPrefix = assertions "stripPrefix" $ do+ let stripPrefix x y = fmap (toChar8) (P.stripPrefix (fromChar8 x) (fromChar8 y))++ $expect $ equal (stripPrefix "" "") (Just "")+ $expect $ equal (stripPrefix "" "/") (Just "/")+ $expect $ equal (stripPrefix "/" "/") (Just "")+ $expect $ equal (stripPrefix "/" "/foo") (Just "foo")+ $expect $ equal (stripPrefix "/" "/foo/bar") (Just "foo/bar")+ $expect $ equal (stripPrefix "/foo/" "/foo/bar") (Just "bar")+ $expect $ equal (stripPrefix "/foo/" "/foo/bar/baz") (Just "bar/baz")+ $expect $ equal (stripPrefix "/foo/bar" "/foo/bar.txt") (Just ".txt")+ $expect $ equal (stripPrefix "/foo/bar.txt" "/foo/bar.txt.gz") (Just ".gz")++ -- Test ignoring non-matching prefixes+ $expect $ equal (stripPrefix "/foo" "/foo/bar") Nothing+ $expect $ equal (stripPrefix "/foo/bar/baz" "/foo") Nothing+ $expect $ equal (stripPrefix "/foo/baz/" "/foo/bar/qux") Nothing+ $expect $ equal (stripPrefix "/foo/bar/baz" "/foo/bar/qux") Nothing+ $expect $ equal (stripPrefix "/foo/bar/baz" "/foo/bar/qux") Nothing++prop_StripPrefix :: Property+prop_StripPrefix =+ forAll posixPaths $ \x ->+ forAll posixPaths $ \suffix ->+ let prefix = x </> "" in+ let full = fromChar8 (toChar8 prefix ++ toChar8 suffix) in+ case stripPrefix prefix full of+ Nothing -> False+ Just stripped -> prefix </> stripped == full++test_SplitExtension :: Test+test_SplitExtension = assertions "splitExtension" $ do+ let+ splitExtension x = (toChar8 base, ext) where+ (base, ext) = P.splitExtension (fromChar8 x)++ $expect $ equal (splitExtension "") ("", Nothing)+ $expect $ equal (splitExtension "foo") ("foo", Nothing)+ $expect $ equal (splitExtension "foo.") ("foo", Just (T.pack ""))+ $expect $ equal (splitExtension "foo.a") ("foo", Just (T.pack "a"))+ $expect $ equal (splitExtension "foo.a/") ("foo.a/", Nothing)+ $expect $ equal (splitExtension "foo.a/bar") ("foo.a/bar", Nothing)+ $expect $ equal (splitExtension "foo.a/bar.b") ("foo.a/bar", Just (T.pack "b"))+ $expect $ equal (splitExtension "foo.a/bar.b.c") ("foo.a/bar.b", Just (T.pack "c"))++test_Collapse :: Test+test_Collapse = assertions "collapse" $ do+ let collapse x = toChar8 (P.collapse (fromChar8 x))++ $expect $ equal (collapse "./") "./"+ $expect $ equal (collapse "././") "./"+ $expect $ equal (collapse "../") "../"+ $expect $ equal (collapse ".././") "../"+ $expect $ equal (collapse "./../") "../"+ $expect $ equal (collapse "../../") "../../"+ $expect $ equal (collapse "parent/foo/baz/../bar") "parent/foo/bar"+ $expect $ equal (collapse "parent/foo/baz/../../bar") "parent/bar"+ $expect $ equal (collapse "parent/foo/..") "parent/"+ $expect $ equal (collapse "/parent/foo/../../../bar") "/bar"+ $expect $ equal (collapse "/./parent/foo") "/parent/foo"++test_SplitDirectories :: Test+test_SplitDirectories = assertions "splitDirectories" $ do+ let splitDirectories x = P.splitDirectories (fromChar8 x)+ fromChar8' = map fromChar8++ $expect $ equal (splitDirectories "") (fromChar8' [])+ $expect $ equal (splitDirectories "/") (fromChar8' ["/"])+ $expect $ equal (splitDirectories "/a") (fromChar8' ["/", "a"])+ $expect $ equal (splitDirectories "/ab/cd") (fromChar8' ["/", "ab/", "cd"])+ $expect $ equal (splitDirectories "/ab/cd/") (fromChar8' ["/", "ab/", "cd/"])+ $expect $ equal (splitDirectories "ab/cd") (fromChar8' ["ab/", "cd"])+ $expect $ equal (splitDirectories "ab/cd/") (fromChar8' ["ab/", "cd/"])+ $expect $ equal (splitDirectories "ab/cd.txt") (fromChar8' ["ab/", "cd.txt"])+ $expect $ equal (splitDirectories "ab/cd/.txt") (fromChar8' ["ab/", "cd/", ".txt"])+ $expect $ equal (splitDirectories "ab/./cd") (fromChar8' ["ab/", ".", "cd"])++test_InvalidUtf8InDirectoryComponent :: Test+test_InvalidUtf8InDirectoryComponent = assertions "invalid-utf8-in-directory-component" $ do+ $expect $ equal (toText posix (fromChar8 "/\218\130.\137\141")) (Left (T.pack "/\1666.\137\141"))+ $expect $ equal (encode posix (fromChar8 "/\218\130.\137\141")) (B8.pack "/\218\130.\137\141")++ $expect $ equal (toText posix (fromChar8 "/\218\130.\137\141/")) (Left (T.pack "/\1666.\137\141/"))+ $expect $ equal (encode posix (fromChar8 "/\218\130.\137\141/")) (B8.pack "/\218\130.\137\141/")++ $expect $ equal (toText posix (fromChar8 "/\218\130.\137\141//baz")) (Left (T.pack "/\1666.\137\141/baz"))+ $expect $ equal (encode posix (fromChar8 "/\218\130.\137\141//baz")) (B8.pack "/\218\130.\137\141/baz")++test_Utf8CharInGhcEscapeArea :: Test+test_Utf8CharInGhcEscapeArea = assertions "utf8-char-in-ghc-escape-area" $ do+ let chars = "/a/\238\189\178/b"+ let path = fromChar8 chars+ $expect (equal (toChar8 path) chars)+ $expect (equal (toText posix path) (Right (T.pack "/a/\61298/b")))++ let chars = "/a/\xEE\xBC\x80/b"+ let path = fromChar8 chars+ $expect (equal (toChar8 path) chars)+ $expect (equal (toText posix path) (Right (T.pack "/a/\61184/b")))++test_Parsing :: Test+test_Parsing = assertions "parsing" $ do+ let p x = toChar8 (fromChar8 x)+ let w x = toString (fromString x)++ $expect $ equal (p "") ""+ $expect $ equal (p "/") "/"+ $expect $ equal (p "/a") "/a"+ $expect $ equal (p "/a/") "/a/"+ $expect $ equal (p "a") "a"+ $expect $ equal (p "a/") "a/"+ $expect $ equal (p "a/b") "a/b"+ $expect $ equal (p "a//b") "a/b"+ $expect $ equal (p "a/./b") "a/./b"+ $expect $ equal (p ".") "./"+ $expect $ equal (p "./") "./"+ $expect $ equal (p "..") "../"+ $expect $ equal (p "../") "../"++ $expect $ equal (w "") ""+ $expect $ equal (w "c:\\") "C:\\"+ $expect $ equal (w "c:\\a") "C:\\a"+ $expect $ equal (w "c:\\a\\") "C:\\a\\"+ $expect $ equal (w "a") "a"+ $expect $ equal (w "a/") "a\\"+ $expect $ equal (w "a\\") "a\\"+ $expect $ equal (w "a\\b") "a\\b"+ $expect $ equal (w "a\\\\b") "a\\b"+ $expect $ equal (w "a\\.\\b") "a\\.\\b"+ $expect $ equal (w ".") ".\\"+ $expect $ equal (w ".\\") ".\\"+ $expect $ equal (w "..") "..\\"+ $expect $ equal (w "..\\") "..\\"++ -- extended-length+ $expect $ equal (w "\\\\?\\C:\\") "\\\\?\\C:\\"+ $expect $ equal (w "\\\\?\\C:\\a") "\\\\?\\C:\\a"++ -- UNC+ $expect $ equal (w "\\\\server\\share") "\\\\server\\share"+ $expect $ equal (w "\\\\server\\share\\") "\\\\server\\share"+ $expect $ equal (w "\\\\server\\share\\a") "\\\\server\\share\\a"+ $expect $ equal (w "\\\\server\\share\\.") "\\\\server\\share\\."+ $expect $ equal (w "\\\\server\\share\\..") "\\\\server\\share\\.."+ $expect $ equal (w "\\\\server\\share\\a\\") "\\\\server\\share\\a"++ -- extended-length UNC+ $expect $ equal (w "\\\\?\\unc\\server\\share") "\\\\?\\UNC\\server\\share"+ $expect $ equal (w "\\\\?\\UNC\\server\\share") "\\\\?\\UNC\\server\\share"+ $expect $ equal (w "\\\\?\\UNC\\server\\share\\a") "\\\\?\\UNC\\server\\share\\a"++ -- magical \??\ and \\.\ Windows prefixes+ $expect $ equal (w "\\??\\Volume{12345}") "\\??\\Volume{12345}"+ $expect $ equal (w "\\\\.\\PhysicalDrive0") "\\\\.\\PhysicalDrive0"++test_UncValidity :: Test+test_UncValidity = assertions "unc-validity" $ do+ let invalid rules = not . valid rules+ $expect $ invalid windows (fromString "\\\\server")+ $expect $ invalid windows (fromString "\\\\server\\")+ $expect $ valid windows (fromString "\\\\server\\share")+ $expect $ valid windows (fromString "\\\\server\\share\\")+ $expect $ valid windows (fromString "\\\\server\\share\\a")+ $expect $ valid windows (fromString "\\??\\Volume{12345}")+ $expect $ valid windows (fromString "\\\\.\\PhysicalDrive0")++test_SplitSearchPath :: Test+test_SplitSearchPath = assertions "splitSearchPath" $ do+ let p x = map toChar8 (splitSearchPath posix (B8.pack x))+ let w x = map toString (splitSearchPath windows (T.pack x))++ $expect $ equal (p "a:b:c") ["a", "b", "c"]+ $expect $ equal (p "a::b:c") ["a", "./", "b", "c"]+ $expect $ equal (w "a;b;c") ["a", "b", "c"]+ $expect $ equal (w "a;;b;c") ["a", "b", "c"]++suite_SplitSearchPathString :: Suite+suite_SplitSearchPathString = suite "splitSearchPathString"+ [ test_SplitSearchPathString_Posix+ , test_SplitSearchPathString_Posix_Ghc702+ , test_SplitSearchPathString_Posix_Ghc704+ , test_SplitSearchPathString_Darwin+ , test_SplitSearchPathString_Darwin_Ghc702+ , test_SplitSearchPathString_Win32+ ]++test_SplitSearchPathString_Posix :: Test+test_SplitSearchPathString_Posix = assertions "posix" $ do+ let split x = map (toText posix) (splitSearchPathString posix x)+ $expect $ equal (split "a::\xC2\xA1\xC2\xA2:\xA1\xA2") [Right "a", Right "./", Right "\xA1\xA2", Left "\xA1\xA2"]++test_SplitSearchPathString_Posix_Ghc702 :: Test+test_SplitSearchPathString_Posix_Ghc702 = assertions "posix_ghc702" $ do+ let split x = map (toText posix) (splitSearchPathString posix_ghc702 x)+ $expect $ equal (split "a::\xA1\xA2:\xEFA1\xEFA2") [Right "a", Right "./", Right "\xA1\xA2", Left "\xA1\xA2"]++test_SplitSearchPathString_Posix_Ghc704 :: Test+test_SplitSearchPathString_Posix_Ghc704 = assertions "posix_ghc704" $ do+ let split x = map (toText posix) (splitSearchPathString posix_ghc704 x)+ $expect $ equal (split "a::\xA1\xA2:\xDCA1\xDCA2") [Right "a", Right "./", Right "\xA1\xA2", Left "\xA1\xA2"]++test_SplitSearchPathString_Darwin :: Test+test_SplitSearchPathString_Darwin = assertions "darwin" $ do+ let split x = map (toText darwin) (splitSearchPathString darwin x)+ $expect $ equal (split "a::\xC2\xA1\xC2\xA2") [Right "a", Right "./", Right "\xA1\xA2"]++test_SplitSearchPathString_Darwin_Ghc702 :: Test+test_SplitSearchPathString_Darwin_Ghc702 = assertions "darwin_ghc702" $ do+ let split x = map (toText darwin) (splitSearchPathString darwin_ghc702 x)+ $expect $ equal (split "a::\xA1\xA2") [Right "a", Right "./", Right "\xA1\xA2"]++test_SplitSearchPathString_Win32 :: Test+test_SplitSearchPathString_Win32 = assertions "win32" $ do+ let split x = map (toText windows) (splitSearchPathString windows x)+ $expect $ equal (split "a;;\xA1\xA2") [Right "a", Right "\xA1\xA2"]++suite_EncodeString :: Suite+suite_EncodeString = suite "encodeString"+ [ test_EncodeString_Posix+ , test_EncodeString_Posix_Ghc702+ , test_EncodeString_Posix_Ghc704+ , test_EncodeString_Win32+ ]++test_EncodeString_Posix :: Test+test_EncodeString_Posix = assertions "posix" $ do+ let enc = encodeString posix+ $expect $ equal (enc (fromChar8 "test")) "test"+ $expect $ equal (enc (fromChar8 "test\xC2\xA1\xC2\xA2")) "test\xC2\xA1\xC2\xA2"+ $expect $ equal (enc (fromChar8 "test\xA1\xA2")) "test\xA1\xA2"+ $expect $ equal (enc (fromChar8 "\xC2\xA1\xC2\xA2/test\xA1\xA2")) "\xC2\xA1\xC2\xA2/test\xA1\xA2"+ $expect $ equal (enc (fromText posix "test\xA1\xA2")) "test\xC2\xA1\xC2\xA2"++test_EncodeString_Posix_Ghc702 :: Test+test_EncodeString_Posix_Ghc702 = assertions "posix_ghc702" $ do+ let enc = encodeString posix_ghc702+ $expect $ equal (enc (fromChar8 "test")) "test"+ $expect $ equal (enc (fromChar8 "test\xA1\xA2")) "test\xEFA1\xEFA2"+ $expect $ equal (enc (fromChar8 "\xC2\xA1\xC2\xA2/test\xA1\xA2")) "\xA1\xA2/test\xEFA1\xEFA2"+ $expect $ equal (enc (fromText posix_ghc702 "test\xA1\xA2")) "test\xA1\xA2"++test_EncodeString_Posix_Ghc704 :: Test+test_EncodeString_Posix_Ghc704 = assertions "posix_ghc704" $ do+ let enc = encodeString posix_ghc704+ $expect $ equal (enc (fromChar8 "test")) "test"+ $expect $ equal (enc (fromChar8 "test\xA1\xA2")) "test\xDCA1\xDCA2"+ $expect $ equal (enc (fromChar8 "\xC2\xA1\xC2\xA2/test\xA1\xA2")) "\xA1\xA2/test\xDCA1\xDCA2"+ $expect $ equal (enc (fromText posix_ghc704 "test\xA1\xA2")) "test\xA1\xA2"++test_EncodeString_Win32 :: Test+test_EncodeString_Win32 = assertions "windows" $ do+ let enc = encodeString windows+ $expect $ equal (enc (fromString "test")) "test"+ $expect $ equal (enc (fromString "test\xA1\xA2")) "test\xA1\xA2"+ $expect $ equal (enc (fromText windows "test\xA1\xA2")) "test\xA1\xA2"++suite_DecodeString :: Suite+suite_DecodeString = suite "decodeString"+ [ test_DecodeString_Posix+ , test_DecodeString_Posix_Ghc702+ , test_DecodeString_Posix_Ghc704+ , test_DecodeString_Darwin+ , test_DecodeString_Darwin_Ghc702+ , test_DecodeString_Win32+ ]++test_DecodeString_Posix :: Test+test_DecodeString_Posix = assertions "posix" $ do+ let r = posix+ let dec = decodeString+ $expect $ equal (dec r "test") (fromText r "test")+ $expect $ equal (dec r "test\xC2\xA1\xC2\xA2") (fromText r "test\xA1\xA2")+ $expect $ equal (dec r "test\xA1\xA2") (fromText r "test\xA1\xA2")++test_DecodeString_Posix_Ghc702 :: Test+test_DecodeString_Posix_Ghc702 = assertions "posix_ghc702" $ do+ let r = posix_ghc702+ let dec = decodeString+ $expect $ equal (dec r "test") (fromText r "test")+ $expect $ equal (dec r "test\xC2\xA1\xC2\xA2") (fromText r "test\xC2\xA1\xC2\xA2")+ $expect $ equal (dec r "test\xA1\xA2") (fromText r "test\xA1\xA2")+ $expect $ equal (dec r "test\xEFA1\xEFA2") (fromChar8 "test\xA1\xA2")+ $expect $ equal+ (toText r (dec r "test\xEFA1\xEFA2"))+ (Left "test\xA1\xA2")++test_DecodeString_Posix_Ghc704 :: Test+test_DecodeString_Posix_Ghc704 = assertions "posix_ghc704" $ do+ let r = posix_ghc704+ let dec = decodeString+ $expect $ equal (dec r "test") (fromText r "test")+ $expect $ equal (dec r "test\xC2\xA1\xC2\xA2") (fromText r "test\xC2\xA1\xC2\xA2")+ $expect $ equal (dec r "test\xA1\xA2") (fromText r "test\xA1\xA2")+ $expect $ equal (dec r "test\xDCA1\xDCA2") (fromChar8 "test\xA1\xA2")+ $expect $ equal+ (toText r (dec r "test\xDCA1\xDCA2"))+ (Left "test\xA1\xA2")++test_DecodeString_Darwin :: Test+test_DecodeString_Darwin = assertions "darwin" $ do+ let r = darwin+ let dec = decodeString+ $expect $ equal (dec r "test\xC2\xA1\xC2\xA2") (fromText r "test\xA1\xA2")++test_DecodeString_Darwin_Ghc702 :: Test+test_DecodeString_Darwin_Ghc702 = assertions "darwin_ghc702" $ do+ let r = darwin_ghc702+ let dec = decodeString+ $expect $ equal (dec r "test\xC2\xA1\xC2\xA2") (fromText r "test\xC2\xA1\xC2\xA2")+ $expect $ equal (dec r "test\xA1\xA2") (fromText r "test\xA1\xA2")++test_DecodeString_Win32 :: Test+test_DecodeString_Win32 = assertions "windows" $ do+ let r = windows+ let dec = decodeString+ $expect $ equal (dec r "test") (fromText r "test")+ $expect $ equal (dec r "test\xC2\xA1\xC2\xA2") (fromText r "test\xC2\xA1\xC2\xA2")+ $expect $ equal (dec r "test\xA1\xA2") (fromText r "test\xA1\xA2")++test_EqualsIgnoresPosixEncoding :: Test+test_EqualsIgnoresPosixEncoding = assertions "equals-ignores-posix-encoding" $ do+ $expect $ equal+ (fromChar8 "test\xA1\xA2")+ (fromText posix "test\xA1\xA2")++test_ShowRules :: Test+test_ShowRules = assertions "show-rules" $ do+ $expect $ equal (showsPrec 11 darwin "") "(Rules \"Darwin\")"+ $expect $ equal (showsPrec 11 darwin_ghc702 "") "(Rules \"Darwin (GHC 7.2)\")"+ $expect $ equal (showsPrec 11 posix "") "(Rules \"POSIX\")"+ $expect $ equal (showsPrec 11 posix_ghc702 "") "(Rules \"POSIX (GHC 7.2)\")"+ $expect $ equal (showsPrec 11 windows "") "(Rules \"Windows\")"++posixPaths :: Gen FilePath+posixPaths = sized $ fmap merge . genComponents where+ merge = fromChar8 . intercalate "/"+ validChar c = not $ elem c ['\x00', '/']+ component = do+ size <- choose (0, 10)+ vectorOf size $ arbitrary `suchThat` validChar+ genComponents n = do+ cs <- vectorOf n component+ frequency [(1, return cs), (9, return ([""] ++ cs))]++windowsPaths :: Gen FilePath+windowsPaths = oneof [dosPaths, uncPaths]++dosPaths :: Gen FilePath+dosPaths = sized $ \n -> genComponents n >>= merge where+ merge cs = do+ root <- genRoot+ let path = intercalate "\\" cs+ return $ fromString $ root ++ path++ reserved = ['\x00'..'\x1F'] ++ ['/', '\\', '?', '*', ':', '|', '"', '<', '>']+ reservedNames =+ [ "AUX", "CLOCK$", "COM1", "COM2", "COM3", "COM4"+ , "COM5", "COM6", "COM7", "COM8", "COM9", "CON"+ , "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6"+ , "LPT7", "LPT8", "LPT9", "NUL", "PRN"+ ]+ validChar c = not (elem c reserved)+ validComponent c = not (elem (map toUpper c) reservedNames)+ component = do+ size <- choose (1, 10)+ vectorOf size $ arbitrary `suchThat` validChar+ genComponents n = vectorOf n (component `suchThat` validComponent)++ genRoot = do+ let upperChar = elements ['A'..'Z']+ label <- frequency [(1, return Nothing), (9, fmap Just upperChar)]+ return $ case label of+ Just c -> [c, ':', '\\']+ Nothing -> "\\"++uncPaths :: Gen FilePath+uncPaths = sized $ \n -> genComponents n >>= merge where+ merge cs = do+ root <- genRoot+ let path = intercalate "\\" cs+ return $ case cs of+ [] -> fromString (root ++ path)+ _ -> fromString (root ++ "\\" ++ path)+ validChar c = c /= '\x00' && c /= '\\'+ component = do+ size <- choose (1, 10)+ vectorOf size (arbitrary `suchThat` validChar)+ genComponents n = vectorOf n component++ genRoot = do+ host <- component+ share <- component+ return ("\\\\" ++ host ++ "\\" ++ share) toChar8 :: FilePath -> String toChar8 = B8.unpack . encode posix