module System.Path
(
Path,
Abs,
Rel,
File,
Dir,
AbsFile,
RelFile,
AbsDir,
RelDir,
AbsPath,
RelPath,
FilePath,
DirPath,
getPathString,
rootDir,
currentDir,
mkPath,
mkRelFile,
mkRelDir,
mkAbsFile,
mkAbsDir,
mkRelPath,
mkAbsPath,
mkFile,
mkDir,
mkPathAbsOrRel,
mkPathFileOrDir,
(</>),
(<.>),
addExtension,
combine,
dropExtension,
dropExtensions,
dropFileName,
replaceExtension,
replaceBaseName,
replaceDirectory,
replaceFileName,
splitExtension,
splitExtensions,
splitFileName,
takeBaseName,
takeDirectory,
takeExtension,
takeExtensions,
takeFileName,
equalFilePath,
joinPath,
normalise,
splitDirectories,
splitPath,
makeRelative,
isAbsolute,
isAbsoluteString,
isRelative,
isRelativeString,
hasExtension,
addTrailingPathSeparator,
dropTrailingPathSeparator,
extSeparator,
hasTrailingPathSeparator,
pathSeparator,
pathSeparators,
searchPathSeparator,
isExtSeparator,
isPathSeparator,
isSearchPathSeparator,
addFileOrDirExtension,
dropFileOrDirExtension,
dropFileOrDirExtensions,
splitFileOrDirExtension,
splitFileOrDirExtensions,
takeFileOrDirExtension,
takeFileOrDirExtensions,
getDirectoryContents,
absDirectoryContents,
relDirectoryContents
)
where
import Prelude hiding (FilePath)
import Control.Applicative
import Control.Arrow
import Data.List
import qualified System.Directory as SD
import System.IO hiding (FilePath)
import System.IO.Error
import Text.Printf
import Test.QuickCheck
data Abs
data Rel
data File
data Dir
data Path ar fd = PathRoot
| FileDir (DirPath ar) PathComponent
deriving (Eq, Ord)
newtype PathComponent = PathComponent { unPathComponent :: String } deriving (Eq,Ord)
instance Show PathComponent where showsPrec _ (PathComponent s) = showString s
pcMap :: (String -> String) -> PathComponent -> PathComponent
pcMap f (PathComponent s) = PathComponent (f s)
type AbsFile = Path Abs File
type RelFile = Path Rel File
type AbsDir = Path Abs Dir
type RelDir = Path Rel Dir
type AbsPath fd = Path Abs fd
type RelPath fd = Path Rel fd
type FilePath ar = Path ar File
type DirPath ar = Path ar Dir
class AbsRelClass ar where
absRel :: (AbsPath fd -> a) -> (RelPath fd -> a) -> Path ar fd -> a
instance AbsRelClass Abs where absRel f g = f
instance AbsRelClass Rel where absRel f g = g
class FileDirClass fd where
fileDir :: (FilePath ar -> a) -> (DirPath ar -> a) -> Path ar fd -> a
instance FileDirClass File where fileDir f g = f
instance FileDirClass Dir where fileDir f g = g
pathAbsRel :: AbsRelClass ar => Path ar fd -> Either (AbsPath fd) (RelPath fd)
pathAbsRel = absRel Left Right
instance AbsRelClass ar => Show (Path ar fd) where
showsPrec d x@PathRoot = absRel (const $ showString pathSeparators)
(const $ showString ".") x
showsPrec d x@(FileDir p@PathRoot pc) = absRel (const $ showString pathSeparators)
(const id)
p .
showsPrec d pc
showsPrec d x@(FileDir p pc) = showsPrec d p . showString pathSeparators .
showsPrec d pc
instance AbsRelClass ar => Read (Path ar fd) where
readsPrec _ s = [(mkPath s,"")]
getPathString :: AbsRelClass ar => Path ar fd -> String
getPathString = show
prop_mkPath_getPathString :: AbsFile -> Property
prop_mkPath_getPathString p = property $ p == mkPath (getPathString p)
rootDir :: AbsDir
rootDir = PathRoot
currentDir :: RelDir
currentDir = PathRoot
mkPath :: String -> Path ar fd
mkPath = mkPathFromComponents . mkPathComponents
mkRelFile :: String -> RelFile
mkRelFile = mkPath
mkRelDir :: String -> RelDir
mkRelDir = mkPath
mkAbsFile :: String -> AbsFile
mkAbsFile = mkPath
mkAbsDir :: String -> AbsDir
mkAbsDir = mkPath
mkRelPath :: String -> RelPath fd
mkRelPath = mkPath
mkAbsPath :: String -> AbsPath fd
mkAbsPath = mkPath
mkFile :: String -> FilePath ar
mkFile = mkPath
mkDir :: String -> DirPath ar
mkDir = mkPath
mkPathAbsOrRel :: String -> Either (AbsPath fd) (RelPath fd)
mkPathAbsOrRel s | isAbsoluteString s = Left (mkPath s)
| otherwise = Right (mkPath s)
mkPathFileOrDir :: AbsRelClass ar => String -> IO (Maybe (Either (FilePath ar) (DirPath ar)))
mkPathFileOrDir s = do
isfile <- doesFileExist `onPathString` s
isdir <- doesDirectoryExist `onPathString` s
case (isfile, isdir) of
(False, False) -> return Nothing
(True, False) -> return $ Just $ Left $ mkPath s
(False, True ) -> return $ Just $ Right $ mkPath s
(True, True ) -> ioError $ userError "mkPathFileOrDir - internal inconsistency - file&dir"
onPathString :: (forall ar . AbsRelClass ar => Path ar fd -> a) -> String -> a
onPathString f = (f ||| f) . mkPathAbsOrRel
mkAbsFrom :: AbsRelClass ar => AbsDir -> Path ar fd -> AbsPath fd
mkAbsFrom base p = absRel id (mkAbsFromRel base) p
mkAbsFromRel :: AbsDir -> RelPath fd -> AbsPath fd
mkAbsFromRel = (</>)
prop_mkAbsFromRel_endSame :: AbsDir -> RelFile -> Property
prop_mkAbsFromRel_endSame base p = property $ show p `isSuffixOf` show (mkAbsFrom base p)
prop_mkAbsFromRel_startSame :: AbsDir -> RelFile -> Property
prop_mkAbsFromRel_startSame base p = property $ show base `isPrefixOf` show (mkAbsFrom base p)
mkPathFromComponents :: [PathComponent] -> Path ar fd
mkPathFromComponents [] = PathRoot
mkPathFromComponents pcs | (p:ps) <- reverse pcs = FileDir (foldr (flip FileDir) PathRoot ps) p
mkPathComponents :: String -> [PathComponent]
mkPathComponents xs =
case break isPathSeparator (dropWhile isPathSeparator xs) of
("","") -> []
(s,rest) -> PathComponent s : mkPathComponents rest
pathComponents :: Path ar fd -> [PathComponent]
pathComponents PathRoot = []
pathComponents (FileDir p pc) = pathComponents p ++ [pc]
prop_mkPathFromComponents_pathComponents :: AbsFile -> Property
prop_mkPathFromComponents_pathComponents p = property $
mkPathFromComponents (pathComponents p) == p
(</>) :: DirPath ar -> RelPath fd -> Path ar fd
PathRoot </> PathRoot = PathRoot
(FileDir dp dpc) </> PathRoot = FileDir dp dpc
d </> (FileDir p pc) = FileDir (d </> p) pc
(<.>) :: FilePath ar -> String -> FilePath ar
(<.>) = addFileOrDirExtension
addExtension :: FilePath ar -> String -> FilePath ar
addExtension = (<.>)
combine :: DirPath ar -> RelPath fd -> Path ar fd
combine = (</>)
dropExtension :: FilePath ar -> FilePath ar
dropExtension = fst . splitExtension
dropExtensions :: FilePath ar -> FilePath ar
dropExtensions = fst . splitExtensions
dropFileName :: Path ar fd -> DirPath ar
dropFileName = fst . splitFileName
replaceExtension :: FilePath ar -> String -> FilePath ar
replaceExtension p ext = dropExtension p <.> ext
replaceBaseName :: Path ar fd -> String -> Path ar fd
replaceBaseName p bn = takeDirectory p </> (mkPath bn `addFileOrDirExtension` takeFileOrDirExtension p)
replaceDirectory :: Path ar1 fd -> DirPath ar2 -> Path ar2 fd
replaceDirectory p d = d </> takeFileName p
replaceFileName :: Path ar fd -> String -> Path ar fd
replaceFileName p fn = takeDirectory p </> mkPath fn
splitExtension :: FilePath ar -> (FilePath ar, String)
splitExtension = splitFileOrDirExtension
splitExtensions :: FilePath ar -> (FilePath ar, String)
splitExtensions = splitFileOrDirExtensions
prop_splitCombine :: AbsFile -> Property
prop_splitCombine p = property $ p == p2 <.> ext
where
(p2, ext) = splitExtension p
splitFileName :: Path ar fd -> (DirPath ar, RelPath fd)
splitFileName (FileDir p pc) = (p, mkPathFromComponents [pc])
prop_split_combine :: AbsFile -> Property
prop_split_combine p = property $ uncurry combine (splitFileName p) == p
takeBaseName :: Path ar fd -> RelPath fd
takeBaseName = takeFileName . dropFileOrDirExtension
takeDirectory :: Path ar fd -> DirPath ar
takeDirectory = fst . splitFileName
takeExtension :: FilePath ar -> String
takeExtension = snd . splitExtension
takeExtensions :: FilePath ar -> String
takeExtensions = snd . splitExtensions
takeFileName :: Path ar fd -> RelPath fd
takeFileName PathRoot = PathRoot
takeFileName (FileDir _ pc) = FileDir PathRoot pc
prop_takeFileName_end :: AbsFile -> Property
prop_takeFileName_end p = property $ show (takeFileName p) `isSuffixOf` show p
equalFilePath :: String -> String -> Bool
equalFilePath s1 s2 = mkPath s1 == mkPath s2
joinPath :: [String] -> Path ar fd
joinPath = mkPathFromComponents . map PathComponent
normalise :: Path ar fd -> Path ar fd
normalise = mkPathFromComponents . filter (/=(PathComponent ".")) . pathComponents
splitDirectories :: Path ar fd -> [String]
splitDirectories PathRoot = []
splitDirectories p = map unPathComponent . init . pathComponents $ p
splitPath :: Path ar fd -> [String]
splitPath = map unPathComponent . pathComponents
makeRelative :: AbsDir -> AbsPath fd -> RelPath fd
makeRelative relTo orig = maybe err mkPathFromComponents $ stripPrefix relToPC origPC
where
err = error $ printf "System.Path can't make %s relative to %s" (show origPC) (show relToPC)
relToPC = pathComponents relTo
origPC = pathComponents orig
isAbsolute :: AbsRelClass ar => Path ar fd -> Bool
isAbsolute = absRel (const True) (const False)
isAbsoluteString :: String -> Bool
isAbsoluteString [] = False
isAbsoluteString (x:_) = any (== x) pathSeparators
isRelative :: AbsRelClass ar => Path ar fd -> Bool
isRelative = not . isAbsolute
isRelativeString :: String -> Bool
isRelativeString = not . isAbsoluteString
hasExtension :: FilePath ar -> Bool
hasExtension = not . null . snd . splitExtension
addTrailingPathSeparator :: String -> String
addTrailingPathSeparator = (++[pathSeparator])
dropTrailingPathSeparator :: String -> String
dropTrailingPathSeparator = init
extSeparator :: Char
extSeparator = '.'
hasTrailingPathSeparator :: String -> Bool
hasTrailingPathSeparator = isPathSeparator . last
pathSeparator :: Char
pathSeparator = '/'
pathSeparators :: [Char]
pathSeparators = return pathSeparator
searchPathSeparator :: Char
searchPathSeparator = ':'
isExtSeparator :: Char -> Bool
isExtSeparator = (== extSeparator)
isPathSeparator :: Char -> Bool
isPathSeparator = (== pathSeparator)
isSearchPathSeparator :: Char -> Bool
isSearchPathSeparator = (== searchPathSeparator)
addFileOrDirExtension :: Path ar fd -> String -> Path ar fd
addFileOrDirExtension p "" = p
addFileOrDirExtension (FileDir p (PathComponent pc)) ext = FileDir p (PathComponent (pc ++ suffix))
where suffix | "." `isPrefixOf` ext = ext
| otherwise = "." ++ ext
addFileOrDirExtension PathRoot ext = FileDir PathRoot (PathComponent suffix)
where suffix | "." `isPrefixOf` ext = ext
| otherwise = "." ++ ext
dropFileOrDirExtension :: Path ar fd -> Path ar fd
dropFileOrDirExtension = fst . splitFileOrDirExtension
dropFileOrDirExtensions :: Path ar fd -> Path ar fd
dropFileOrDirExtensions = fst . splitFileOrDirExtensions
splitFileOrDirExtension :: Path ar fd -> (Path ar fd, String)
splitFileOrDirExtension (FileDir p (PathComponent s)) = (FileDir p (PathComponent s1), s2)
where (s1,s2) = fixTrailingDot $ rbreak isExtSeparator s
fixTrailingDot ("",r2) = (r2,"")
fixTrailingDot (r1,r2) | [extSeparator] `isSuffixOf` r1 = (init r1, extSeparator:r2)
| otherwise = (r1,r2)
swap (x,y) = (y,x)
rbreak p = (reverse *** reverse) . swap . break p . reverse
splitFileOrDirExtension p = (p,"")
splitFileOrDirExtensions :: Path ar fd -> (Path ar fd, String)
splitFileOrDirExtensions (FileDir p (PathComponent s)) = (FileDir p (PathComponent s1), s2)
where (s1,s2) = break isExtSeparator s
splitFileOrDirExtensions p = (p,"")
takeFileOrDirExtension :: Path ar fd -> String
takeFileOrDirExtension = snd . splitFileOrDirExtension
takeFileOrDirExtensions :: Path ar fd -> String
takeFileOrDirExtensions = snd . splitFileOrDirExtension
doesFileExist :: AbsRelClass ar => FilePath ar -> IO Bool
doesFileExist = SD.doesFileExist . getPathString
doesDirectoryExist :: AbsRelClass ar => DirPath ar -> IO Bool
doesDirectoryExist = SD.doesDirectoryExist . getPathString
getDirectoryContents :: AbsRelClass ar => DirPath ar -> IO ([AbsDir], [AbsFile])
getDirectoryContents = absDirectoryContents
absDirectoryContents :: AbsRelClass ar => DirPath ar -> IO ([AbsDir], [AbsFile])
absDirectoryContents p = do
cd <- mkAbsDir <$> SD.getCurrentDirectory
let dir = absRel id (cd </>) p
(rds, rfs) <- relDirectoryContents dir
return (map (dir </>) rds, map (dir </>) rfs)
relDirectoryContents :: AbsRelClass ar => DirPath ar -> IO ([RelDir], [RelFile])
relDirectoryContents dir = do
filenames <- filter (not . flip elem [".",".."]) <$> SD.getDirectoryContents (getPathString dir)
dirFlags <- mapM (doesDirectoryExist . (dir </>) . mkPath) filenames
let fileinfo = zip filenames dirFlags
(dirs, files) = partition snd fileinfo
return (map (FileDir currentDir . PathComponent . fst) dirs,
map (FileDir currentDir . PathComponent . fst) files)
filesInDir :: AbsRelClass ar => DirPath ar -> IO [RelFile]
filesInDir dir = snd <$> relDirectoryContents dir
dirsInDir :: AbsRelClass ar => DirPath ar -> IO [RelDir]
dirsInDir dir = fst <$> relDirectoryContents dir
createDirectory :: AbsRelClass ar => DirPath ar -> IO ()
createDirectory = SD.createDirectory . getPathString
createDirectoryIfMissing :: AbsRelClass ar => Bool -> DirPath ar -> IO ()
createDirectoryIfMissing flag = SD.createDirectoryIfMissing flag . getPathString
removeDirectory :: AbsRelClass ar => DirPath ar -> IO ()
removeDirectory = SD.removeDirectory . getPathString
removeDirectoryRecursive :: AbsRelClass ar => DirPath ar -> IO ()
removeDirectoryRecursive = SD.removeDirectoryRecursive . getPathString
getCurrentDirectory :: IO AbsDir
getCurrentDirectory = mkAbsDir <$> SD.getCurrentDirectory
setCurrentDirectory :: AbsRelClass ar => FilePath ar -> IO ()
setCurrentDirectory = SD.setCurrentDirectory . getPathString
getHomeDirectory :: IO AbsDir
getHomeDirectory = mkAbsDir <$> SD.getHomeDirectory
getUserDocumentsDirectory :: IO AbsDir
getUserDocumentsDirectory = mkAbsDir <$> SD.getUserDocumentsDirectory
getTemporaryDirectory :: IO AbsDir
getTemporaryDirectory = mkAbsDir <$> SD.getTemporaryDirectory
getAppUserDataDirectory :: String -> IO AbsDir
getAppUserDataDirectory user = mkAbsDir <$> SD.getAppUserDataDirectory user
copyFile :: (AbsRelClass ar1, AbsRelClass ar2) => FilePath ar1 -> FilePath ar2 -> IO ()
copyFile p1 p2 = SD.copyFile (getPathString p1) (getPathString p2)
removeFile :: AbsRelClass ar => FilePath ar -> IO ()
removeFile = SD.removeFile . getPathString
renameFile :: (AbsRelClass ar1, AbsRelClass ar2) => FilePath ar1 -> FilePath ar2 -> IO ()
renameFile p1 p2 = SD.renameFile (getPathString p1) (getPathString p2)
makeRelativeToCurrentDirectory :: AbsRelClass ar => Path ar fd -> IO (RelPath fd)
makeRelativeToCurrentDirectory p = mkPath <$> SD.makeRelativeToCurrentDirectory (getPathString p)
renameDirectory :: (AbsRelClass ar1, AbsRelClass ar2) => DirPath ar1 -> DirPath ar2 -> IO ()
renameDirectory p1 p2 = SD.renameDirectory (getPathString p1) (getPathString p2)
canonicalizePath :: AbsRelClass ar => Path ar fd -> IO (AbsPath fd)
canonicalizePath p = mkPath <$> SD.canonicalizePath (getPathString p)
testall = do
putStrLn "Running QuickCheck tests..."
quickCheck prop_mkPathFromComponents_pathComponents
quickCheck prop_mkAbsFromRel_endSame
quickCheck prop_mkAbsFromRel_startSame
quickCheck prop_split_combine
quickCheck prop_takeFileName_end
quickCheck prop_splitCombine
putStrLn "Tests completed."
vectorOf :: Gen a -> Int -> Gen [a]
vectorOf gen n = sequence [ gen | i <- [1..n] ]
qcFileComponent :: Gen PathComponent
qcFileComponent = PathComponent <$> frequency [
(1, return "someFile"),
(1, return "fileWith.ext"),
(1, return "file.with.multiple.exts"),
(1, return "file with spcs")
]
qcDirComponent :: Gen PathComponent
qcDirComponent = PathComponent <$> frequency [
(1, return "someDir"),
(1, return "aDir"),
(1, return "aFolder"),
(1, return "a folder"),
(1, return "directory")
]
qcFilePath :: Gen (FilePath ar)
qcFilePath = do
numDirs <- arbitrary
pcs <- vectorOf qcDirComponent numDirs
pc <- qcFileComponent
return $ mkPathFromComponents (pcs ++ [pc])
qcDirPath :: Gen (DirPath ar)
qcDirPath = do
numDirs <- arbitrary
pcs <- vectorOf qcDirComponent numDirs
pc <- qcDirComponent
return $ mkPathFromComponents (pcs ++ [pc])
instance Arbitrary PathComponent where
arbitrary = oneof [qcFileComponent, qcDirComponent]
coarbitrary = error "No PathComponent coarbitrary"
instance Arbitrary (Path ar File) where
arbitrary = qcFilePath
coarbitrary = error "No (FilePath ar) coarbitrary"
instance Arbitrary (Path ar Dir) where
arbitrary = qcDirPath
coarbitrary = error "No DirPath coarbitrary"