diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2009, Ben Moseley +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Ben Moseley nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY BEN MOSELEY ''AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL BEN MOSELEY BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/System/Path.hs b/System/Path.hs new file mode 100644 --- /dev/null +++ b/System/Path.hs @@ -0,0 +1,830 @@ +{-# LANGUAGE EmptyDataDecls, PatternGuards, FlexibleInstances, Rank2Types #-} + +-- | This module provides type-safe access to filepath manipulations. +-- +-- It is designed to be imported instead of 'System.FilePath' and +-- 'System.Directory'. (It is intended to provide versions of +-- functions from those modules which have equivalent functionality +-- but are more typesafe). +-- +-- The heart of this module is the @Path ar fd@ abstract type which +-- represents file and directory paths. The idea is that there are +-- two phantom type parameters - the first should be 'Abs' or 'Rel', +-- and the second 'File' or 'Dir'. A number of type synonyms are +-- provided for common types: +-- +-- > type AbsFile = Path Abs File +-- > type RelFile = Path Rel File +-- > type AbsDir = Path Abs Dir +-- > type RelDir = Path Rel Dir +-- > type RelPath fd = Path Rel fd +-- > type DirPath ar = Path ar Dir +-- +-- The type of the 'combine' (aka '') function gives the idea: +-- +-- > () :: DirPath ar -> RelPath fd -> Path ar fd +-- +-- Together this enables us to give more meaningful types to +-- a lot of the functions, and (hopefully) catch a bunch more +-- errors at compile time. +-- +-- The basic API (and properties satisfied) are heavily influenced +-- by Neil Mitchell's 'System.FilePath' module. +-- +-- +-- WARNING --- THE API IS NOT YET STABLE --- WARNING +-- +-- +-- Ben Moseley - (c) Jan 2009 +-- +module System.Path +( + -- * The main filepath (& dirpath) abstract type + Path, -- kept abstract + + -- * Phantom Types + Abs, + Rel, + File, + Dir, + + -- * Type Synonyms + AbsFile, + RelFile, + AbsDir, + RelDir, + AbsPath, + RelPath, + FilePath, + DirPath, + + -- * Path to String conversion + getPathString, + + -- * Constants + rootDir, + currentDir, + + -- * Unchecked Construction Functions + mkPath, + mkRelFile, + mkRelDir, + mkAbsFile, + mkAbsDir, + mkRelPath, + mkAbsPath, + mkFile, + mkDir, + + -- * Checked Construction Functions + mkPathAbsOrRel, + mkPathFileOrDir, + + -- * Basic Manipulation Functions + (), + (<.>), + addExtension, + combine, + dropExtension, + dropExtensions, + dropFileName, + replaceExtension, + replaceBaseName, + replaceDirectory, + replaceFileName, + splitExtension, + splitExtensions, + splitFileName, + takeBaseName, + takeDirectory, + takeExtension, + takeExtensions, + takeFileName, + + -- * Auxillary Manipulation Functions + equalFilePath, + joinPath, + normalise, + splitDirectories, + splitPath, + makeRelative, + + -- * Path Predicates + isAbsolute, + isAbsoluteString, + isRelative, + isRelativeString, + hasExtension, + + -- * Separators + addTrailingPathSeparator, + dropTrailingPathSeparator, + extSeparator, + hasTrailingPathSeparator, + pathSeparator, + pathSeparators, + searchPathSeparator, + isExtSeparator, + isPathSeparator, + isSearchPathSeparator, + + -- * Flexible Manipulation Functions + addFileOrDirExtension, + dropFileOrDirExtension, + dropFileOrDirExtensions, + splitFileOrDirExtension, + splitFileOrDirExtensions, + takeFileOrDirExtension, + takeFileOrDirExtensions, + + -- * System.Directory replacements + 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 + + +------------------------------------------------------------------------ +-- Types + +data Abs +data Rel +data File +data Dir + +-- | This is the main filepath abstract datatype +data Path ar fd = PathRoot -- ^ Invariant - this should always have type :: DirPath ar + | 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 + + +------------------------------------------------------------------------ +-- Type classes and machinery for switching on Abs/Rel and File/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 + + +------------------------------------------------------------------------ +-- Read & Show instances + +instance AbsRelClass ar => Show (Path ar fd) where + showsPrec d x@PathRoot = absRel (const $ showString pathSeparators) + (const $ showString ".") x + -- we need the clause below so that we don't duplicate the pathSeparator after an abs + -- root and we don't want to display a "./" prefix on relative paths + 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 + +-- This instance consumes all remaining input. Would it be better to, say, +-- give up at newlines or some set of non-allowable chars? +instance AbsRelClass ar => Read (Path ar fd) where + readsPrec _ s = [(mkPath s,"")] + +-- | Convert the 'Path' into a plain 'String'. This is simply an +-- alias for 'show'. +getPathString :: AbsRelClass ar => Path ar fd -> String +getPathString = show + +prop_mkPath_getPathString :: AbsFile -> Property +prop_mkPath_getPathString p = property $ p == mkPath (getPathString p) + + +------------------------------------------------------------------------ +-- Constants + +rootDir :: AbsDir +rootDir = PathRoot + +currentDir :: RelDir +currentDir = PathRoot + + +------------------------------------------------------------------------ +-- Unchecked Construction Functions +-- NB - these construction functions are pure and do no checking!! + +-- | Convert a 'String' into a 'Path' whose type is determined +-- by its context. +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 + + +------------------------------------------------------------------------ +-- Checked Construction Functions + +-- | Examines the supplied string and constructs an absolute or +-- relative path as appropriate. +mkPathAbsOrRel :: String -> Either (AbsPath fd) (RelPath fd) +mkPathAbsOrRel s | isAbsoluteString s = Left (mkPath s) + | otherwise = Right (mkPath s) + +-- | Searches for a file or directory with the supplied path string +-- and returns a 'File' or 'Dir' path as appropriate. If neither exists +-- at the supplied path, 'Nothing' is returned. +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" + +-- | Lift a function which can operate on either Abs or Rel Path to one which +-- operates on Strings +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) + +-- prop_mkAbsFromRel_startSameAbs :: AbsDir -> AbsFile -> Property +-- prop_mkAbsFromRel_startSameAbs base p = property $ show base `isPrefixOf` show (mkAbsFrom base p) + + +------------------------------------------------------------------------ +-- Internal Functions for PathComponent manipulation + +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 + + + +------------------------------------------------------------------------ +-- Basic Manipulation Functions + +-- | Join an (absolute or relative) directory path with a relative +-- (file or directory) path to form a new path. +() :: 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 + +-- | We only allow files (and not directories) to have extensions added +-- by this function. This is because it's the vastly common case and +-- an attempt to add one to a directory will - more often than not - +-- represent an error. +-- We don't however want to prevent the corresponding operation on +-- directories, and so we provide a function that is more flexible: +-- 'addFileOrDirExtension'. +(<.>) :: FilePath ar -> String -> FilePath ar +(<.>) = addFileOrDirExtension + +-- | Add an extension, even if there is already one there. +-- E.g. @addExtension \"foo.txt\" \"bat\" -> \"foo.txt.bat\"@. +-- +-- >> addExtension (mkFile "file.txt") "bib" == (mkFile "file.txt.bib") +-- >> addExtension (mkFile "file.") ".bib" == (mkFile "file..bib") +-- >> addExtension (mkFile "file") ".bib" == (mkFile "file.bib") +-- >> takeFileName (addExtension (mkFile "") "ext") == mkFile ".ext" +-- > Windows: addExtension "\\\\share" ".txt" == "\\\\share\\.txt" +addExtension :: FilePath ar -> String -> FilePath ar +addExtension = (<.>) + +-- | Join an (absolute or relative) directory path with a relative +-- (file or directory) path to form a new path. +combine :: DirPath ar -> RelPath fd -> Path ar fd +combine = () + + +-- | Remove last extension, and the \".\" preceding it. +-- +-- >> dropExtension x == fst (splitExtension x) +dropExtension :: FilePath ar -> FilePath ar +dropExtension = fst . splitExtension + +-- | Drop all extensions +-- +-- >> not $ hasExtension (dropExtensions x) +dropExtensions :: FilePath ar -> FilePath ar +dropExtensions = fst . splitExtensions + +dropFileName :: Path ar fd -> DirPath ar +dropFileName = fst . splitFileName + + +-- | Set the extension of a file, overwriting one if already present. +-- +-- >> replaceExtension (mkFile "file.txt") ".bob" == (mkFile "file.bob") +-- >> replaceExtension (mkFile "file.txt") "bob" == (mkFile "file.bob") +-- >> replaceExtension (mkFile "file") ".bob" == (mkFile "file.bob") +-- >> replaceExtension (mkFile "file.txt") "" == (mkFile "file") +-- >> replaceExtension (mkFile "file.fred.bob") "txt" == (mkFile "file.fred.txt") +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 + + +-- | Split on the extension. 'addExtension' is the inverse. +-- +-- >> uncurry (<.>) (splitExtension x) == x +-- >> uncurry addExtension (splitExtension x) == x +-- >> splitExtension (mkFile "file.txt") == (mkFile "file",".txt") +-- >> splitExtension (mkFile "file") == (mkFile "file","") +-- >> splitExtension (mkFile "file/file.txt") == (mkFile "file/file",".txt") +-- >> splitExtension (mkFile "file.txt/boris") == (mkFile "file.txt/boris","") +-- >> splitExtension (mkFile "file.txt/boris.ext") == (mkFile "file.txt/boris",".ext") +-- >> splitExtension (mkFile "file/path.txt.bob.fred") == (mkFile "file/path.txt.bob",".fred") +splitExtension :: FilePath ar -> (FilePath ar, String) +splitExtension = splitFileOrDirExtension + +-- | Split on all extensions +-- +-- >> splitExtensions (mkFile "file.tar.gz") == (mkFile "file",".tar.gz") +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 + +-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. +-- +-- >> takeExtension x == snd (splitExtension x) +-- >> takeExtension (addExtension x "ext") == ".ext" +-- >> takeExtension (replaceExtension x "ext") == ".ext" +takeExtension :: FilePath ar -> String +takeExtension = snd . splitExtension + +-- | Get all extensions +-- +-- >> takeExtensions (mkFile "file.tar.gz") == ".tar.gz" +takeExtensions :: FilePath ar -> String +takeExtensions = snd . splitExtensions + +takeFileName :: Path ar fd -> RelPath fd +takeFileName PathRoot = PathRoot -- becomes a relative root +takeFileName (FileDir _ pc) = FileDir PathRoot pc + +prop_takeFileName_end :: AbsFile -> Property +prop_takeFileName_end p = property $ show (takeFileName p) `isSuffixOf` show p + + +------------------------------------------------------------------------ +-- Auxillary Manipulation Functions + +equalFilePath :: String -> String -> Bool +equalFilePath s1 s2 = mkPath s1 == mkPath s2 + +-- | Constructs a 'Path' from a list of components. +joinPath :: [String] -> Path ar fd +joinPath = mkPathFromComponents . map PathComponent + +-- | Currently just transforms: +-- +-- >> normalise (mkFile "/tmp/fred/./jim/./file") == mkFile "/tmp/fred/jim/file" +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 + +------------------------------------------------------------------------ +-- NYI - Not Yet Implemented + +{- +splitSearchPath :: String -> [String] +getSearchPath :: IO [String] +splitDrive :: String -> (String, String) +joinDrive :: String -> String -> String +takeDrive :: String -> String +hasDrive :: String -> Bool +dropDrive :: String -> String +isDrive :: String -> Bool +isValid :: String -> Bool +makeValid :: String -> String +-} + + +------------------------------------------------------------------------ +-- Path Predicates + +isAbsolute :: AbsRelClass ar => Path ar fd -> Bool +isAbsolute = absRel (const True) (const False) + +isAbsoluteString :: String -> Bool +isAbsoluteString [] = False -- Treat the empty string as relative because it doesn't start with 'pathSeparators' +isAbsoluteString (x:_) = any (== x) pathSeparators -- Absolute if first char is a path separator + +-- | Invariant - this should return True iff arg is of type @Path Rel _@ +isRelative :: AbsRelClass ar => Path ar fd -> Bool +isRelative = not . isAbsolute + +isRelativeString :: String -> Bool +isRelativeString = not . isAbsoluteString + + +-- | Does the given filename have an extension? +-- +-- >> null (takeExtension x) == not (hasExtension x) +hasExtension :: FilePath ar -> Bool +hasExtension = not . null . snd . splitExtension + + +------------------------------------------------------------------------ +-- Separators + +-- | This is largely for 'System.FilePath' compatability +addTrailingPathSeparator :: String -> String +addTrailingPathSeparator = (++[pathSeparator]) + +-- | This is largely for 'System.FilePath' compatability +dropTrailingPathSeparator :: String -> String +dropTrailingPathSeparator = init + +-- | File extension character +-- +-- >> extSeparator == '.' +extSeparator :: Char +extSeparator = '.' + +-- | This is largely for 'System.FilePath' compatability +hasTrailingPathSeparator :: String -> Bool +hasTrailingPathSeparator = isPathSeparator . last + +-- | The character that separates directories. In the case where more than +-- one character is possible, 'pathSeparator' is the \'ideal\' one. +-- +-- > Windows: pathSeparator == '\\' +-- > Posix: pathSeparator == '/' +-- >> isPathSeparator pathSeparator +pathSeparator :: Char +pathSeparator = '/' + +-- | The list of all possible separators. +-- +-- > Windows: pathSeparators == ['\\', '/'] +-- > Posix: pathSeparators == ['/'] +-- >> pathSeparator `elem` pathSeparators +pathSeparators :: [Char] +pathSeparators = return pathSeparator + +-- | The character that is used to separate the entries in the $PATH environment variable. +-- +-- > Windows: searchPathSeparator == ';' +-- > Posix: searchPathSeparator == ':' +searchPathSeparator :: Char +searchPathSeparator = ':' + +-- | Is the character an extension character? +-- +-- >> isExtSeparator a == (a == extSeparator) +isExtSeparator :: Char -> Bool +isExtSeparator = (== extSeparator) + +-- | Rather than using @(== 'pathSeparator')@, use this. Test if something +-- is a path separator. +-- +-- >> isPathSeparator a == (a `elem` pathSeparators) +isPathSeparator :: Char -> Bool +isPathSeparator = (== pathSeparator) + +-- | Is the character a file separator? +-- +-- >> isSearchPathSeparator a == (a == searchPathSeparator) +isSearchPathSeparator :: Char -> Bool +isSearchPathSeparator = (== searchPathSeparator) + + +------------------------------------------------------------------------ +-- Flexible Manipulation Functions + +-- These functions support manipulation of extensions on directories +-- as well as files. They have looser types than the corresponding +-- 'Basic Manipulation Functions', but it is expected that the basic +-- functions will be used more frequently as they provide more checks. + +-- | This is a more flexible variant of 'addExtension' / @<.>@ which can +-- work with files or directories +-- +-- >> addFileOrDirExtension (mkFile "/") "x" == (mkFile "/.x") +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 + + +------------------------------------------------------------------------ +-- System.Directory replacements + +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 + +-- | Retrieve the contents of a directory path (which may be relative) as absolute paths +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) + +-- | Returns paths relative /to/ the supplied (abs or relative) directory path. +-- eg (for current working directory of @\/somewhere\/cwd\/@): +-- +-- > show (relDirectoryContents (mkRelDir "subDir1")) == (["subDir1A","subDir1B"], +-- > ["file1A","file1B"]) +-- +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) + +{- +findExecutable :: String -> IO (Maybe FilePath) +getPermissions :: FilePath -> IO Permissions +setPermissions :: FilePath -> Permissions -> IO () +getModificationTime :: FilePath -> IO ClockTime +-} + + +------------------------------------------------------------------------ +-- QuickCheck + +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] ] + +-- test :: Testable a => a -> IO () +-- test = quickCheck + +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]) + +-- qcPath :: (AbsRelClass ar, FileDirClass fd) => Gen (Path ar fd) +-- qcPath = absRel + +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" + + diff --git a/pathtype.cabal b/pathtype.cabal new file mode 100644 --- /dev/null +++ b/pathtype.cabal @@ -0,0 +1,50 @@ +Name: pathtype +Version: 0.0.1 +Synopsis: Type-safe replacement for System.FilePath etc +Description: This module provides type-safe access to filepath manipulations. + . + It is designed to be imported instead of 'System.FilePath' and + 'System.Directory' and is intended to provide versions of + functions from those modules which have equivalent functionality + but are more typesafe. + . + The heart of this module is the @Path ar fd@ abstract type which + represents file and directory paths. The idea is that there are + two phantom type parameters - the first should be 'Abs' or 'Rel', + and the second 'File' or 'Dir'. A number of type synonyms are + provided for common types: + . + > type AbsFile = Path Abs File + > type RelFile = Path Rel File + > type AbsDir = Path Abs Dir + > type RelDir = Path Rel Dir + > type RelPath fd = Path Rel fd + > type DirPath ar = Path ar Dir + . + The type of the 'combine' (aka '') function gives the idea: + . + > () :: DirPath ar -> RelPath fd -> Path ar fd + . + Together this enables us to give more meaningful types to + a lot of the functions, and (hopefully) catch a bunch more + errors at compile time. + . + The basic API (and properties satisfied) are heavily influenced + by Neil Mitchell's 'System.FilePath' module. + . + WARNING -- THE API IS NOT YET STABLE -- WARNING + +Stability: experimental +License: BSD3 +Category: System +License-file: LICENSE +Author: Ben Moseley +Maintainer: ben@moseley.name +Build-Type: Simple +Cabal-Version: >=1.2 + +Library + Build-Depends: base >= 3 && < 5, directory >= 1 && < 2, QuickCheck >= 1.2 && < 2 + Exposed-modules: + System.Path + Extensions: EmptyDataDecls, PatternGuards, FlexibleInstances, Rank2Types