diff --git a/lib/Filesystem/Path.hs b/lib/Filesystem/Path.hs --- a/lib/Filesystem/Path.hs +++ b/lib/Filesystem/Path.hs @@ -180,7 +180,7 @@ directories = xDirectories ++ pathDirectories y xDirectories = (pathDirectories x ++) $ if null (filename x) then [] - else [filenameText x] + else [filenameChunk x] -- | An alias for 'append'. () :: FilePath -> FilePath -> FilePath @@ -284,6 +284,7 @@ extensions :: FilePath -> [T.Text] extensions = map unescape' . pathExtensions + -- | Get whether a 'FilePath'’s last extension is the predicate. hasExtension :: FilePath -> T.Text -> Bool hasExtension p e = extension p == Just e @@ -295,7 +296,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 ++ exts + newExtensions = pathExtensions p ++ map escape exts -- | An alias for 'addExtension'. (<.>) :: FilePath -> T.Text -> FilePath 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 @@ -57,7 +57,9 @@ currentOS = R.darwin #endif #else -#if __GLASGOW_HASKELL__ >= 702 +#if __GLASGOW_HASKELL__ >= 704 +currentOS = R.posix_ghc704 +#elif __GLASGOW_HASKELL__ >= 702 currentOS = R.posix_ghc702 #else currentOS = R.posix 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 @@ -31,9 +31,10 @@ -- File Paths ------------------------------------------------------------------------------- -type Directory = T.Text -type Basename = T.Text -type Extension = T.Text +type Chunk = String +type Directory = Chunk +type Basename = Chunk +type Extension = Chunk data Root = RootPosix @@ -71,18 +72,18 @@ empty :: FilePath empty = FilePath Nothing [] Nothing [] -dot :: T.Text -dot = T.pack "." +dot :: Chunk +dot = "." -dots :: T.Text -dots = T.pack ".." +dots :: Chunk +dots = ".." -filenameText :: FilePath -> T.Text -filenameText p = T.concat (name:exts) where - name = maybe T.empty id (pathBasename p) +filenameChunk :: FilePath -> Chunk +filenameChunk p = concat (name:exts) where + name = maybe "" id (pathBasename p) exts = case pathExtensions p of [] -> [] - exts' -> intersperse dot (T.empty:exts') + exts' -> intersperse dot ("":exts') ------------------------------------------------------------------------------- -- Rules @@ -165,6 +166,33 @@ 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) + +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) + +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 + textSplitBy :: (Char -> Bool) -> T.Text -> [T.Text] #if MIN_VERSION_text(0,11,0) textSplitBy = T.split @@ -172,34 +200,11 @@ textSplitBy = T.splitBy #endif -unescape :: T.Text -> (T.Text, Bool) -unescape t = if anyEscaped then (impl, False) else (t, True) where - anyEscaped = T.any (== '\xEF00') t - impl = T.pack (reverse (snd folded)) - folded = T.foldl' step (False, []) t - step (prevEsc, acc) c = if prevEsc - then (False, c:acc) - else if c == '\xEF00' - then (True, acc) - else (False, c:acc) - -unescape' :: T.Text -> T.Text -unescape' = fst . unescape - -unescapeBytes' :: T.Text -> B8.ByteString -unescapeBytes' t = B8.concat (reverse (snd folded)) where - folded = T.foldl' step (False, []) t - step (prevEsc, acc) c = if prevEsc - then (False, B8.singleton (chr (ord c)) : acc) - else if c == '\xEF00' - then (True, acc) - else (False, TE.encodeUtf8 (T.singleton c) : acc) - -parseFilename :: T.Text -> (Maybe Basename, [Extension]) +parseFilename :: Chunk -> (Maybe Basename, [Extension]) parseFilename filename = parsed where - parsed = if T.null filename + parsed = if null filename then (Nothing, []) - else case textSplitBy (== '.') filename of + else case splitBy (== '.') filename of [] -> (Nothing, []) (name':exts') -> (Just name', exts') @@ -212,4 +217,3 @@ unicodeError :: UnicodeException -> IO (Maybe a) unicodeError _ = return Nothing - 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 @@ -10,6 +10,7 @@ ( Rules , posix , posix_ghc702 + , posix_ghc704 , windows , darwin , darwin_ghc702 @@ -33,7 +34,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import Data.Char (toUpper, chr, ord) -import Data.List (intersperse) +import Data.List (intersperse, intercalate) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import System.IO () @@ -45,15 +46,18 @@ -- Generic ------------------------------------------------------------------------------- -rootText :: Maybe Root -> T.Text -rootText r = T.pack $ flip (maybe "") r $ \r' -> case r' of +rootChunk :: Maybe Root -> Chunk +rootChunk r = flip (maybe "") r $ \r' -> case r' of RootPosix -> "/" RootWindowsVolume c -> c : ":\\" RootWindowsCurrentVolume -> "\\" -directoryChunks :: FilePath -> [T.Text] -directoryChunks path = pathDirectories path ++ [filenameText path] +rootText :: Maybe Root -> T.Text +rootText = T.pack . rootChunk +directoryChunks :: FilePath -> [Chunk] +directoryChunks path = pathDirectories path ++ [filenameChunk path] + ------------------------------------------------------------------------------- -- POSIX ------------------------------------------------------------------------------- @@ -74,17 +78,30 @@ -- | Linux, BSD, and other UNIX or UNIX-like operating systems. -- --- This is a variant of 'posix' for use with GHC 7.2 or later, which tries to --- decode file paths in its IO computations. +-- This is a variant of 'posix' for use with GHC 7.2, which tries to decode +-- file paths in its IO computations. -- --- Since: 0.4.2 +-- Since: 0.3.3 / 0.4.2 posix_ghc702 :: Rules B.ByteString posix_ghc702 = posix { rulesName = T.pack "POSIX (GHC 7.2)" - , encodeString = posixToGhcString - , decodeString = posixFromGhcString + , encodeString = posixToGhc702String + , decodeString = posixFromGhc702String } +-- | Linux, BSD, and other UNIX or UNIX-like operating systems. +-- +-- This is a variant of 'posix' for use with GHC 7.4 or later, which tries to +-- decode file paths in its IO computations. +-- +-- Since: 0.3.7 / 0.4.6 +posix_ghc704 :: Rules B.ByteString +posix_ghc704 = posix + { rulesName = T.pack "POSIX (GHC 7.4)" + , 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) @@ -93,82 +110,87 @@ root = rootText (pathRoot p) chunks = intersperse (T.pack "/", True) (map unescape (directoryChunks p)) -posixFromChunks :: [T.Text] -> FilePath +posixFromChunks :: [Chunk] -> FilePath posixFromChunks chunks = FilePath root directories basename exts where - (root, pastRoot) = if T.null (head chunks) + (root, pastRoot) = if P.null (head chunks) then (Just RootPosix, tail chunks) else (Nothing, chunks) (directories, filename) - | P.null pastRoot = ([], T.empty) + | P.null pastRoot = ([], "") | otherwise = case last pastRoot of - fn | fn == dot -> (goodDirs pastRoot, T.empty) - fn | fn == dots -> (goodDirs pastRoot, T.empty) + fn | fn == dot -> (goodDirs pastRoot, "") + fn | fn == dots -> (goodDirs pastRoot, "") fn -> (goodDirs (init pastRoot), fn) - goodDirs = filter (not . T.null) + goodDirs = filter (not . P.null) (basename, exts) = parseFilename filename posixFromText :: T.Text -> FilePath posixFromText text = if T.null text then empty - else posixFromChunks (textSplitBy (== '/') text) + else posixFromChunks (map escape (textSplitBy (== '/') text)) posixToBytes :: FilePath -> B.ByteString posixToBytes p = B.concat (root : chunks) where - root = TE.encodeUtf8 (rootText (pathRoot p)) + root = B8.pack (rootChunk (pathRoot p)) chunks = intersperse (B8.pack "/") (map chunkBytes (directoryChunks p)) - chunkBytes t = if T.any (== '\xEF00') t - then unescapeBytes' t - else TE.encodeUtf8 t + 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 -> text + Just text -> escape text Nothing -> processInvalidUtf8 b -processInvalidUtf8 :: B.ByteString -> T.Text -processInvalidUtf8 bytes = T.intercalate (T.pack ".") textChunks where +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 -> t - Nothing -> T.pack (concatMap (\c -> if ord c >= 0x80 - then ['\xEF00', c] - else [c]) (B8.unpack b)) + Just t -> escape t + Nothing -> map (\c -> if ord c >= 0x80 + then chr (ord c + 0xDC00) + else c) (B8.unpack b) -posixToGhcString :: FilePath -> String -posixToGhcString p = P.concat (root : chunks) where - root = T.unpack (rootText (pathRoot p)) - chunks = intersperse "/" (map escapeToGhc (directoryChunks p)) +posixToGhc702String :: FilePath -> String +posixToGhc702String p = P.concat (root : chunks) where + root = rootChunk (pathRoot p) + chunks = intersperse "/" (map escapeToGhc702 (directoryChunks p)) -escapeToGhc :: T.Text -> String -escapeToGhc t = if anyEscaped then impl else T.unpack t where - anyEscaped = T.any (== '\xEF00') t - impl = reverse (snd folded) - folded = T.foldl' step (False, []) t - step (prevEsc, acc) c = if prevEsc - then (False, (chr (ord c + 0xEF00)):acc) - else if c == '\xEF00' - then (True, acc) - else (False, c:acc) +escapeToGhc702 :: Chunk -> String +escapeToGhc702 = map (\c -> if ord c >= 0xDC80 && ord c <= 0xDCFF + then chr (ord c - 0xDC00 + 0xEF00) + else c) -posixFromGhcString :: String -> FilePath -posixFromGhcString = posixFromText . T.pack . escapeFromGhc +posixFromGhc702String :: String -> FilePath +posixFromGhc702String cs = if P.null cs + then empty + else posixFromChunks (map escapeFromGhc702 (splitBy (== '/') cs)) -escapeFromGhc :: String -> String -escapeFromGhc = concatMap step where - step c = if ord c >= 0xEF00 && ord c <= 0xEFFF - then ['\xEF00', chr (ord c - 0xEF00)] - else [c] +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) +posixToGhc704String :: FilePath -> String +posixToGhc704String p = P.concat (root : chunks) where + root = rootChunk (pathRoot p) + chunks = intersperse "/" (directoryChunks p) + +posixFromGhc704String :: String -> FilePath +posixFromGhc704String cs = if P.null cs + then empty + else posixFromChunks (splitBy (== '/') cs) + posixValid :: FilePath -> Bool posixValid p = validRoot && validDirectories where validDirectories = all validChunk (directoryChunks p) - validChunk ch = not (T.any (\c -> c == '\0' || c == '/') ch) + validChunk ch = not (any (\c -> c == '\0' || c == '/') ch) validRoot = case pathRoot p of Nothing -> True Just RootPosix -> True @@ -187,7 +209,7 @@ -- This is almost identical to 'posix', but with a native path type of 'T.Text' -- rather than 'B.ByteString'. -- --- Since: 0.4.3 +-- Since: 0.3.4 / 0.4.3 darwin :: Rules T.Text darwin = Rules { rulesName = T.pack "Darwin" @@ -206,7 +228,7 @@ -- This is a variant of 'darwin' for use with GHC 7.2 or later, which tries to -- decode file paths in its IO computations. -- --- Since: 0.4.3 +-- Since: 0.3.4 / 0.4.3 darwin_ghc702 :: Rules T.Text darwin_ghc702 = darwin { rulesName = T.pack "Darwin (GHC 7.2)" @@ -217,7 +239,7 @@ darwinToText :: FilePath -> T.Text darwinToText p = T.concat (root : chunks) where root = rootText (pathRoot p) - chunks = intersperse (T.pack "/") (directoryChunks p) + chunks = intersperse (T.pack "/") (map unescape' (directoryChunks p)) darwinToString :: FilePath -> String darwinToString = B8.unpack . TE.encodeUtf8 . darwinToText @@ -250,7 +272,7 @@ winToText :: FilePath -> T.Text winToText p = T.concat (root : chunks) where root = rootText (pathRoot p) - chunks = intersperse (T.pack "\\") (directoryChunks p) + chunks = intersperse (T.pack "\\") (map unescape' (directoryChunks p)) winFromText :: T.Text -> FilePath winFromText text = if T.null text then empty else path where @@ -270,20 +292,21 @@ parseDrive = RootWindowsVolume . toUpper . T.head (directories, filename) - | P.null pastRoot = ([], T.empty) + | P.null pastRoot = ([], "") | otherwise = case last pastRoot of - fn | fn == dot -> (goodDirs pastRoot, T.empty) - fn | fn == dots -> (goodDirs pastRoot, T.empty) - fn -> (goodDirs (init pastRoot), fn) + fn | fn == T.pack "." -> (goodDirs pastRoot, "") + fn | fn == T.pack ".." -> (goodDirs pastRoot, "") + fn -> (goodDirs (init pastRoot), escape fn) - goodDirs = filter (not . T.null) + goodDirs :: [T.Text] -> [Chunk] + goodDirs = map escape . filter (not . T.null) (basename, exts) = parseFilename filename winValid :: FilePath -> Bool winValid p = validRoot && noReserved && validCharacters where reservedChars = map chr [0..0x1F] ++ "/\\?*:|\"<>" - reservedNames = map T.pack + reservedNames = [ "AUX", "CLOCK$", "COM1", "COM2", "COM3", "COM4" , "COM5", "COM6", "COM7", "COM8", "COM9", "CON" , "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6" @@ -298,10 +321,10 @@ noExt = p { pathExtensions = [] } noReserved = flip all (directoryChunks noExt) - $ \fn -> notElem (T.toUpper fn) reservedNames + $ \fn -> notElem (map toUpper fn) reservedNames validCharacters = flip all (directoryChunks p) - $ not . T.any (`elem` reservedChars) + $ not . any (`elem` reservedChars) winSplit :: T.Text -> [FilePath] winSplit = map winFromText . filter (not . T.null) . textSplitBy (== ';') diff --git a/system-filepath.cabal b/system-filepath.cabal --- a/system-filepath.cabal +++ b/system-filepath.cabal @@ -1,11 +1,11 @@ name: system-filepath -version: 0.4.5 +version: 0.4.6 synopsis: High-level, byte-based file and directory path manipulations license: MIT license-file: license.txt author: John Millikin maintainer: John Millikin -copyright: John Millikin 2010-2011 +copyright: John Millikin 2010-2012 build-type: Simple cabal-version: >= 1.6 category: System @@ -29,7 +29,7 @@ source-repository this type: bzr location: https://john-millikin.com/branches/system-filepath/0.4/ - tag: system-filepath_0.4.5 + tag: system-filepath_0.4.6 library ghc-options: -Wall -O2 diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -340,6 +340,11 @@ 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 :: Suite test_Parsing = assertions "parsing" $ do @@ -389,6 +394,7 @@ test_EncodeString = suite "encodeString" [ test_EncodeString_Posix , test_EncodeString_Posix_Ghc702 + , test_EncodeString_Posix_Ghc704 , test_EncodeString_Win32 ] @@ -409,6 +415,14 @@ $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 :: Suite +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 :: Suite test_EncodeString_Win32 = assertions "windows" $ do let enc = encodeString windows @@ -420,6 +434,7 @@ test_DecodeString = suite "decodeString" [ test_DecodeString_Posix , test_DecodeString_Posix_Ghc702 + , test_DecodeString_Posix_Ghc704 , test_DecodeString_Darwin , test_DecodeString_Darwin_Ghc702 , test_DecodeString_Win32 @@ -443,6 +458,18 @@ $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 :: Suite +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 :: Suite