diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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`, diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -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) - }) diff --git a/lib/Filesystem/Path.hs b/lib/Filesystem/Path.hs --- a/lib/Filesystem/Path.hs +++ b/lib/Filesystem/Path.hs @@ -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 diff --git a/lib/Filesystem/Path/CurrentOS.hs b/lib/Filesystem/Path/CurrentOS.hs --- a/lib/Filesystem/Path/CurrentOS.hs +++ b/lib/Filesystem/Path/CurrentOS.hs @@ -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. -- diff --git a/lib/Filesystem/Path/Internal.hs b/lib/Filesystem/Path/Internal.hs --- a/lib/Filesystem/Path/Internal.hs +++ b/lib/Filesystem/Path/Internal.hs @@ -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 diff --git a/lib/Filesystem/Path/Rules.hs b/lib/Filesystem/Path/Rules.hs --- a/lib/Filesystem/Path/Rules.hs +++ b/lib/Filesystem/Path/Rules.hs @@ -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) [] diff --git a/system-filepath.cabal b/system-filepath.cabal --- a/system-filepath.cabal +++ b/system-filepath.cabal @@ -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 -maintainer: FP Complete +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 diff --git a/tests/FilesystemPathTests.hs b/tests/FilesystemPathTests.hs --- a/tests/FilesystemPathTests.hs +++ b/tests/FilesystemPathTests.hs @@ -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