diff --git a/Filesystem/Path.hs b/Filesystem/Path.hs new file mode 100644 --- /dev/null +++ b/Filesystem/Path.hs @@ -0,0 +1,277 @@ +-- | +-- 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 + , basename + , absolute + , relative + + -- * Basic operations + , append + , () + , concat + , commonPrefix + , 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 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 = if absolute y then y else xy where + 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 @\".\"@ 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/Filesystem/Path/CurrentOS.hs b/Filesystem/Path/CurrentOS.hs new file mode 100644 --- /dev/null +++ b/Filesystem/Path/CurrentOS.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE CPP #-} + +-- | +-- 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 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/Filesystem/Path/Internal.hs b/Filesystem/Path/Internal.hs new file mode 100644 --- /dev/null +++ b/Filesystem/Path/Internal.hs @@ -0,0 +1,156 @@ +{-# 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/Filesystem/Path/Rules.hs b/Filesystem/Path/Rules.hs new file mode 100644 --- /dev/null +++ b/Filesystem/Path/Rules.hs @@ -0,0 +1,232 @@ +-- | +-- 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/lib/Filesystem/Path.hs b/lib/Filesystem/Path.hs deleted file mode 100644 --- a/lib/Filesystem/Path.hs +++ /dev/null @@ -1,341 +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.3.2 -dirname :: FilePath -> FilePath -dirname p = case reverse (pathDirectories p) of - [] -> FilePath Nothing [] Nothing [] - (d:_) -> case parseFilename d of - (base, exts) -> FilePath Nothing [] base 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 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.3.2 -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 unescape' . 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 ++ map escape 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 deleted file mode 100644 --- a/lib/Filesystem/Path/CurrentOS.hs +++ /dev/null @@ -1,149 +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) || defined(CABAL_OS_DARWIN) -#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 -#elif defined(CABAL_OS_DARWIN) -#if __GLASGOW_HASKELL__ >= 702 -currentOS = R.darwin_ghc702 -#else -currentOS = R.darwin -#endif -#else -#if __GLASGOW_HASKELL__ >= 704 -currentOS = R.posix_ghc704 -#elif __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 deleted file mode 100644 --- a/lib/Filesystem/Path/Internal.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# 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 Control.DeepSeq (NFData, rnf) -import qualified Control.Exception as Exc -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import Data.Char (chr, ord) -import Data.Data (Data) -import Data.List (intersperse) -import Data.Ord (comparing) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Text.Encoding.Error (UnicodeException) -import Data.Typeable (Typeable) -import System.IO.Unsafe (unsafePerformIO) - -------------------------------------------------------------------------------- --- File Paths -------------------------------------------------------------------------------- - -type Chunk = String -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 (Data, Typeable) - -instance Eq FilePath where - 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) - )) - -instance NFData Root where - rnf (RootWindowsVolume c) = rnf c - rnf _ = () - -instance NFData FilePath where - 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 -empty = FilePath Nothing [] Nothing [] - -dot :: Chunk -dot = "." - -dots :: Chunk -dots = ".." - -filenameChunk :: FilePath -> Chunk -filenameChunk p = concat (name:exts) where - name = maybe "" id (pathBasename p) - exts = case pathExtensions p of - [] -> [] - exts' -> intersperse dot ("":exts') - -------------------------------------------------------------------------------- --- 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)) - -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 -#else -textSplitBy = T.splitBy -#endif - -parseFilename :: Chunk -> (Maybe Basename, [Extension]) -parseFilename filename = parsed where - parsed = if null filename - then (Nothing, []) - else case splitBy (== '.') filename of - [] -> (Nothing, []) - (name':exts') -> (Just name', exts') - -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 diff --git a/lib/Filesystem/Path/Rules.hs b/lib/Filesystem/Path/Rules.hs deleted file mode 100644 --- a/lib/Filesystem/Path/Rules.hs +++ /dev/null @@ -1,330 +0,0 @@ --- | --- Module: Filesystem.Path.Rules --- Copyright: 2010 John Millikin --- License: MIT --- --- Maintainer: jmillikin@gmail.com --- 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 - ) where - -import Prelude hiding (FilePath, null) -import qualified Prelude as P - -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import Data.Char (toUpper, chr, ord) -import Data.List (intersperse, intercalate) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import System.IO () - -import Filesystem.Path hiding (root, filename, basename) -import Filesystem.Path.Internal - -------------------------------------------------------------------------------- --- Generic -------------------------------------------------------------------------------- - -rootChunk :: Maybe Root -> Chunk -rootChunk r = flip (maybe "") r $ \r' -> case r' of - RootPosix -> "/" - RootWindowsVolume c -> c : ":\\" - RootWindowsCurrentVolume -> "\\" - -rootText :: Maybe Root -> T.Text -rootText = T.pack . rootChunk - -directoryChunks :: FilePath -> [Chunk] -directoryChunks path = pathDirectories path ++ [filenameChunk path] - -------------------------------------------------------------------------------- --- POSIX -------------------------------------------------------------------------------- - --- | Linux, BSD, 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, and other UNIX or UNIX-like operating systems. --- --- This is a variant of 'posix' for use with GHC 7.2, which tries to decode --- file paths in its IO computations. --- --- Since: 0.3.3 -posix_ghc702 :: Rules B.ByteString -posix_ghc702 = posix - { rulesName = T.pack "POSIX (GHC 7.2)" - , 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 -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) - 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 - -posixFromText :: T.Text -> FilePath -posixFromText text = if T.null 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 - -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 - -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) - -posixToGhc702String :: FilePath -> String -posixToGhc702String p = P.concat (root : chunks) where - 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) - -posixFromGhc702String :: String -> FilePath -posixFromGhc702String cs = if P.null 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) - -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 (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 - -------------------------------------------------------------------------------- --- Darwin -------------------------------------------------------------------------------- - --- | Darwin and Mac OS X. --- --- This is almost identical to 'posix', but with a native path type of 'T.Text' --- rather than 'B.ByteString'. --- --- Since: 0.3.4 -darwin :: Rules T.Text -darwin = Rules - { rulesName = T.pack "Darwin" - , valid = posixValid - , splitSearchPath = darwinSplitSearch - , toText = Right . darwinToText - , fromText = posixFromText - , encode = darwinToText - , decode = posixFromText - , encodeString = darwinToString - , decodeString = darwinFromString - } - --- | Darwin and Mac OS X. --- --- 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.3.4 -darwin_ghc702 :: Rules T.Text -darwin_ghc702 = darwin - { rulesName = T.pack "Darwin (GHC 7.2)" - , 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)) - -darwinToString :: FilePath -> String -darwinToString = B8.unpack . TE.encodeUtf8 . darwinToText - -darwinFromString :: String -> FilePath -darwinFromString = posixFromText . TE.decodeUtf8 . B8.pack - -darwinSplitSearch :: T.Text -> [FilePath] -darwinSplitSearch = map (posixFromText . normSearch) . textSplitBy (== ':') where - normSearch text = if T.null text then T.pack "." else text - -------------------------------------------------------------------------------- --- 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 unescape' (directoryChunks p)) - -winFromText :: T.Text -> FilePath -winFromText text = if T.null text then empty else path where - path = FilePath root directories basename exts - - split = textSplitBy (\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 = ([], "") - | otherwise = case last pastRoot of - fn | fn == T.pack "." -> (goodDirs pastRoot, "") - fn | fn == T.pack ".." -> (goodDirs pastRoot, "") - fn -> (goodDirs (init pastRoot), escape fn) - - 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 = - [ "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 noExt) - $ \fn -> notElem (map toUpper fn) reservedNames - - validCharacters = flip all (directoryChunks p) - $ not . any (`elem` reservedChars) - -winSplit :: T.Text -> [FilePath] -winSplit = map winFromText . filter (not . T.null) . textSplitBy (== ';') diff --git a/lib/System/FilePath.hs b/lib/System/FilePath.hs deleted file mode 100644 --- a/lib/System/FilePath.hs +++ /dev/null @@ -1,15 +0,0 @@ --- | --- Module: System.FilePath --- Copyright: 2011 John Millikin --- License: MIT --- --- Maintainer: jmillikin@gmail.com --- Portability: portable --- --- Deprecated alias for "Filesystem.Path" --- -module System.FilePath - ( module Filesystem.Path - ) where - -import Filesystem.Path diff --git a/lib/System/FilePath/CurrentOS.hs b/lib/System/FilePath/CurrentOS.hs deleted file mode 100644 --- a/lib/System/FilePath/CurrentOS.hs +++ /dev/null @@ -1,15 +0,0 @@ --- | --- Module: System.FilePath.CurrentOS --- Copyright: 2011 John Millikin --- License: MIT --- --- Maintainer: jmillikin@gmail.com --- Portability: portable --- --- Deprecated alias for "Filesystem.Path.CurrentOS" --- -module System.FilePath.CurrentOS - ( module Filesystem.Path.CurrentOS - ) where - -import Filesystem.Path.CurrentOS diff --git a/lib/System/FilePath/Rules.hs b/lib/System/FilePath/Rules.hs deleted file mode 100644 --- a/lib/System/FilePath/Rules.hs +++ /dev/null @@ -1,15 +0,0 @@ --- | --- Module: System.FilePath.Rules --- Copyright: 2011 John Millikin --- License: MIT --- --- Maintainer: jmillikin@gmail.com --- Portability: portable --- --- Deprecated alias for "Filesystem.Path.Rules" --- -module System.FilePath.Rules - ( module Filesystem.Path.Rules - ) where - -import Filesystem.Path.Rules diff --git a/scripts/common.bash b/scripts/common.bash deleted file mode 100644 --- a/scripts/common.bash +++ /dev/null @@ -1,23 +0,0 @@ -PATH="$PATH:$PWD/cabal-dev/bin/" - -VERSION=$(awk '/^version:/{print $2}' system-filepath.cabal) - -CABAL_DEV=$(which cabal-dev) -XZ=$(which xz) - -require_cabal_dev() -{ - if [ -z "$CABAL_DEV" ]; then - echo "Can't find 'cabal-dev' executable; make sure it exists on your "'$PATH' - echo "Cowardly refusing to fuck with the global package database" - exit 1 - fi -} - -clean_dev_install() -{ - require_cabal_dev - - rm -rf dist - $CABAL_DEV install || exit 1 -} diff --git a/scripts/run-benchmarks b/scripts/run-benchmarks deleted file mode 100644 --- a/scripts/run-benchmarks +++ /dev/null @@ -1,21 +0,0 @@ -#!/bin/bash -if [ ! -f 'system-filepath.cabal' ]; then - echo -n "Can't find system-filepath.cabal; please run this script as" - echo -n " ./scripts/run-benchmarks from within the system-filepath source" - echo " directory" - exit 1 -fi - -. scripts/common.bash - -require_cabal_dev - -rm -rf dist -cabal-dev install || exit 1 - -pushd benchmarks -rm -rf dist -$CABAL_DEV -s ../cabal-dev install || exit 1 -popd - -cabal-dev/bin/system-filepath_benchmarks $@ diff --git a/scripts/run-coverage b/scripts/run-coverage deleted file mode 100644 --- a/scripts/run-coverage +++ /dev/null @@ -1,21 +0,0 @@ -#!/bin/bash -if [ ! -f 'system-filepath.cabal' ]; then - echo -n "Can't find system-filepath.cabal; please run this script as" - echo -n " ./scripts/run-coverage from within the system-filepath source" - echo " directory" - exit 1 -fi - -. scripts/common.bash - -require_cabal_dev - -pushd tests -$CABAL_DEV -s ../cabal-dev install --flags="coverage" || exit 1 -popd - -rm -f system-filepath_tests.tix -cabal-dev/bin/system-filepath_tests $@ - -hpc markup --srcdir=src --srcdir=tests/ system-filepath_tests.tix --destdir=hpc-markup --exclude=Main -hpc report --srcdir=src --srcdir=tests/ system-filepath_tests.tix --exclude=Main diff --git a/scripts/run-tests b/scripts/run-tests deleted file mode 100644 --- a/scripts/run-tests +++ /dev/null @@ -1,17 +0,0 @@ -#!/bin/bash -if [ ! -f 'system-filepath.cabal' ]; then - echo -n "Can't find system-filepath.cabal; please run this script as" - echo -n " ./scripts/run-tests from within the system-filepath source" - echo " directory" - exit 1 -fi - -. scripts/common.bash - -require_cabal_dev - -pushd tests -$CABAL_DEV -s ../cabal-dev install || exit 1 -popd - -cabal-dev/bin/system-filepath_tests $@ diff --git a/system-filepath.cabal b/system-filepath.cabal --- a/system-filepath.cabal +++ b/system-filepath.cabal @@ -1,59 +1,38 @@ name: system-filepath -version: 0.3.7 +version: 0.4 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-2012 +maintainer: jmillikin@gmail.com +copyright: Copyright (c) John Millikin 2010 build-type: Simple cabal-version: >= 1.6 category: System stability: experimental -homepage: https://john-millikin.com/software/haskell-filesystem/ +homepage: https://john-millikin.com/software/hs-filepath/ bug-reports: mailto:jmillikin@gmail.com - -extra-source-files: - scripts/common.bash - scripts/run-benchmarks - scripts/run-coverage - scripts/run-tests - -- - tests/system-filepath-tests.cabal - tests/Tests.hs +tested-with: GHC == 6.12.1 source-repository head type: bzr - location: https://john-millikin.com/branches/system-filepath/0.3/ - -source-repository this - type: bzr - location: https://john-millikin.com/branches/system-filepath/0.3/ - tag: system-filepath_0.3.7 + location: https://john-millikin.com/software/hs-filepath/ library ghc-options: -Wall -O2 - hs-source-dirs: lib build-depends: base >= 3 && < 5 , bytestring >= 0.9 && < 0.10 - , deepseq >= 1.1 && < 1.4 - , text >= 0.7.1 && < 0.12 + , text >= 0.3 && < 0.12 if os(windows) cpp-options: -DCABAL_OS_WINDOWS - if os(darwin) - cpp-options: -DCABAL_OS_DARWIN - exposed-modules: Filesystem.Path Filesystem.Path.CurrentOS Filesystem.Path.Rules - System.FilePath - System.FilePath.CurrentOS - System.FilePath.Rules other-modules: Filesystem.Path.Internal diff --git a/tests/Tests.hs b/tests/Tests.hs deleted file mode 100644 --- a/tests/Tests.hs +++ /dev/null @@ -1,561 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} - -module Main (tests, main) where - -import Prelude hiding (FilePath) - -import qualified Data.ByteString.Char8 as B8 -import Data.Char (toUpper) -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 - , test_InvalidUtf8InDirectoryComponent - , test_Utf8CharInGhcEscapeArea - - , 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_ShowRules - ] - -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", "\x76A"] - -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.\x76A/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_InvalidUtf8InDirectoryComponent :: Suite -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 :: Suite -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 :: 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_Posix_Ghc704 - , 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\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 :: 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 - $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_Posix_Ghc704 - , test_DecodeString_Darwin - , test_DecodeString_Darwin_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") - $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 -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 :: Suite -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 :: 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") - -test_ShowRules :: Suite -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 = 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 (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 deleted file mode 100644 --- a/tests/system-filepath-tests.cabal +++ /dev/null @@ -1,25 +0,0 @@ -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 - , deepseq >= 1.1 && < 1.4 - , QuickCheck - , text