diff --git a/lib/Filesystem/Path.hs b/lib/Filesystem/Path.hs new file mode 100644 --- /dev/null +++ b/lib/Filesystem/Path.hs @@ -0,0 +1,344 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module: Filesystem.Path +-- Copyright: 2010 John Millikin +-- License: MIT +-- +-- Maintainer: jmillikin@gmail.com +-- Portability: portable +-- +-- High‐level, byte‐based file and directory path +-- manipulations. You probably want to import "Filesystem.Path.CurrentOS" +-- instead, since it handles detecting which rules to use in the current +-- compilation. +-- +module Filesystem.Path + ( FilePath + , empty + + -- * Basic properties + , null + , root + , directory + , parent + , filename + , dirname + , basename + , absolute + , relative + + -- * Basic operations + , append + , () + , concat + , commonPrefix + , stripPrefix + , collapse + + -- * Extensions + , extension + , extensions + , hasExtension + + , addExtension + , (<.>) + , dropExtension + , replaceExtension + + , addExtensions + , dropExtensions + , replaceExtensions + + , splitExtension + , splitExtensions + ) where + +import Prelude hiding (FilePath, concat, null) + +import Data.List (foldl') +import Data.Maybe (isNothing) +import qualified Data.Monoid as M +import qualified Data.Text as T + +import Filesystem.Path.Internal + +instance M.Monoid FilePath where + mempty = empty + mappend = append + mconcat = concat + +------------------------------------------------------------------------------- +-- Basic properties +------------------------------------------------------------------------------- + +-- | @null p = (p == 'empty')@ +null :: FilePath -> Bool +null = (== empty) + +-- | Retrieves the 'FilePath'’s root. +root :: FilePath -> FilePath +root p = empty { pathRoot = pathRoot p } + +-- | Retrieves the 'FilePath'’s directory. If the path is already a +-- directory, it is returned unchanged. +directory :: FilePath -> FilePath +directory p = empty + { pathRoot = pathRoot p + , pathDirectories = let + starts = map Just [dot, dots] + dot' | safeHead (pathDirectories p) `elem` starts = [] + | isNothing (pathRoot 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 + } + +-- | Retrieve a 'FilePath'’s filename component. +-- +-- @ +-- filename \"foo/bar.txt\" == \"bar.txt\" +-- @ +filename :: FilePath -> FilePath +filename p = empty + { 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. +-- +-- @ +-- dirname \"foo/bar/baz.txt\" == \"bar\" +-- dirname \"/\" == \"\" +-- @ +-- +-- Since: 0.4.1 +dirname :: FilePath -> FilePath +dirname p = case reverse (pathDirectories p) of + [] -> FilePath Nothing [] Nothing [] + (d:_) -> let + d':exts = T.split (== '.') (chunkText d) + chunk txt = d { chunkText = txt } + in FilePath Nothing [] (Just (chunk d')) (map chunk exts) + + +-- | Retrieve a 'FilePath'’s basename component. +-- +-- @ +-- basename \"foo/bar.txt\" == \"bar\" +-- @ +basename :: FilePath -> FilePath +basename p = empty + { pathBasename = pathBasename p + } + +-- | Test whether a path is absolute. +absolute :: FilePath -> Bool +absolute p = case pathRoot p of + Just RootPosix -> True + Just (RootWindowsVolume _) -> True + _ -> False + +-- | Test whether a path is relative. +relative :: FilePath -> Bool +relative p = case pathRoot p of + Just _ -> False + _ -> True + +------------------------------------------------------------------------------- +-- Basic operations +------------------------------------------------------------------------------- + +-- | Appends two 'FilePath's. If the second path is absolute, it is returned +-- 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 + Nothing -> xy + xy = y + { pathRoot = pathRoot x + , pathDirectories = directories + } + directories = xDirectories ++ pathDirectories y + xDirectories = (pathDirectories x ++) $ if null (filename x) + then [] + else [filenameChunk True x] + +-- | An alias for 'append'. +() :: FilePath -> FilePath -> FilePath +() = append + +-- | A fold over 'append'. +concat :: [FilePath] -> FilePath +concat [] = empty +concat ps = foldr1 append ps + +-- | Find the greatest common prefix between a list of 'FilePath's. +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 [] + +-- Remove a prefix from a path. +-- +-- @ +-- stripPrefix "/foo/" "/foo/bar/baz.txt" == Just "bar/baz.txt" +-- stripPrefix "/foo/" "/bar/baz.txt" == Nothing +-- @ +-- +-- 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 + +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 + +-- | Remove @\".\"@ and @\"..\"@ directories from a path. +-- +-- Note that if any of the elements are symbolic links, 'collapse' may change +-- which file the path resolves to. +-- +-- Since: 0.2 +collapse :: FilePath -> FilePath +collapse p = p { pathDirectories = reverse newDirs } where + (_, newDirs) = 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) + +------------------------------------------------------------------------------- +-- Extensions +------------------------------------------------------------------------------- + +-- | Get a 'FilePath'’s last extension, or 'Nothing' if it has no +-- extensions. +extension :: FilePath -> Maybe T.Text +extension p = case extensions p of + [] -> Nothing + es -> Just (last es) + +-- | Get a 'FilePath'’s full extension list. +extensions :: FilePath -> [T.Text] +extensions = map chunkText . pathExtensions + +-- | Get whether a 'FilePath'’s last extension is the predicate. +hasExtension :: FilePath -> T.Text -> Bool +hasExtension p e = extension p == Just e + +-- | Append an extension to the end of a 'FilePath'. +addExtension :: FilePath -> T.Text -> FilePath +addExtension p ext = addExtensions p [ext] + +-- | Append many extensions to the end of a 'FilePath'. +addExtensions :: FilePath -> [T.Text] -> FilePath +addExtensions p exts = p { pathExtensions = newExtensions } where + newExtensions = pathExtensions p ++ chunks + chunks = map (\e -> Chunk e True) exts + +-- | An alias for 'addExtension'. +(<.>) :: FilePath -> T.Text -> FilePath +(<.>) = addExtension + +-- | Remove a 'FilePath'’s last extension. +dropExtension :: FilePath -> FilePath +dropExtension p = p { pathExtensions = safeInit (pathExtensions p) } + +-- | Remove all extensions from a 'FilePath'. +dropExtensions :: FilePath -> FilePath +dropExtensions p = p { pathExtensions = [] } + +-- | Replace a 'FilePath'’s last extension. +replaceExtension :: FilePath -> T.Text -> FilePath +replaceExtension = addExtension . dropExtension + +-- | Remove all extensions from a 'FilePath', and replace them with a new +-- list. +replaceExtensions :: FilePath -> [T.Text] -> FilePath +replaceExtensions = addExtensions . dropExtensions + +-- | @splitExtension p = ('dropExtension' p, 'extension' p)@ +splitExtension :: FilePath -> (FilePath, Maybe T.Text) +splitExtension p = (dropExtension p, extension p) + +-- | @splitExtensions p = ('dropExtensions' p, 'extensions' p)@ +splitExtensions :: FilePath -> (FilePath, [T.Text]) +splitExtensions p = (dropExtensions p, extensions p) + +------------------------------------------------------------------------------- +-- Utils +------------------------------------------------------------------------------- + +safeInit :: [a] -> [a] +safeInit xs = case xs of + [] -> [] + _ -> init xs + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x diff --git a/lib/Filesystem/Path/CurrentOS.hs b/lib/Filesystem/Path/CurrentOS.hs new file mode 100644 --- /dev/null +++ b/lib/Filesystem/Path/CurrentOS.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module: Filesystem.Path.CurrentOS +-- Copyright: 2010 John Millikin +-- License: MIT +-- +-- Maintainer: jmillikin@gmail.com +-- Portability: portable +-- +-- Re‐exports contents of "Filesystem.Path.Rules", defaulting to the +-- current OS’s rules when needed. +-- +-- 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 + ) where + +import Prelude hiding (FilePath) + +import qualified Data.ByteString as B +import qualified Data.String as S +import qualified Data.Text as T + +import Filesystem.Path +import qualified Filesystem.Path as F +import qualified Filesystem.Path.Rules as R + +#if defined(CABAL_OS_WINDOWS) +#define PLATFORM_PATH_FORMAT T.Text +#else +#define PLATFORM_PATH_FORMAT B.ByteString +#endif + +currentOS :: R.Rules PLATFORM_PATH_FORMAT +#if defined(CABAL_OS_WINDOWS) +currentOS = R.windows +#else +#if __GLASGOW_HASKELL__ >= 702 +currentOS = R.posix_ghc702 +#else +currentOS = R.posix +#endif +#endif + +instance S.IsString F.FilePath where + 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) + +-- | Attempt to convert a 'F.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 :: F.FilePath -> Either T.Text T.Text +toText = R.toText currentOS + +-- | 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 -> F.FilePath +fromText = R.fromText currentOS + +-- | Check if a 'FilePath' is valid; it must not contain any illegal +-- characters, and must have a root appropriate to the current 'R.Rules'. +valid :: F.FilePath -> Bool +valid = R.valid currentOS + +-- | Split a search path, such as @$PATH@ or @$PYTHONPATH@, into a list +-- of 'FilePath's. +splitSearchPath :: PLATFORM_PATH_FORMAT -> [F.FilePath] +splitSearchPath = R.splitSearchPath currentOS + +-- | Convert a 'F.FilePath' to a platform‐specific format, suitable +-- for use with external OS functions. +-- +-- Since: 0.3 +encode :: F.FilePath -> PLATFORM_PATH_FORMAT +encode = R.encode currentOS + +-- | Convert a 'F.FilePath' from a platform‐specific format, suitable +-- for use with external OS functions. +-- +-- Since: 0.3 +decode :: PLATFORM_PATH_FORMAT -> F.FilePath +decode = R.decode currentOS + +-- | Attempt to convert a 'F.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 'F.FilePath's to a +-- human‐readable format, use 'toText'. +-- +-- Since: 0.3.1 +encodeString :: F.FilePath -> String +encodeString = R.encodeString currentOS + +-- | Attempt to parse a 'F.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 +-- 'F.FilePath', use 'fromText'. +-- +-- Since: 0.3.1 +decodeString :: String -> F.FilePath +decodeString = R.decodeString currentOS diff --git a/lib/Filesystem/Path/Internal.hs b/lib/Filesystem/Path/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Filesystem/Path/Internal.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | +-- Module: Filesystem.Path.Internal +-- Copyright: 2010 John Millikin +-- License: MIT +-- +-- Maintainer: jmillikin@gmail.com +-- Portability: portable +-- +module Filesystem.Path.Internal where + +import Prelude hiding (FilePath) + +import qualified Data.ByteString.Char8 as B8 +import Data.Data (Data) +import Data.List (intersperse) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Typeable (Typeable) + +------------------------------------------------------------------------------- +-- File Paths +------------------------------------------------------------------------------- + +data Chunk = Chunk + { chunkText :: T.Text + , chunkGood :: Bool + } + deriving (Ord, Data, Typeable) + +instance Eq Chunk where + (Chunk x _) == (Chunk y _) = x == y + +type Directory = Chunk +type Basename = Chunk +type Extension = Chunk + +data Root + = RootPosix + | RootWindowsVolume Char + | RootWindowsCurrentVolume + deriving (Eq, Ord, Data, Typeable) + +data FilePath = FilePath + { pathRoot :: Maybe Root + , pathDirectories :: [Directory] + , pathBasename :: Maybe Basename + , pathExtensions :: [Extension] + } + deriving (Eq, Ord, Data, Typeable) + +-- | A file path with no root, directory, or filename +empty :: FilePath +empty = FilePath Nothing [] Nothing [] + +dot :: Chunk +dot = Chunk (T.pack ".") True + +dots :: Chunk +dots = Chunk (T.pack "..") True + +filenameChunk :: Bool -> FilePath -> Chunk +filenameChunk strict p = Chunk (T.concat texts) allGood where + name = maybe (Chunk T.empty True) id (pathBasename p) + exts = case pathExtensions p of + [] -> [] + exts' -> intersperse dot ((Chunk T.empty True):exts') + chunks = name:exts + + texts = map chunkText' chunks + allGood = and (map chunkGood chunks) + + chunkText' c = if chunkGood c + then if allGood || not strict + then chunkText c + else T.pack (B8.unpack (TE.encodeUtf8 (chunkText c))) + else chunkText c + +------------------------------------------------------------------------------- +-- Rules +------------------------------------------------------------------------------- + +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. + , splitSearchPath :: platformFormat -> [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. + -- + -- Since: 0.3 + , encode :: FilePath -> platformFormat + + -- | Convert a 'FilePath' from a platform‐specific format, + -- suitable for use with external OS functions. + -- + -- 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)) diff --git a/lib/Filesystem/Path/Rules.hs b/lib/Filesystem/Path/Rules.hs new file mode 100644 --- /dev/null +++ b/lib/Filesystem/Path/Rules.hs @@ -0,0 +1,243 @@ +-- | +-- Module: Filesystem.Path.Rules +-- Copyright: 2010 John Millikin +-- License: MIT +-- +-- Maintainer: jmillikin@gmail.com +-- Portability: portable +-- +module Filesystem.Path.Rules + ( Rules + , posix + , posix_ghc702 + , windows + + -- * Type conversions + , toText + , fromText + , encode + , decode + , encodeString + , decodeString + + -- * Rule‐specific path properties + , valid + , splitSearchPath + ) where + +import Prelude hiding (FilePath, null) +import qualified Prelude as P + +import qualified Control.Exception as Exc +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import Data.Char (toUpper, chr) +import Data.List (intersperse) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Text.Encoding.Error (UnicodeException) +import System.IO () +import System.IO.Unsafe (unsafePerformIO) + +import Filesystem.Path hiding (root, filename, basename) +import Filesystem.Path.Internal + +------------------------------------------------------------------------------- +-- Generic +------------------------------------------------------------------------------- + +rootText :: Maybe Root -> T.Text +rootText r = T.pack $ flip (maybe "") r $ \r' -> case r' of + RootPosix -> "/" + RootWindowsVolume c -> c : ":\\" + RootWindowsCurrentVolume -> "\\" + +directoryChunks :: Bool -> FilePath -> [Chunk] +directoryChunks strict path = pathDirectories path ++ [filenameChunk strict path] + +maybeDecodeUtf8 :: B.ByteString -> Maybe T.Text +maybeDecodeUtf8 = excToMaybe . TE.decodeUtf8 where + excToMaybe :: a -> Maybe a + excToMaybe x = unsafePerformIO $ Exc.catch + (fmap Just (Exc.evaluate x)) + unicodeError + + unicodeError :: UnicodeException -> IO (Maybe a) + unicodeError _ = return Nothing + +------------------------------------------------------------------------------- +-- POSIX +------------------------------------------------------------------------------- + +-- | Linux, BSD, OS X, and other UNIX or UNIX-like operating systems. +posix :: Rules B.ByteString +posix = Rules + { rulesName = T.pack "POSIX" + , valid = posixValid + , splitSearchPath = posixSplitSearch + , toText = posixToText + , fromText = posixFromText + , encode = posixToBytes + , decode = posixFromBytes + , encodeString = B8.unpack . posixToBytes + , decodeString = posixFromBytes . B8.pack + } + +-- | Linux, BSD, OS X, and other UNIX or UNIX-like operating systems. +-- +-- This variant is for use with GHC 7.2 or later, which tries to decode +-- file paths in its IO computations. +posix_ghc702 :: Rules B.ByteString +posix_ghc702 = posix + { encodeString = T.unpack . either id id . posixToText + , decodeString = posixFromText . T.pack + } + +posixToText :: FilePath -> Either T.Text T.Text +posixToText p = if good then Right text else Left text where + good = and (map chunkGood chunks) + text = T.concat (root : map chunkText chunks) + + root = rootText (pathRoot p) + chunks = intersperse (Chunk (T.pack "/") True) (directoryChunks False p) + +posixFromChunks :: [Chunk] -> FilePath +posixFromChunks chunks = FilePath root directories basename exts where + (root, pastRoot) = if T.null (chunkText (head chunks)) + then (Just RootPosix, tail chunks) + else (Nothing, chunks) + + (directories, filename) + | P.null pastRoot = ([], Chunk T.empty True) + | otherwise = case last pastRoot of + fn | fn == dot -> (goodDirs pastRoot, Chunk T.empty True) + fn | fn == dots -> (goodDirs pastRoot, Chunk T.empty True) + fn -> (goodDirs (init pastRoot), fn) + + goodDirs = filter (not . T.null . chunkText) + + (basename, exts) = if T.null (chunkText filename) + then (Nothing, []) + else case T.split (== '.') (chunkText filename) of + [] -> (Nothing, []) + (name':exts') -> if chunkGood filename + then (Just (Chunk name' True), map (\e -> Chunk e True) exts') + else (Just (checkChunk name'), map checkChunk exts') + + checkChunk raw = case maybeDecodeUtf8 (B8.pack (T.unpack raw)) of + Just text -> Chunk text True + Nothing -> Chunk raw False + +posixFromText :: T.Text -> FilePath +posixFromText text = if T.null text + then empty + else posixFromChunks (map (\t -> Chunk t True) (T.split (== '/') text)) + +posixToBytes :: FilePath -> B.ByteString +posixToBytes p = B.concat (root : chunks) where + root = TE.encodeUtf8 (rootText (pathRoot p)) + chunks = intersperse (B8.pack "/") (map chunkBytes (directoryChunks True p)) + chunkBytes c = if chunkGood c + then TE.encodeUtf8 (chunkText c) + else B8.pack (T.unpack (chunkText 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 -> Chunk text True + Nothing -> Chunk (T.pack (B8.unpack b)) False + +posixValid :: FilePath -> Bool +posixValid p = validRoot && validDirectories where + validDirectories = all validChunk (directoryChunks True p) + validChunk ch = not (T.any (\c -> c == '\0' || c == '/') (chunkText 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 + +------------------------------------------------------------------------------- +-- Windows +------------------------------------------------------------------------------- + +-- | Windows and DOS +windows :: Rules T.Text +windows = Rules + { rulesName = T.pack "Windows" + , valid = winValid + , splitSearchPath = winSplit + , toText = Right . winToText + , fromText = winFromText + , encode = winToText + , decode = winFromText + , encodeString = T.unpack . winToText + , decodeString = winFromText . T.pack + } + +winToText :: FilePath -> T.Text +winToText p = T.concat (root : chunks) where + root = rootText (pathRoot p) + chunks = intersperse (T.pack "\\") (map chunkText (directoryChunks False p)) + +winFromText :: T.Text -> FilePath +winFromText text = if T.null text then empty else path where + path = FilePath root directories basename exts + + split = T.split (\c -> c == '/' || c == '\\') text + + (root, pastRoot) = let + head' = head split + tail' = tail split + in if T.null head' + then (Just RootWindowsCurrentVolume, tail') + else if T.any (== ':') head' + then (Just (parseDrive head'), tail') + else (Nothing, split) + + parseDrive = RootWindowsVolume . toUpper . T.head + + (directories, filename) + | P.null pastRoot = ([], T.empty) + | otherwise = case last pastRoot of + fn | fn == chunkText dot -> (goodDirs pastRoot, T.empty) + fn | fn == chunkText dots -> (goodDirs pastRoot, T.empty) + fn -> (goodDirs (init pastRoot), fn) + + goodDirs = map (\t -> Chunk t True) . filter (not . T.null) + + (basename, exts) = if T.null filename + then (Nothing, []) + else case T.split (== '.') filename of + [] -> (Nothing, []) + (name':exts') -> (Just (Chunk name' True), map (\e -> Chunk e True) exts') + +winValid :: FilePath -> Bool +winValid p = validRoot && noReserved && validCharacters where + reservedChars = map chr [0..0x1F] ++ "/\\?*:|\"<>" + reservedNames = map T.pack + [ "AUX", "CLOCK$", "COM1", "COM2", "COM3", "COM4" + , "COM5", "COM6", "COM7", "COM8", "COM9", "CON" + , "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6" + , "LPT7", "LPT8", "LPT9", "NUL", "PRN" + ] + + validRoot = case pathRoot p of + Nothing -> True + Just RootWindowsCurrentVolume -> True + Just (RootWindowsVolume v) -> elem v ['A'..'Z'] + _ -> False + + noExt = p { pathExtensions = [] } + noReserved = flip all (directoryChunks False noExt) + $ \fn -> notElem (T.toUpper (chunkText fn)) reservedNames + + validCharacters = flip all (directoryChunks False p) + $ not . T.any (`elem` reservedChars) . chunkText + +winSplit :: T.Text -> [FilePath] +winSplit = map winFromText . filter (not . T.null) . T.split (== ';') diff --git a/src/Filesystem/Path.hs b/src/Filesystem/Path.hs deleted file mode 100644 --- a/src/Filesystem/Path.hs +++ /dev/null @@ -1,344 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- Module: Filesystem.Path --- Copyright: 2010 John Millikin --- License: MIT --- --- Maintainer: jmillikin@gmail.com --- Portability: portable --- --- High‐level, byte‐based file and directory path --- manipulations. You probably want to import "Filesystem.Path.CurrentOS" --- instead, since it handles detecting which rules to use in the current --- compilation. --- -module Filesystem.Path - ( FilePath - , empty - - -- * Basic properties - , null - , root - , directory - , parent - , filename - , dirname - , basename - , absolute - , relative - - -- * Basic operations - , append - , () - , concat - , commonPrefix - , stripPrefix - , collapse - - -- * Extensions - , extension - , extensions - , hasExtension - - , addExtension - , (<.>) - , dropExtension - , replaceExtension - - , addExtensions - , dropExtensions - , replaceExtensions - - , splitExtension - , splitExtensions - ) where - -import Prelude hiding (FilePath, concat, null) - -import Data.List (foldl') -import Data.Maybe (isNothing) -import qualified Data.Monoid as M -import qualified Data.Text as T - -import Filesystem.Path.Internal - -instance M.Monoid FilePath where - mempty = empty - mappend = append - mconcat = concat - -------------------------------------------------------------------------------- --- Basic properties -------------------------------------------------------------------------------- - --- | @null p = (p == 'empty')@ -null :: FilePath -> Bool -null = (== empty) - --- | Retrieves the 'FilePath'’s root. -root :: FilePath -> FilePath -root p = empty { pathRoot = pathRoot p } - --- | Retrieves the 'FilePath'’s directory. If the path is already a --- directory, it is returned unchanged. -directory :: FilePath -> FilePath -directory p = empty - { pathRoot = pathRoot p - , pathDirectories = let - starts = map Just [dot, dots] - dot' | safeHead (pathDirectories p) `elem` starts = [] - | isNothing (pathRoot 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 - } - --- | Retrieve a 'FilePath'’s filename component. --- --- @ --- filename \"foo/bar.txt\" == \"bar.txt\" --- @ -filename :: FilePath -> FilePath -filename p = empty - { 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. --- --- @ --- dirname \"foo/bar/baz.txt\" == \"bar\" --- dirname \"/\" == \"\" --- @ --- --- Since: 0.4.1 -dirname :: FilePath -> FilePath -dirname p = case reverse (pathDirectories p) of - [] -> FilePath Nothing [] Nothing [] - (d:_) -> let - d':exts = T.split (== '.') (chunkText d) - chunk txt = d { chunkText = txt } - in FilePath Nothing [] (Just (chunk d')) (map chunk exts) - - --- | Retrieve a 'FilePath'’s basename component. --- --- @ --- basename \"foo/bar.txt\" == \"bar\" --- @ -basename :: FilePath -> FilePath -basename p = empty - { pathBasename = pathBasename p - } - --- | Test whether a path is absolute. -absolute :: FilePath -> Bool -absolute p = case pathRoot p of - Just RootPosix -> True - Just (RootWindowsVolume _) -> True - _ -> False - --- | Test whether a path is relative. -relative :: FilePath -> Bool -relative p = case pathRoot p of - Just _ -> False - _ -> True - -------------------------------------------------------------------------------- --- Basic operations -------------------------------------------------------------------------------- - --- | Appends two 'FilePath's. If the second path is absolute, it is returned --- 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 - Nothing -> xy - xy = y - { pathRoot = pathRoot x - , pathDirectories = directories - } - directories = xDirectories ++ pathDirectories y - xDirectories = (pathDirectories x ++) $ if null (filename x) - then [] - else [filenameChunk True x] - --- | An alias for 'append'. -() :: FilePath -> FilePath -> FilePath -() = append - --- | A fold over 'append'. -concat :: [FilePath] -> FilePath -concat [] = empty -concat ps = foldr1 append ps - --- | Find the greatest common prefix between a list of 'FilePath's. -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 [] - --- Remove a prefix from a path. --- --- @ --- stripPrefix "/foo/" "/foo/bar/baz.txt" == Just "bar/baz.txt" --- stripPrefix "/foo/" "/bar/baz.txt" == Nothing --- @ --- --- 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 - -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 - --- | Remove @\".\"@ and @\"..\"@ directories from a path. --- --- Note that if any of the elements are symbolic links, 'collapse' may change --- which file the path resolves to. --- --- Since: 0.2 -collapse :: FilePath -> FilePath -collapse p = p { pathDirectories = reverse newDirs } where - (_, newDirs) = 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) - -------------------------------------------------------------------------------- --- Extensions -------------------------------------------------------------------------------- - --- | Get a 'FilePath'’s last extension, or 'Nothing' if it has no --- extensions. -extension :: FilePath -> Maybe T.Text -extension p = case extensions p of - [] -> Nothing - es -> Just (last es) - --- | Get a 'FilePath'’s full extension list. -extensions :: FilePath -> [T.Text] -extensions = map chunkText . pathExtensions - --- | Get whether a 'FilePath'’s last extension is the predicate. -hasExtension :: FilePath -> T.Text -> Bool -hasExtension p e = extension p == Just e - --- | Append an extension to the end of a 'FilePath'. -addExtension :: FilePath -> T.Text -> FilePath -addExtension p ext = addExtensions p [ext] - --- | Append many extensions to the end of a 'FilePath'. -addExtensions :: FilePath -> [T.Text] -> FilePath -addExtensions p exts = p { pathExtensions = newExtensions } where - newExtensions = pathExtensions p ++ chunks - chunks = map (\e -> Chunk e True) exts - --- | An alias for 'addExtension'. -(<.>) :: FilePath -> T.Text -> FilePath -(<.>) = addExtension - --- | Remove a 'FilePath'’s last extension. -dropExtension :: FilePath -> FilePath -dropExtension p = p { pathExtensions = safeInit (pathExtensions p) } - --- | Remove all extensions from a 'FilePath'. -dropExtensions :: FilePath -> FilePath -dropExtensions p = p { pathExtensions = [] } - --- | Replace a 'FilePath'’s last extension. -replaceExtension :: FilePath -> T.Text -> FilePath -replaceExtension = addExtension . dropExtension - --- | Remove all extensions from a 'FilePath', and replace them with a new --- list. -replaceExtensions :: FilePath -> [T.Text] -> FilePath -replaceExtensions = addExtensions . dropExtensions - --- | @splitExtension p = ('dropExtension' p, 'extension' p)@ -splitExtension :: FilePath -> (FilePath, Maybe T.Text) -splitExtension p = (dropExtension p, extension p) - --- | @splitExtensions p = ('dropExtensions' p, 'extensions' p)@ -splitExtensions :: FilePath -> (FilePath, [T.Text]) -splitExtensions p = (dropExtensions p, extensions p) - -------------------------------------------------------------------------------- --- Utils -------------------------------------------------------------------------------- - -safeInit :: [a] -> [a] -safeInit xs = case xs of - [] -> [] - _ -> init xs - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x:_) = Just x diff --git a/src/Filesystem/Path/CurrentOS.hs b/src/Filesystem/Path/CurrentOS.hs deleted file mode 100644 --- a/src/Filesystem/Path/CurrentOS.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- Module: Filesystem.Path.CurrentOS --- Copyright: 2010 John Millikin --- License: MIT --- --- Maintainer: jmillikin@gmail.com --- Portability: portable --- --- Re‐exports contents of "Filesystem.Path.Rules", defaulting to the --- current OS’s rules when needed. --- --- 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 - ) where - -import Prelude hiding (FilePath) - -import qualified Data.ByteString as B -import qualified Data.String as S -import qualified Data.Text as T - -import Filesystem.Path -import qualified Filesystem.Path as F -import qualified Filesystem.Path.Rules as R - -#if defined(CABAL_OS_WINDOWS) -#define PLATFORM_PATH_FORMAT T.Text -#else -#define PLATFORM_PATH_FORMAT B.ByteString -#endif - -currentOS :: R.Rules PLATFORM_PATH_FORMAT -#if defined(CABAL_OS_WINDOWS) -currentOS = R.windows -#else -currentOS = R.posix -#endif - -instance S.IsString F.FilePath where - 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) - --- | Attempt to convert a 'F.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 :: F.FilePath -> Either T.Text T.Text -toText = R.toText currentOS - --- | 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 -> F.FilePath -fromText = R.fromText currentOS - --- | Check if a 'FilePath' is valid; it must not contain any illegal --- characters, and must have a root appropriate to the current 'R.Rules'. -valid :: F.FilePath -> Bool -valid = R.valid currentOS - --- | Split a search path, such as @$PATH@ or @$PYTHONPATH@, into a list --- of 'FilePath's. -splitSearchPath :: PLATFORM_PATH_FORMAT -> [F.FilePath] -splitSearchPath = R.splitSearchPath currentOS - --- | Convert a 'F.FilePath' to a platform‐specific format, suitable --- for use with external OS functions. --- --- Since: 0.3 -encode :: F.FilePath -> PLATFORM_PATH_FORMAT -encode = R.encode currentOS - --- | Convert a 'F.FilePath' from a platform‐specific format, suitable --- for use with external OS functions. --- --- Since: 0.3 -decode :: PLATFORM_PATH_FORMAT -> F.FilePath -decode = R.decode currentOS - --- | Attempt to convert a 'F.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 'F.FilePath's to a --- human‐readable format, use 'toText'. --- --- Since: 0.3.1 -encodeString :: F.FilePath -> String -encodeString = R.encodeString currentOS - --- | Attempt to parse a 'F.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 --- 'F.FilePath', use 'fromText'. --- --- Since: 0.3.1 -decodeString :: String -> F.FilePath -decodeString = R.decodeString currentOS diff --git a/src/Filesystem/Path/Internal.hs b/src/Filesystem/Path/Internal.hs deleted file mode 100644 --- a/src/Filesystem/Path/Internal.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- | --- Module: Filesystem.Path.Internal --- Copyright: 2010 John Millikin --- License: MIT --- --- Maintainer: jmillikin@gmail.com --- Portability: portable --- -module Filesystem.Path.Internal where - -import Prelude hiding (FilePath) - -import qualified Data.ByteString.Char8 as B8 -import Data.Data (Data) -import Data.List (intersperse) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Typeable (Typeable) - -------------------------------------------------------------------------------- --- File Paths -------------------------------------------------------------------------------- - -data Chunk = Chunk - { chunkText :: T.Text - , chunkGood :: Bool - } - deriving (Eq, Ord, Data, Typeable) - -type Directory = Chunk -type Basename = Chunk -type Extension = Chunk - -data Root - = RootPosix - | RootWindowsVolume Char - | RootWindowsCurrentVolume - deriving (Eq, Ord, Data, Typeable) - -data FilePath = FilePath - { pathRoot :: Maybe Root - , pathDirectories :: [Directory] - , pathBasename :: Maybe Basename - , pathExtensions :: [Extension] - } - deriving (Eq, Ord, Data, Typeable) - --- | A file path with no root, directory, or filename -empty :: FilePath -empty = FilePath Nothing [] Nothing [] - -dot :: Chunk -dot = Chunk (T.pack ".") True - -dots :: Chunk -dots = Chunk (T.pack "..") True - -filenameChunk :: Bool -> FilePath -> Chunk -filenameChunk strict p = Chunk (T.concat texts) allGood where - name = maybe (Chunk T.empty True) id (pathBasename p) - exts = case pathExtensions p of - [] -> [] - exts' -> intersperse dot ((Chunk T.empty True):exts') - chunks = name:exts - - texts = map chunkText' chunks - allGood = and (map chunkGood chunks) - - chunkText' c = if chunkGood c - then if allGood || not strict - then chunkText c - else T.pack (B8.unpack (TE.encodeUtf8 (chunkText c))) - else chunkText c - -------------------------------------------------------------------------------- --- Rules -------------------------------------------------------------------------------- - -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. - , splitSearchPath :: platformFormat -> [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. - -- - -- Since: 0.3 - , encode :: FilePath -> platformFormat - - -- | Convert a 'FilePath' from a platform‐specific format, - -- suitable for use with external OS functions. - -- - -- 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)) diff --git a/src/Filesystem/Path/Rules.hs b/src/Filesystem/Path/Rules.hs deleted file mode 100644 --- a/src/Filesystem/Path/Rules.hs +++ /dev/null @@ -1,232 +0,0 @@ --- | --- Module: Filesystem.Path.Rules --- Copyright: 2010 John Millikin --- License: MIT --- --- Maintainer: jmillikin@gmail.com --- Portability: portable --- -module Filesystem.Path.Rules - ( Rules - , posix - , windows - - -- * Type conversions - , toText - , fromText - , encode - , decode - , encodeString - , decodeString - - -- * Rule‐specific path properties - , valid - , splitSearchPath - ) where - -import Prelude hiding (FilePath, null) -import qualified Prelude as P - -import qualified Control.Exception as Exc -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import Data.Char (toUpper, chr) -import Data.List (intersperse) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Text.Encoding.Error (UnicodeException) -import System.IO () -import System.IO.Unsafe (unsafePerformIO) - -import Filesystem.Path hiding (root, filename, basename) -import Filesystem.Path.Internal - -------------------------------------------------------------------------------- --- Generic -------------------------------------------------------------------------------- - -rootText :: Maybe Root -> T.Text -rootText r = T.pack $ flip (maybe "") r $ \r' -> case r' of - RootPosix -> "/" - RootWindowsVolume c -> c : ":\\" - RootWindowsCurrentVolume -> "\\" - -directoryChunks :: Bool -> FilePath -> [Chunk] -directoryChunks strict path = pathDirectories path ++ [filenameChunk strict path] - -maybeDecodeUtf8 :: B.ByteString -> Maybe T.Text -maybeDecodeUtf8 = excToMaybe . TE.decodeUtf8 where - excToMaybe :: a -> Maybe a - excToMaybe x = unsafePerformIO $ Exc.catch - (fmap Just (Exc.evaluate x)) - unicodeError - - unicodeError :: UnicodeException -> IO (Maybe a) - unicodeError _ = return Nothing - -------------------------------------------------------------------------------- --- POSIX -------------------------------------------------------------------------------- - --- | Linux, BSD, OS X, and other UNIX or UNIX-like operating systems. -posix :: Rules B.ByteString -posix = Rules - { rulesName = T.pack "POSIX" - , valid = posixValid - , splitSearchPath = posixSplitSearch - , toText = posixToText - , fromText = posixFromText - , encode = posixToBytes - , decode = posixFromBytes - , encodeString = B8.unpack . posixToBytes - , decodeString = posixFromBytes . B8.pack - } - -posixToText :: FilePath -> Either T.Text T.Text -posixToText p = if good then Right text else Left text where - good = and (map chunkGood chunks) - text = T.concat (root : map chunkText chunks) - - root = rootText (pathRoot p) - chunks = intersperse (Chunk (T.pack "/") True) (directoryChunks False p) - -posixFromChunks :: [Chunk] -> FilePath -posixFromChunks chunks = FilePath root directories basename exts where - (root, pastRoot) = if T.null (chunkText (head chunks)) - then (Just RootPosix, tail chunks) - else (Nothing, chunks) - - (directories, filename) - | P.null pastRoot = ([], Chunk T.empty True) - | otherwise = case last pastRoot of - fn | fn == dot -> (goodDirs pastRoot, Chunk T.empty True) - fn | fn == dots -> (goodDirs pastRoot, Chunk T.empty True) - fn -> (goodDirs (init pastRoot), fn) - - goodDirs = filter (not . T.null . chunkText) - - (basename, exts) = if T.null (chunkText filename) - then (Nothing, []) - else case T.split (== '.') (chunkText filename) of - [] -> (Nothing, []) - (name':exts') -> if chunkGood filename - then (Just (Chunk name' True), map (\e -> Chunk e True) exts') - else (Just (checkChunk name'), map checkChunk exts') - - checkChunk raw = case maybeDecodeUtf8 (B8.pack (T.unpack raw)) of - Just text -> Chunk text True - Nothing -> Chunk raw False - -posixFromText :: T.Text -> FilePath -posixFromText text = if T.null text - then empty - else posixFromChunks (map (\t -> Chunk t True) (T.split (== '/') text)) - -posixToBytes :: FilePath -> B.ByteString -posixToBytes p = B.concat (root : chunks) where - root = TE.encodeUtf8 (rootText (pathRoot p)) - chunks = intersperse (B8.pack "/") (map chunkBytes (directoryChunks True p)) - chunkBytes c = if chunkGood c - then TE.encodeUtf8 (chunkText c) - else B8.pack (T.unpack (chunkText 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 -> Chunk text True - Nothing -> Chunk (T.pack (B8.unpack b)) False - -posixValid :: FilePath -> Bool -posixValid p = validRoot && validDirectories where - validDirectories = all validChunk (directoryChunks True p) - validChunk ch = not (T.any (\c -> c == '\0' || c == '/') (chunkText 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 - -------------------------------------------------------------------------------- --- Windows -------------------------------------------------------------------------------- - --- | Windows and DOS -windows :: Rules T.Text -windows = Rules - { rulesName = T.pack "Windows" - , valid = winValid - , splitSearchPath = winSplit - , toText = Right . winToText - , fromText = winFromText - , encode = winToText - , decode = winFromText - , encodeString = T.unpack . winToText - , decodeString = winFromText . T.pack - } - -winToText :: FilePath -> T.Text -winToText p = T.concat (root : chunks) where - root = rootText (pathRoot p) - chunks = intersperse (T.pack "\\") (map chunkText (directoryChunks False p)) - -winFromText :: T.Text -> FilePath -winFromText text = if T.null text then empty else path where - path = FilePath root directories basename exts - - split = T.split (\c -> c == '/' || c == '\\') text - - (root, pastRoot) = let - head' = head split - tail' = tail split - in if T.null head' - then (Just RootWindowsCurrentVolume, tail') - else if T.any (== ':') head' - then (Just (parseDrive head'), tail') - else (Nothing, split) - - parseDrive = RootWindowsVolume . toUpper . T.head - - (directories, filename) - | P.null pastRoot = ([], T.empty) - | otherwise = case last pastRoot of - fn | fn == chunkText dot -> (goodDirs pastRoot, T.empty) - fn | fn == chunkText dots -> (goodDirs pastRoot, T.empty) - fn -> (goodDirs (init pastRoot), fn) - - goodDirs = map (\t -> Chunk t True) . filter (not . T.null) - - (basename, exts) = if T.null filename - then (Nothing, []) - else case T.split (== '.') filename of - [] -> (Nothing, []) - (name':exts') -> (Just (Chunk name' True), map (\e -> Chunk e True) exts') - -winValid :: FilePath -> Bool -winValid p = validRoot && noReserved && validCharacters where - reservedChars = map chr [0..0x1F] ++ "/\\?*:|\"<>" - reservedNames = map T.pack - [ "AUX", "CLOCK$", "COM1", "COM2", "COM3", "COM4" - , "COM5", "COM6", "COM7", "COM8", "COM9", "CON" - , "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6" - , "LPT7", "LPT8", "LPT9", "NUL", "PRN" - ] - - validRoot = case pathRoot p of - Nothing -> True - Just RootWindowsCurrentVolume -> True - Just (RootWindowsVolume v) -> elem v ['A'..'Z'] - _ -> False - - noExt = p { pathExtensions = [] } - noReserved = flip all (directoryChunks False noExt) - $ \fn -> notElem (T.toUpper (chunkText fn)) reservedNames - - validCharacters = flip all (directoryChunks False p) - $ not . T.any (`elem` reservedChars) . chunkText - -winSplit :: T.Text -> [FilePath] -winSplit = map winFromText . filter (not . T.null) . T.split (== ';') diff --git a/system-filepath.cabal b/system-filepath.cabal --- a/system-filepath.cabal +++ b/system-filepath.cabal @@ -1,5 +1,5 @@ name: system-filepath -version: 0.4.1 +version: 0.4.2 synopsis: High-level, byte-based file and directory path manipulations license: MIT license-file: license.txt @@ -13,6 +13,10 @@ homepage: https://john-millikin.com/software/hs-filepath/ bug-reports: mailto:jmillikin@gmail.com +extra-source-files: + tests/system-filepath-tests.cabal + tests/Tests.hs + source-repository head type: bzr location: https://john-millikin.com/software/hs-filepath/ @@ -20,11 +24,11 @@ source-repository this type: bzr location: https://john-millikin.com/branches/hs-filepath/0.4/ - tag: system-filepath_0.4.1 + tag: system-filepath_0.4.2 library ghc-options: -Wall -O2 - hs-source-dirs: src + hs-source-dirs: lib build-depends: base >= 3 && < 5 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (tests, main) where + +import Prelude hiding (FilePath) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import Data.List (intercalate) +import qualified Data.Text as T +import Data.Text (Text) +import Test.Chell +import Test.Chell.QuickCheck +import Test.QuickCheck hiding (property) + +import Filesystem.Path as P +import Filesystem.Path.CurrentOS () +import Filesystem.Path.Rules + +main :: IO () +main = Test.Chell.defaultMain tests + +tests :: [Suite] +tests = + [ + -- Basic properties + test_Empty + , test_Root + , test_Directory + , test_Parent + , test_Filename + , test_Dirname + , test_Basename + , test_Absolute + , test_Relative + + -- Basic operations + , test_Append + , test_CommonPrefix + , test_StripPrefix + , property "stripPrefix" prop_StripPrefix + , test_SplitExtension + , test_Collapse + + , suite "to-from-bytes" + [ test_Identity "posix" posix posixPaths + , test_Identity "windows" windows windowsPaths + , test_MixedValidityToBytes + ] + + , suite "to-from-text" + [ test_ToText + , test_FromText + ] + + , suite "validity" + [ property "posix" (forAll posixPaths (valid posix)) + , property "windows" (forAll windowsPaths (valid windows)) + ] + + , test_SplitSearchPath + , test_Parsing + , test_EncodeString + , test_DecodeString + , test_EqualsIgnoresPosixEncoding + ] + +test_Empty :: Suite +test_Empty = assertions "empty" $ do + $expect $ P.null empty + $expect $ equal (toChar8 empty) "" + $expect $ equal (toString empty) "" + +test_Root :: Suite +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 :: Suite +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 :: Suite +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 :: Suite +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 :: Suite +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", "\xDD\xAA"] + +test_Basename :: Suite +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_posix ".") "" + $expect $ equal (basename_posix "..") "" + + $expect $ equal (basename_windows "c:\\foo\\bar") "bar" + $expect $ equal (basename_windows "c:\\foo\\bar.txt") "bar" + $expect $ equal (basename_windows ".") "" + $expect $ equal (basename_windows "..") "" + +test_Absolute :: Suite +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 :: Suite +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_Identity :: Text -> Rules a -> Gen FilePath -> Suite +test_Identity name r gen = property name $ forAll gen $ \p -> p == decode r (encode r p) + +test_MixedValidityToBytes :: Suite +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 :: Suite +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.\xDD\xAA/foo")) + +test_FromText :: Suite +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 :: Suite +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 :: Suite +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 :: Suite +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 :: Suite +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 :: Suite +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/" + +test_Parsing :: Suite +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 "..\\") "..\\" + +test_SplitSearchPath :: Suite +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"] + +test_EncodeString :: Suite +test_EncodeString = suite "encodeString" + [ test_EncodeString_Posix + , test_EncodeString_Posix_Ghc702 + , test_EncodeString_Win32 + ] + +test_EncodeString_Posix :: Suite +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 :: Suite +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\xA1\xA2" + $expect $ equal (enc (fromChar8 "\xC2\xA1\xC2\xA2/test\xA1\xA2")) "\xA1\xA2/test\xA1\xA2" + $expect $ equal (enc (fromText posix_ghc702 "test\xA1\xA2")) "test\xA1\xA2" + +test_EncodeString_Win32 :: Suite +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" + +test_DecodeString :: Suite +test_DecodeString = suite "decodeString" + [ test_DecodeString_Posix + , test_DecodeString_Posix_Ghc702 + , test_DecodeString_Win32 + ] + +test_DecodeString_Posix :: Suite +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 :: Suite +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") + +test_DecodeString_Win32 :: Suite +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 :: Suite +test_EqualsIgnoresPosixEncoding = assertions "equals-ignores-posix-encoding" $ do + $expect $ equal + (fromChar8 "test\xA1\xA2") + (fromText posix "test\xA1\xA2") + +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 = 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 c reservedNames) + component = do + size <- choose (0, 10) + vectorOf size $ arbitrary `suchThat` validChar + genComponents n = do + cs <- vectorOf n (component `suchThat` validComponent) + frequency [(1, return cs), (9, return ([""] ++ cs))] + + genRoot = do + let upperChar = elements ['A'..'Z'] + label <- frequency [(1, return Nothing), (9, fmap Just upperChar)] + return $ case label of + Just c -> [c, ':', '\\'] + Nothing -> "\\" + +toChar8 :: FilePath -> String +toChar8 = B8.unpack . encode posix + +fromChar8 :: String -> FilePath +fromChar8 = decode posix . B8.pack + +toString :: FilePath -> String +toString = T.unpack . encode windows + +fromString :: String -> FilePath +fromString = decode windows . T.pack diff --git a/tests/system-filepath-tests.cabal b/tests/system-filepath-tests.cabal new file mode 100644 --- /dev/null +++ b/tests/system-filepath-tests.cabal @@ -0,0 +1,24 @@ +name: system-filepath-tests +version: 0 +build-type: Simple +cabal-version: >= 1.6 + +flag coverage + default: False + manual: True + +executable system-filepath_tests + main-is: Tests.hs + ghc-options: -Wall + hs-source-dirs: ../lib,. + + if flag(coverage) + ghc-options: -fhpc + + build-depends: + base > 3 && < 5 + , bytestring + , chell >= 0.2 && < 0.3 + , chell-quickcheck >= 0.1 && < 0.2 + , QuickCheck + , text