diff --git a/System/Path.hs b/System/Path.hs --- a/System/Path.hs +++ b/System/Path.hs @@ -1,24 +1,28 @@ -{-# LANGUAGE EmptyDataDecls, PatternGuards, FlexibleInstances, Rank2Types #-} +{-# LANGUAGE EmptyDataDecls, PatternGuards, FlexibleInstances, Rank2Types, OverloadedStrings #-} -- | 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). +-- It is designed to be imported instead of "System.FilePath". +-- (It is intended to provide versions of functions from that +-- module which have equivalent functionality but are more +-- typesafe). "System.Path.Directory" is a companion module +-- providing a type-safe alternative to "System.Directory". -- --- The heart of this module is the @Path ar fd@ abstract type which +-- 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 +-- > 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 -- -- The type of the 'combine' (aka '') function gives the idea: -- @@ -28,15 +32,49 @@ -- 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. +-- Overloaded string literals are supported, so with the @OverloadedStrings@ +-- extension enabled, you can: -- +-- > f :: FilePath ar +-- > f = "tmp" "someFile" <.> "ext" -- --- WARNING --- THE API IS NOT YET STABLE --- WARNING +-- If you don't want to use @OverloadedStrings@, you can use the construction fns: -- +-- > f :: FilePath ar +-- > f = asDirPath "tmp" asFilePath "someFile" <.> "ext" -- --- Ben Moseley - (c) Jan 2009 +-- or... -- +-- > f :: FilePath ar +-- > f = asPath "tmp" asPath "someFile" <.> "ext" +-- +-- or just... +-- +-- > f :: FilePath ar +-- > f = asPath "tmp/someFile.ext" +-- +-- One point to note is that whether one of these is interpreted as +-- an absolute or a relative path depends on the type at which it is +-- used: +-- +-- > *System.Path> f :: AbsFile +-- > /tmp/someFile.ext +-- > *System.Path> f :: RelFile +-- > tmp/someFile.ext +-- +-- You will typically want to import as follows: +-- +-- > import Prelude hiding (FilePath) +-- > import System.Path +-- > import System.Path.Directory +-- > import System.Path.IO +-- +-- The basic API (and properties satisfied) are heavily influenced +-- by Neil Mitchell's "System.FilePath" module. +-- +-- +-- Ben Moseley - (c) 2009 +-- module System.Path ( -- * The main filepath (& dirpath) abstract type @@ -58,6 +96,10 @@ FilePath, DirPath, + -- * Classes + AbsRelClass(..), + FileDirClass(..), + -- * Path to String conversion getPathString, @@ -66,19 +108,21 @@ currentDir, -- * Unchecked Construction Functions - mkPath, - mkRelFile, - mkRelDir, - mkAbsFile, - mkAbsDir, - mkRelPath, - mkAbsPath, - mkFile, - mkDir, + asPath, + asRelFile, + asRelDir, + asAbsFile, + asAbsDir, + asRelPath, + asAbsPath, + asFilePath, + asDirPath, -- * Checked Construction Functions mkPathAbsOrRel, mkPathFileOrDir, + mkAbsPath, + mkAbsPathFromCwd, -- * Basic Manipulation Functions (), @@ -105,15 +149,20 @@ equalFilePath, joinPath, normalise, - splitDirectories, splitPath, makeRelative, + makeAbsolute, + makeAbsoluteFromCwd, + genericMakeAbsolute, + genericMakeAbsoluteFromCwd, + pathMap, -- * Path Predicates isAbsolute, isAbsoluteString, isRelative, isRelativeString, + hasAnExtension, hasExtension, -- * Separators @@ -128,19 +177,14 @@ isPathSeparator, isSearchPathSeparator, - -- * Flexible Manipulation Functions - addFileOrDirExtension, - dropFileOrDirExtension, - dropFileOrDirExtensions, - splitFileOrDirExtension, - splitFileOrDirExtensions, - takeFileOrDirExtension, - takeFileOrDirExtensions, - - -- * System.Directory replacements - getDirectoryContents, - absDirectoryContents, - relDirectoryContents + -- * Generic Manipulation Functions + genericAddExtension, + genericDropExtension, + genericDropExtensions, + genericSplitExtension, + genericSplitExtensions, + genericTakeExtension, + genericTakeExtensions ) where @@ -150,6 +194,7 @@ import Control.Applicative import Control.Arrow import Data.List +import GHC.Exts( IsString(..) ) import qualified System.Directory as SD import System.IO hiding (FilePath) @@ -168,15 +213,13 @@ -- | This is the main filepath abstract datatype data Path ar fd = PathRoot -- ^ Invariant - this should always have type :: DirPath ar - | FileDir (DirPath ar) PathComponent + | FileDir !(DirPath ar) !PathComponent -- The fact that we recurse binding fd to Dir + -- makes this a "nested datatype" 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 @@ -187,26 +230,59 @@ type FilePath ar = Path ar File type DirPath ar = Path ar Dir +-- I don't think this basic type of fold is appropriate for a nested datatype +-- pathFold :: a -> (a -> String -> a) -> Path ar fd -> a +-- pathFold pr f PathRoot = pr +-- pathFold pr f (FileDir d pc) = f (pathFold pr f d) (unPathComponent pc) +-- | Map over the components of the path. +-- +-- >> pathMap (map toLower) "/tmp/Reports/SpreadSheets" == "/tmp/reports/spreadsheets" +pathMap :: (String -> String) -> Path ar fd -> Path ar fd +pathMap f PathRoot = PathRoot +pathMap f (FileDir d pc) = FileDir (pathMap f d) (pcMap f pc) + +-- Private fn +pcMap :: (String -> String) -> PathComponent -> PathComponent +pcMap f (PathComponent s) = PathComponent (f s) + + ------------------------------------------------------------------------ -- Type classes and machinery for switching on Abs/Rel and File/Dir -class AbsRelClass ar where +-- | This class provides a way to prevent other modules +-- from making further 'AbsRelClass' or 'FileDirClass' +-- instances +class Private p +instance Private Abs +instance Private Rel +instance Private File +instance Private Dir + +-- | This class allows selective behaviour for absolute and +-- relative paths and is mostly for internal use. +class Private ar => 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 +-- | This class allows selective behaviour for file and +-- directory paths and is mostly for internal use. +class Private fd => 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 +-- | Currently not exported pathAbsRel :: AbsRelClass ar => Path ar fd -> Either (AbsPath fd) (RelPath fd) pathAbsRel = absRel Left Right +-- | Currently not exported +pathFileDir :: FileDirClass fd => Path ar fd -> Either (FilePath ar) (DirPath ar) +pathFileDir = fileDir Left Right ------------------------------------------------------------------------ -- Read & Show instances @@ -226,15 +302,15 @@ -- 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,"")] + readsPrec _ s = [(asPath 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) +prop_asPath_getPathString :: AbsFile -> Property +prop_asPath_getPathString p = property $ p == asPath (getPathString p) ------------------------------------------------------------------------ @@ -251,44 +327,84 @@ -- Unchecked Construction Functions -- NB - these construction functions are pure and do no checking!! --- | Convert a 'String' into a 'Path' whose type is determined +-- | Use a 'String' as a 'Path' whose type is determined -- by its context. -mkPath :: String -> Path ar fd -mkPath = mkPathFromComponents . mkPathComponents +-- +-- >> asPath "/tmp" == "/tmp" +-- >> asPath "file.txt" == "file.txt" +-- >> isAbsolute (asPath "/tmp" :: AbsDir) == True +-- >> isAbsolute (asPath "/tmp" :: RelDir) == False +-- >> getPathString (asPath "/tmp" :: AbsDir) == "/tmp" +-- >> getPathString (asPath "/tmp" :: RelDir) == "tmp" +asPath :: String -> Path ar fd +asPath = mkPathFromComponents . mkPathComponents -mkRelFile :: String -> RelFile -mkRelFile = mkPath +-- | Use a 'String' as a 'RelFile'. No checking is done. +-- +-- >> getPathString (asRelFile "file.txt") == "file.txt" +-- >> getPathString (asRelFile "/file.txt") == "file.txt" +-- >> getPathString (asRelFile "tmp") == "tmp" +-- >> getPathString (asRelFile "/tmp") == "tmp" +asRelFile :: String -> RelFile +asRelFile = asPath -mkRelDir :: String -> RelDir -mkRelDir = mkPath +-- | Use a 'String' as a 'RelDir'. No checking is done. +-- +-- >> getPathString (asRelDir "file.txt") == "file.txt" +-- >> getPathString (asRelDir "/file.txt") == "file.txt" +-- >> getPathString (asRelDir "tmp") == "tmp" +-- >> getPathString (asRelDir "/tmp") == "tmp" +asRelDir :: String -> RelDir +asRelDir = asPath -mkAbsFile :: String -> AbsFile -mkAbsFile = mkPath +-- | Use a 'String' as an 'AbsFile'. No checking is done. +-- +-- >> getPathString (asAbsFile "file.txt") == "/file.txt" +-- >> getPathString (asAbsFile "/file.txt") == "/file.txt" +-- >> getPathString (asAbsFile "tmp") == "/tmp" +-- >> getPathString (asAbsFile "/tmp") == "/tmp" +asAbsFile :: String -> AbsFile +asAbsFile = asPath -mkAbsDir :: String -> AbsDir -mkAbsDir = mkPath +-- | Use a 'String' as an 'AbsDir'. No checking is done. +-- +-- >> getPathString (asAbsDir "file.txt") == "/file.txt" +-- >> getPathString (asAbsDir "/file.txt") == "/file.txt" +-- >> getPathString (asAbsDir "tmp") == "/tmp" +-- >> getPathString (asAbsDir "/tmp") == "/tmp" +asAbsDir :: String -> AbsDir +asAbsDir = asPath -mkRelPath :: String -> RelPath fd -mkRelPath = mkPath +-- | Use a 'String' as a 'RelPath fd'. No checking is done. +asRelPath :: String -> RelPath fd +asRelPath = asPath -mkAbsPath :: String -> AbsPath fd -mkAbsPath = mkPath +-- | Use a 'String' as an 'AbsPath fd'. No checking is done. +asAbsPath :: String -> AbsPath fd +asAbsPath = asPath -mkFile :: String -> FilePath ar -mkFile = mkPath +-- | Use a 'String' as a 'FilePath ar'. No checking is done. +asFilePath :: String -> FilePath ar +asFilePath = asPath -mkDir :: String -> DirPath ar -mkDir = mkPath +-- | Use a 'String' as a 'DirPath ar'. No checking is done. +asDirPath :: String -> DirPath ar +asDirPath = asPath +-- | Allow use of OverloadedStrings if desired +instance IsString (Path ar fd) where fromString = asPath ------------------------------------------------------------------------ -- Checked Construction Functions -- | Examines the supplied string and constructs an absolute or -- relative path as appropriate. +-- +-- >> either id (const "fred") (mkPathAbsOrRel "/tmp") == "/tmp" +-- >> either id (const "fred") (mkPathAbsOrRel "tmp") == "fred" mkPathAbsOrRel :: String -> Either (AbsPath fd) (RelPath fd) -mkPathAbsOrRel s | isAbsoluteString s = Left (mkPath s) - | otherwise = Right (mkPath s) +mkPathAbsOrRel s | isAbsoluteString s = Left (asPath s) + | otherwise = Right (asPath s) -- | Searches for a file or directory with the supplied path string -- and returns a 'File' or 'Dir' path as appropriate. If neither exists @@ -299,29 +415,37 @@ 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, False) -> return $ Just $ Left $ asPath s + (False, True ) -> return $ Just $ Right $ asPath s (True, True ) -> ioError $ userError "mkPathFileOrDir - internal inconsistency - file&dir" + where + -- We duplicate these from System.Path.Directory to avoid a module cycle + doesFileExist :: AbsRelClass ar => FilePath ar -> IO Bool + doesFileExist = SD.doesFileExist . getPathString + doesDirectoryExist :: AbsRelClass ar => DirPath ar -> IO Bool + doesDirectoryExist = SD.doesDirectoryExist . getPathString --- | 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 +-- | Convert a 'String' into an 'AbsPath' by interpreting it as +-- relative to the supplied directory if necessary. +-- +-- >> mkAbsPath "/tmp" "foo.txt" == "/tmp/foo.txt" +-- >> mkAbsPath "/tmp" "/etc/foo.txt" == "/etc/foo.txt" +mkAbsPath :: AbsDir -> String -> AbsPath fd +mkAbsPath d = (id ||| makeAbsolute d) . mkPathAbsOrRel -mkAbsFrom :: AbsRelClass ar => AbsDir -> Path ar fd -> AbsPath fd -mkAbsFrom base p = absRel id (mkAbsFromRel base) p +-- | Convert a 'String' into an 'AbsPath' by interpreting it as +-- relative to the cwd if necessary. +mkAbsPathFromCwd :: String -> IO (AbsPath fd) +mkAbsPathFromCwd = (return ||| makeAbsoluteFromCwd) . mkPathAbsOrRel -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) +-- | Lift a function which can operate on either Abs or Rel Path to one which +-- operates on Strings. +-- At present this fn is the only reason we have Rank-2 types, it's also not +-- doing anything useful at present. We /may/ want to expose it later though +-- so leave it for now... +onPathString :: (forall ar . AbsRelClass ar => Path ar fd -> a) -> String -> a +onPathString f = (f ||| f) . mkPathAbsOrRel ------------------------------------------------------------------------ @@ -363,18 +487,17 @@ -- 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'. +-- 'genericAddExtension'. (<.>) :: FilePath ar -> String -> FilePath ar -(<.>) = addFileOrDirExtension +(<.>) = genericAddExtension -- | 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 "file.txt" "bib" == "file.txt.bib" +-- >> addExtension "file." ".bib" == "file..bib" +-- >> addExtension "file" ".bib" == "file.bib" +-- >> takeFileName (addExtension "" "ext") == ".ext" addExtension :: FilePath ar -> String -> FilePath ar addExtension = (<.>) @@ -392,7 +515,7 @@ -- | Drop all extensions -- --- >> not $ hasExtension (dropExtensions x) +-- >> not $ hasAnExtension (dropExtensions x) dropExtensions :: FilePath ar -> FilePath ar dropExtensions = fst . splitExtensions @@ -402,42 +525,42 @@ -- | 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 "file.txt" ".bob" == "file.bob" +-- >> replaceExtension "file.txt" "bob" == "file.bob" +-- >> replaceExtension "file" ".bob" == "file.bob" +-- >> replaceExtension "file.txt" "" == "file" +-- >> replaceExtension "file.fred.bob" "txt" == "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) +replaceBaseName p bn = takeDirectory p (asPath bn `genericAddExtension` genericTakeExtension 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 +replaceFileName p fn = takeDirectory p asPath 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 "file.txt" == ("file",".txt") +-- >> splitExtension "file" == ("file","") +-- >> splitExtension "file/file.txt" == ("file/file",".txt") +-- >> splitExtension "file.txt/boris" == ("file.txt/boris","") +-- >> splitExtension "file.txt/boris.ext" == ("file.txt/boris",".ext") +-- >> splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") splitExtension :: FilePath ar -> (FilePath ar, String) -splitExtension = splitFileOrDirExtension +splitExtension = genericSplitExtension -- | Split on all extensions -- --- >> splitExtensions (mkFile "file.tar.gz") == (mkFile "file",".tar.gz") +-- >> splitExtensions "file.tar.gz" == ("file",".tar.gz") splitExtensions :: FilePath ar -> (FilePath ar, String) -splitExtensions = splitFileOrDirExtensions +splitExtensions = genericSplitExtensions prop_splitCombine :: AbsFile -> Property prop_splitCombine p = property $ p == p2 <.> ext @@ -451,8 +574,13 @@ prop_split_combine p = property $ uncurry combine (splitFileName p) == p +-- | Get the basename of a file +-- +-- >> takeBaseName "/tmp/somedir/myfile.txt" == "myfile" +-- >> takeBaseName "./myfile.txt" == "myfile" +-- >> takeBaseName "myfile.txt" == "myfile" takeBaseName :: Path ar fd -> RelPath fd -takeBaseName = takeFileName . dropFileOrDirExtension +takeBaseName = takeFileName . genericDropExtension takeDirectory :: Path ar fd -> DirPath ar takeDirectory = fst . splitFileName @@ -467,10 +595,15 @@ -- | Get all extensions -- --- >> takeExtensions (mkFile "file.tar.gz") == ".tar.gz" +-- >> takeExtensions "file.tar.gz" == ".tar.gz" takeExtensions :: FilePath ar -> String takeExtensions = snd . splitExtensions +-- | Get the filename component of a file path (ie stripping all parent dirs) +-- +-- >> takeFileName "/tmp/somedir/myfile.txt" == "myfile.txt" +-- >> takeFileName "./myfile.txt" == "myfile.txt" +-- >> takeFileName "myfile.txt" == "myfile.txt" takeFileName :: Path ar fd -> RelPath fd takeFileName PathRoot = PathRoot -- becomes a relative root takeFileName (FileDir _ pc) = FileDir PathRoot pc @@ -482,26 +615,44 @@ ------------------------------------------------------------------------ -- Auxillary Manipulation Functions +-- | Check whether two strings are equal as file paths. +-- +-- >> equalFilePath "/tmp/" "/tmp" == True +-- >> equalFilePath "/tmp" "tmp" == False equalFilePath :: String -> String -> Bool -equalFilePath s1 s2 = mkPath s1 == mkPath s2 +equalFilePath s1 s2 | a1 <- isAbsoluteString s1, + a2 <- isAbsoluteString s2 = a1 == a2 && asPath s1 == asPath s2 -- | Constructs a 'Path' from a list of components. +-- +-- >> joinPath ["/tmp","someDir","file.txt"] == "/tmp/someDir/file.txt" +-- >> (joinPath ["/tmp","someDir","file.txt"] :: RelFile) == "tmp/someDir/file.txt" joinPath :: [String] -> Path ar fd -joinPath = mkPathFromComponents . map PathComponent +joinPath = asPath . intercalate [pathSeparator] -- | Currently just transforms: -- --- >> normalise (mkFile "/tmp/fred/./jim/./file") == mkFile "/tmp/fred/jim/file" +-- >> normalise "/tmp/fred/./jim/./file" == "/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 +-- | Deconstructs a path into its components. +-- +-- >> splitPath ("/tmp/someDir/myfile.txt" :: AbsDir) == (["tmp","someDir","myfile.txt"],Nothing) +-- >> splitPath ("/tmp/someDir/myfile.txt" :: AbsFile) == (["tmp","someDir"],Just "myfile.txt") +-- >> splitPath (asAbsFile "/tmp/someDir/myfile.txt") == (["tmp","someDir"],Just "myfile.txt") +splitPath :: FileDirClass fd => Path ar fd -> ([RelDir],Maybe RelFile) +splitPath PathRoot = ([],Nothing) +splitPath p@(FileDir d pc) = + fileDir (\_->(map (FileDir PathRoot) . pathComponents $ d, Just (FileDir PathRoot pc))) + (\_->(map (FileDir PathRoot) . pathComponents $ p, Nothing)) + p +-- | This function can be used to construct a relative path by removing +-- the supplied 'AbsDir' from the front. It is a runtime 'error' if the +-- supplied 'AbsPath' doesn't start with the 'AbsDir'. +-- +-- >> makeRelative "/tmp/somedir" "/tmp/somedir/anotherdir/file.txt" == "anotherdir/file.txt" makeRelative :: AbsDir -> AbsPath fd -> RelPath fd makeRelative relTo orig = maybe err mkPathFromComponents $ stripPrefix relToPC origPC where @@ -509,6 +660,46 @@ relToPC = pathComponents relTo origPC = pathComponents orig +-- | Joins an absolute directory with a relative path to construct a +-- new absolute path. +-- +-- >> makeAbsolute "/tmp" "file.txt" == "/tmp/file.txt" +-- >> makeAbsolute "/tmp" "adir/file.txt" == "/tmp/adir/file.txt" +makeAbsolute :: AbsDir -> RelPath fd -> AbsPath fd +makeAbsolute = genericMakeAbsolute + +-- | Converts a relative path into an absolute one by +-- prepending the current working directory. +makeAbsoluteFromCwd :: RelPath fd -> IO (AbsPath fd) +makeAbsoluteFromCwd = genericMakeAbsoluteFromCwd + +-- | As for 'makeAbsolute', but for use when the path may already be +-- absolute (in which case it is left unchanged). +-- +-- >> genericMakeAbsolute "/tmp" (asRelFile "file.txt") == "/tmp/file.txt" +-- >> genericMakeAbsolute "/tmp" (asRelFile "adir/file.txt") == "/tmp/adir/file.txt" +-- >> genericMakeAbsolute "/tmp" (asAbsFile "adir/file.txt") == "/adir/file.txt" +-- >> genericMakeAbsolute "/tmp" (asAbsFile "/adir/file.txt") == "/adir/file.txt" +genericMakeAbsolute :: AbsRelClass ar => AbsDir -> Path ar fd -> AbsPath fd +genericMakeAbsolute base p = absRel id (base ) p + +-- | As for 'makeAbsoluteFromCwd', but for use when the path may already be +-- absolute (in which case it is left unchanged). +genericMakeAbsoluteFromCwd :: AbsRelClass ar => Path ar fd -> IO (AbsPath fd) +genericMakeAbsoluteFromCwd p = do + cwdString <- SD.getCurrentDirectory -- we don't use System.Path.Directory impl here to avoid module cycle + return $ genericMakeAbsolute (asAbsDir cwdString) p + +prop_makeAbsoluteFromDir_endSame :: AbsDir -> RelFile -> Property +prop_makeAbsoluteFromDir_endSame base p = property $ show p `isSuffixOf` show (makeAbsolute base p) + +prop_makeAbsoluteFromDir_startSame :: AbsDir -> RelFile -> Property +prop_makeAbsoluteFromDir_startSame base p = property $ show base `isPrefixOf` show (makeAbsolute base p) + +-- prop_makeAbsoluteFromDir_startSameAbs :: AbsDir -> AbsFile -> Property +-- prop_makeAbsoluteFromDir_startSameAbs base p = property $ show base `isPrefixOf` show (makeAbsolute base p) + + ------------------------------------------------------------------------ -- NYI - Not Yet Implemented @@ -529,28 +720,50 @@ ------------------------------------------------------------------------ -- Path Predicates +-- | Test whether a @'Path' ar fd@ is absolute. +-- +-- >> isAbsolute (asAbsFile "fred") == True +-- >> isAbsolute (asRelFile "fred") == False +-- >> isAbsolute (asAbsFile "/fred") == True +-- >> isAbsolute (asRelFile "/fred") == False isAbsolute :: AbsRelClass ar => Path ar fd -> Bool isAbsolute = absRel (const True) (const False) +-- | Test whether the 'String' would correspond to an absolute path +-- if interpreted as a 'Path'. 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 _@ +-- | Invariant - this should return True iff arg is of type @'Path' Rel _@ +-- +-- > isRelative = not . isAbsolute isRelative :: AbsRelClass ar => Path ar fd -> Bool isRelative = not . isAbsolute +-- | Test whether the 'String' would correspond to a relative path +-- if interpreted as a 'Path'. +-- +-- > isRelativeString = not . isAbsoluteString 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 +-- >> null (takeExtension x) == not (hasAnExtension x) +hasAnExtension :: FilePath ar -> Bool +hasAnExtension = not . null . snd . splitExtension +-- | Does the given filename have the given extension? +-- +-- >> hasExtension ".hs" "MyCode.hs" == True +-- >> hasExtension ".hs" "MyCode.hs.bak" == False +-- >> hasExtension ".hs" "MyCode.bak.hs" == True +hasExtension :: String -> FilePath ar -> Bool +hasExtension ext = (==ext) . snd . splitExtension + ------------------------------------------------------------------------ -- Separators @@ -575,24 +788,18 @@ -- | 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 = ':' @@ -617,149 +824,52 @@ ------------------------------------------------------------------------ --- Flexible Manipulation Functions +-- Generic 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 +-- | 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)) +-- >> genericAddExtension "/" "x" == "/.x" +genericAddExtension :: Path ar fd -> String -> Path ar fd +genericAddExtension p "" = p +genericAddExtension (FileDir p (PathComponent pc)) ext = FileDir p (PathComponent (pc ++ suffix)) where suffix | "." `isPrefixOf` ext = ext | otherwise = "." ++ ext -addFileOrDirExtension PathRoot ext = FileDir PathRoot (PathComponent suffix) +genericAddExtension PathRoot ext = FileDir PathRoot (PathComponent suffix) where suffix | "." `isPrefixOf` ext = ext | otherwise = "." ++ ext -dropFileOrDirExtension :: Path ar fd -> Path ar fd -dropFileOrDirExtension = fst . splitFileOrDirExtension +genericDropExtension :: Path ar fd -> Path ar fd +genericDropExtension = fst . genericSplitExtension -dropFileOrDirExtensions :: Path ar fd -> Path ar fd -dropFileOrDirExtensions = fst . splitFileOrDirExtensions +genericDropExtensions :: Path ar fd -> Path ar fd +genericDropExtensions = fst . genericSplitExtensions -splitFileOrDirExtension :: Path ar fd -> (Path ar fd, String) -splitFileOrDirExtension (FileDir p (PathComponent s)) = (FileDir p (PathComponent s1), s2) +genericSplitExtension :: Path ar fd -> (Path ar fd, String) +genericSplitExtension (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,"") +genericSplitExtension p = (p,"") -splitFileOrDirExtensions :: Path ar fd -> (Path ar fd, String) -splitFileOrDirExtensions (FileDir p (PathComponent s)) = (FileDir p (PathComponent s1), s2) +genericSplitExtensions :: Path ar fd -> (Path ar fd, String) +genericSplitExtensions (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) +genericSplitExtensions p = (p,"") -canonicalizePath :: AbsRelClass ar => Path ar fd -> IO (AbsPath fd) -canonicalizePath p = mkPath <$> SD.canonicalizePath (getPathString p) +genericTakeExtension :: Path ar fd -> String +genericTakeExtension = snd . genericSplitExtension -{- -findExecutable :: String -> IO (Maybe FilePath) -getPermissions :: FilePath -> IO Permissions -setPermissions :: FilePath -> Permissions -> IO () -getModificationTime :: FilePath -> IO ClockTime --} +genericTakeExtensions :: Path ar fd -> String +genericTakeExtensions = snd . genericSplitExtension ------------------------------------------------------------------------ @@ -768,8 +878,8 @@ testall = do putStrLn "Running QuickCheck tests..." quickCheck prop_mkPathFromComponents_pathComponents - quickCheck prop_mkAbsFromRel_endSame - quickCheck prop_mkAbsFromRel_startSame + quickCheck prop_makeAbsoluteFromDir_endSame + quickCheck prop_makeAbsoluteFromDir_startSame quickCheck prop_split_combine quickCheck prop_takeFileName_end quickCheck prop_splitCombine diff --git a/System/Path/Directory.hs b/System/Path/Directory.hs new file mode 100644 --- /dev/null +++ b/System/Path/Directory.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides type-safe access to directory manipulations. +-- +-- It is designed to be imported instead of "System.Directory". +-- (It is intended to provide versions of functions from that +-- module which have equivalent functionality but are more +-- typesafe). "System.Path" is a companion module providing +-- a type-safe alternative to "System.FilePath". +-- +-- You will typically want to import as follows: +-- +-- > import Prelude hiding (FilePath) +-- > import System.Path +-- > import System.Path.Directory +-- > import System.Path.IO +-- +-- +-- Ben Moseley - (c) 2009 +-- +module System.Path.Directory +( + -- * Actions on directories + createDirectory, + createDirectoryIfMissing, + removeDirectory, + removeDirectoryRecursive, + renameDirectory, + + getDirectoryContents, + absDirectoryContents, + relDirectoryContents, + filesInDir, + dirsInDir, + + getCurrentDirectory, + setCurrentDirectory, + + -- * Pre-defined directories + getHomeDirectory, + getAppUserDataDirectory, + getUserDocumentsDirectory, + getTemporaryDirectory, + + -- * Actions on files + removeFile, + renameFile, + copyFile, + canonicalizePath, + makeRelativeToCurrentDirectory, + findExecutable, + + -- * Existence tests + doesFileExist, + doesDirectoryExist, + + -- * Permissions + Permissions, + getPermissions, + setPermissions, + + -- * Timestamps + getModificationTime +) + +where + +import Prelude hiding (FilePath) + +import System.Path + +import Control.Applicative +import Control.Arrow +import Data.List +import GHC.Exts(IsString(..)) +import System.Directory (Permissions) +import qualified System.Directory as SD +import System.IO hiding (FilePath) +import System.IO.Error +import System.Time +import Test.QuickCheck +import Text.Printf + + +------------------------------------------------------------------------ +-- Actions on directories + +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 + +renameDirectory :: (AbsRelClass ar1, AbsRelClass ar2) => DirPath ar1 -> DirPath ar2 -> IO () +renameDirectory p1 p2 = SD.renameDirectory (getPathString p1) (getPathString p2) + +-- | An alias for 'relDirectoryContents'. +getDirectoryContents :: AbsRelClass ar => DirPath ar -> IO ([RelDir], [RelFile]) +getDirectoryContents = relDirectoryContents + +-- | 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 <- asAbsDir <$> 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 "d/e/f/") == (["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 ) . asRelPath) filenames + let fileinfo = zip filenames dirFlags + (dirs, files) = partition snd fileinfo + return (map (combine currentDir . asRelDir . fst) dirs, + map (combine currentDir . asRelFile . fst) files) + +-- | A convenient alternative to 'relDirectoryContents' if you only want files. +filesInDir :: AbsRelClass ar => DirPath ar -> IO [RelFile] +filesInDir dir = snd <$> relDirectoryContents dir + +-- | A convenient alternative to 'relDirectoryContents' if you only want directories. +dirsInDir :: AbsRelClass ar => DirPath ar -> IO [RelDir] +dirsInDir dir = fst <$> relDirectoryContents dir + + +getCurrentDirectory :: IO AbsDir +getCurrentDirectory = asAbsDir <$> SD.getCurrentDirectory + +setCurrentDirectory :: AbsRelClass ar => DirPath ar -> IO () +setCurrentDirectory = SD.setCurrentDirectory . getPathString + + +------------------------------------------------------------------------ +-- Pre-defined directories + +getHomeDirectory :: IO AbsDir +getHomeDirectory = asAbsDir <$> SD.getHomeDirectory + +getAppUserDataDirectory :: String -> IO AbsDir +getAppUserDataDirectory user = asAbsDir <$> SD.getAppUserDataDirectory user + +getUserDocumentsDirectory :: IO AbsDir +getUserDocumentsDirectory = asAbsDir <$> SD.getUserDocumentsDirectory + +getTemporaryDirectory :: IO AbsDir +getTemporaryDirectory = asAbsDir <$> SD.getTemporaryDirectory + + +------------------------------------------------------------------------ +-- Actions on files + +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) + +copyFile :: (AbsRelClass ar1, AbsRelClass ar2) => FilePath ar1 -> FilePath ar2 -> IO () +copyFile p1 p2 = SD.copyFile (getPathString p1) (getPathString p2) + +canonicalizePath :: AbsRelClass ar => Path ar fd -> IO (AbsPath fd) +canonicalizePath p = asPath <$> SD.canonicalizePath (getPathString p) + +makeRelativeToCurrentDirectory :: AbsRelClass ar => Path ar fd -> IO (RelPath fd) +makeRelativeToCurrentDirectory p = asPath <$> SD.makeRelativeToCurrentDirectory (getPathString p) + +findExecutable :: String -> IO (Maybe AbsFile) +findExecutable s = fmap asPath <$> SD.findExecutable s + + +------------------------------------------------------------------------ +-- Existence tests + +doesFileExist :: AbsRelClass ar => FilePath ar -> IO Bool +doesFileExist = SD.doesFileExist . getPathString + +doesDirectoryExist :: AbsRelClass ar => DirPath ar -> IO Bool +doesDirectoryExist = SD.doesDirectoryExist . getPathString + + +------------------------------------------------------------------------ +-- Permissions + +getPermissions :: AbsRelClass ar => Path ar fd -> IO Permissions +getPermissions p = SD.getPermissions (getPathString p) + +setPermissions :: AbsRelClass ar => Path ar fd -> Permissions -> IO () +setPermissions p perms = SD.setPermissions (getPathString p) perms + + +------------------------------------------------------------------------ +-- Timestamps + +getModificationTime :: AbsRelClass ar => Path ar fd -> IO ClockTime +getModificationTime p = SD.getModificationTime (getPathString p) + + +------------------------------------------------------------------------ +-- QuickCheck + +testall = do + putStrLn "Running QuickCheck tests..." + putStrLn "Tests completed." + +vectorOf :: Gen a -> Int -> Gen [a] +vectorOf gen n = sequence [ gen | i <- [1..n] ] + +-- test :: Testable a => a -> IO () +-- test = quickCheck + + diff --git a/System/Path/IO.hs b/System/Path/IO.hs new file mode 100644 --- /dev/null +++ b/System/Path/IO.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides type-safe access to IO operations. +-- +-- It is designed to be imported instead of "System.IO". +-- (It is intended to provide versions of functions from that +-- module which have equivalent functionality but are more +-- typesafe). "System.Path" is a companion module providing +-- a type-safe alternative to "System.FilePath". +-- +-- You will typically want to import as follows: +-- +-- > import Prelude hiding (FilePath) +-- > import System.Path +-- > import System.Path.Directory +-- > import System.Path.IO +-- +-- +-- Ben Moseley - (c) 2009 +-- +module System.Path.IO +( + -- * Covers for System.IO functions + withFile, + openFile, + System.Path.IO.readFile, + System.Path.IO.writeFile, + System.Path.IO.appendFile, + withBinaryFile, + openBinaryFile, + openTempFile, + openBinaryTempFile, + + -- * Re-exports + IO, + fixIO, + Handle, + stdin, + stdout, + stderr, + IOMode(..), + hClose, + hFileSize, + hSetFileSize, + hIsEOF, + isEOF, + BufferMode(..), + hSetBuffering, + hGetBuffering, + hFlush, + hGetPosn, + hSetPosn, + HandlePosn, + hSeek, + SeekMode(..), + hTell, + hIsOpen, + hIsClosed, + hIsReadable, + hIsWritable, + hIsSeekable, + hIsTerminalDevice, + hSetEcho, + hGetEcho, + hShow, + hWaitForInput, + hReady, + hGetChar, + hGetLine, + hLookAhead, + hGetContents, + hPutChar, + hPutStr, + hPutStrLn, + hPrint, + interact, + putChar, + putStr, + putStrLn, + print, + getChar, + getLine, + getContents, + readIO, + readLn, + hSetBinaryMode, + hPutBuf, + hGetBuf, + hPutBufNonBlocking, + hGetBufNonBlocking +) + +where + +import Prelude hiding (FilePath) + +import System.Path + +import Control.Applicative +import Control.Arrow +import Data.List +import GHC.Exts(IsString(..)) +import System.Directory (Permissions) +import System.IO hiding (FilePath, withFile, openFile, readFile, writeFile, appendFile, + withBinaryFile, openBinaryFile, openTempFile, openBinaryTempFile) +import qualified System.IO as SIO +import System.IO.Error +import System.Time +import Test.QuickCheck +import Text.Printf + + +------------------------------------------------------------------------ +-- Covers for System.IO functions + +withFile :: AbsRelClass ar => Path ar fd -> IOMode -> (Handle -> IO r) -> IO r +withFile f = SIO.withFile (getPathString f) + +openFile :: AbsRelClass ar => FilePath ar -> IOMode -> IO Handle +openFile f = SIO.openFile (getPathString f) + +readFile :: AbsRelClass ar => FilePath ar -> IO String +readFile f = SIO.readFile (getPathString f) + +writeFile :: AbsRelClass ar => FilePath ar -> String -> IO () +writeFile f = SIO.writeFile (getPathString f) + +appendFile :: AbsRelClass ar => FilePath ar -> String -> IO () +appendFile f = SIO.appendFile (getPathString f) + +withBinaryFile :: AbsRelClass ar => FilePath ar -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile f = SIO.withBinaryFile (getPathString f) + +openBinaryFile :: AbsRelClass ar => FilePath ar -> IOMode -> IO Handle +openBinaryFile f = SIO.openBinaryFile (getPathString f) + +openTempFile :: AbsRelClass ar => DirPath ar -> RelFile -> IO (AbsFile, Handle) +openTempFile f template = first asAbsFile <$> SIO.openTempFile (getPathString f) (getPathString template) + +openBinaryTempFile :: AbsRelClass ar => DirPath ar -> RelFile -> IO (AbsFile, Handle) +openBinaryTempFile f template = first asAbsFile <$> SIO.openBinaryTempFile (getPathString f) (getPathString template) + +------------------------------------------------------------------------ +-- QuickCheck + +testall = do + putStrLn "Running QuickCheck tests..." + putStrLn "Tests completed." + +vectorOf :: Gen a -> Int -> Gen [a] +vectorOf gen n = sequence [ gen | i <- [1..n] ] + +-- test :: Testable a => a -> IO () +-- test = quickCheck + + diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -0,0 +1,46 @@ +module Test where + +import Control.Applicative +import Control.Monad +import Data.List + +import System.Path +import System.Process +import System.Exit +import Text.Printf + +srcfiles = ["System/Path.hs","System/Path/Directory.hs","System/Path/IO.hs"] +template = "TestTemplate.hs" +testModule = "TestModule.hs" +tok = "" +testPrefix = "-- >> " + +main = do + sourceLines <- concat <$> mapM (fmap lines . readFile) srcfiles + templateLines <- lines <$> readFile template + let testLines = [drop (length testPrefix) l | l <- sourceLines, testPrefix `isPrefixOf` l] + (templateHead,_:templateTail) = break (tok `isInfixOf`) templateLines + outLines = (\t -> " "++t++",") <$> testLines + numTestLines = zip [1..] testLines + + writeFile testModule $ unlines $ templateHead ++ outLines ++ templateTail + + let args = ["-e","TestModule.main",testModule] + ghc = "ghc" + stdinput = "" + + printf "Running %d tests...\n" (length testLines) + x@(_ec, failedTestsStr, err) <- readProcessWithExitCode ghc args stdinput + when (not $ null err) $ putStrLn err >> exitFailure + + let failedTests :: [Int] + failedTests = read failedTestsStr + numFailures = length failedTests + + when (not $ null failedTests) $ do + putStrLn "Failures:" + putStrLn $ unlines [s | (n,s) <- numTestLines, n `elem` failedTests] + exitFailure + + putStrLn "Passed." + diff --git a/TestTemplate.hs b/TestTemplate.hs new file mode 100644 --- /dev/null +++ b/TestTemplate.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +module TestModule () +where + +import System.Path +import System.Path.Directory +import System.Random +import Data.Char + +main = do + g <- newStdGen + let (a,_g') = random g + -- TODO - integrate with QuickCheck + x = rootDir "tmp" "someFile" <.> "ext" + + let numResults = zip [1..] $ results a x + fails = [n|(n,False) <-numResults] + + putStr $ show fails -- This can then be parsed by the invoking Test module + +results a x = [ + + True -- Just so we can have commas at end of all preceding lines + ] + diff --git a/pathtype.cabal b/pathtype.cabal --- a/pathtype.cabal +++ b/pathtype.cabal @@ -1,50 +1,96 @@ Name: pathtype -Version: 0.0.1 +Version: 0.0.2 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 +Description: This package provides type-safe access to filepath manipulations. + . + "System.Path" is designed to be used instead of "System.FilePath". + (It is intended to provide versions of functions from that + module which have equivalent functionality but are more + typesafe). "System.Path.Directory" is a companion module + providing a type-safe alternative to "System.Directory". + . + 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 - . + . + > 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 + . 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. - . + . + Overloaded string literals are supported, so with the @OverloadedStrings@ + extension enabled, you can: + . + > f :: FilePath ar + > f = "tmp" "someFile" <.> "ext" + . + If you don't want to use @OverloadedStrings@, you can use the construction fns: + . + > f :: FilePath ar + > f = asDirPath "tmp" asFilePath "someFile" <.> "ext" + . + or... + . + > f :: FilePath ar + > f = asPath "tmp" asPath "someFile" <.> "ext" + . + or just... + . + > f :: FilePath ar + > f = asPath "tmp/someFile.ext" + . + One point to note is that whether one of these is interpreted as + an absolute or a relative path depends on the type at which it is + used: + . + > *System.Path> f :: AbsFile + > /tmp/someFile.ext + > *System.Path> f :: RelFile + > tmp/someFile.ext + . + You will typically want to import as follows: + . + > import Prelude hiding (FilePath) + > import System.Path + > import System.Path.Directory + > import System.Path.IO + . The basic API (and properties satisfied) are heavily influenced - by Neil Mitchell's 'System.FilePath' module. + 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 +HomePage: http://code.haskell.org/pathtype Build-Type: Simple -Cabal-Version: >=1.2 +Cabal-Version: >=1.6 +Extra-Source-Files: Test.hs, TestTemplate.hs +source-repository head + type: darcs + location: http://code.haskell.org/pathtype + Library - Build-Depends: base >= 3 && < 5, directory >= 1 && < 2, QuickCheck >= 1.2 && < 2 + Build-Depends: base >= 4 && < 5, directory >= 1 && < 2, old-time >= 1.0 && < 2, QuickCheck >= 1.2 && < 2 Exposed-modules: - System.Path - Extensions: EmptyDataDecls, PatternGuards, FlexibleInstances, Rank2Types + System.Path, System.Path.Directory, System.Path.IO + Extensions: EmptyDataDecls, PatternGuards, FlexibleInstances, Rank2Types, OverloadedStrings