module System.FilePath.FilePather
(
FilePather,
(<?>),
filePather,
filePath,
always,
always',
never,
never',
extension,
extension',
directory,
directory',
hasExtension,
hasExtension',
splitExtension,
splitExtension',
splitDirectories,
splitDirectories',
hasTrailingPathSeparator,
hasTrailingPathSeparator',
fileName,
fileName',
baseName,
baseName',
normalise,
normalise',
makeValid,
makeValid',
isRelative,
isRelative',
isAbsolute,
isAbsolute',
isValid,
isValid',
FileType(..),
RecursePredicate,
FilterPredicate,
isFile,
isDirectory,
isUnknown,
find,
extensionSatisfies,
extensionOneOf,
extensionEq,
findHere,
indir,
indir'
) where
import Control.Exception
import Control.Applicative
import Control.Monad
import Data.Monoid
import System.FilePath((</>), takeExtension, takeDirectory, takeFileName, takeBaseName)
import qualified System.FilePath as P
import System.Directory
newtype FilePather a = FilePather {
(<?>) :: FilePath -> a
}
instance Functor FilePather where
fmap f (FilePather k) =
FilePather (f . k)
instance Applicative FilePather where
FilePather f <*> FilePather a =
FilePather (f <*> a)
pure =
FilePather . const
instance Monad FilePather where
FilePather f >>= k =
FilePather (f >>= (<?>) . k)
return =
pure
instance (Monoid a) => Monoid (FilePather a) where
mempty =
return mempty
FilePather x `mappend` FilePather y =
FilePather (x `mappend` y)
filePather ::
(FilePath -> a)
-> FilePather a
filePather =
FilePather
filePath ::
FilePather FilePath
filePath =
filePather id
always ::
FilePather Bool
always =
filePather (const True)
always' ::
FilePather (a -> Bool)
always' =
constant always
never ::
FilePather Bool
never =
filePather (const False)
never' ::
FilePather (a -> Bool)
never' =
constant never
extension ::
FilePather FilePath
extension =
filePather takeExtension
extension' ::
FilePather (a -> FilePath)
extension' =
constant extension
directory ::
FilePather FilePath
directory =
filePather takeDirectory
directory' ::
FilePather (a -> FilePath)
directory' =
constant directory
hasExtension ::
FilePather Bool
hasExtension =
filePather P.hasExtension
hasExtension' ::
FilePather (a -> Bool)
hasExtension' =
constant hasExtension
splitExtension ::
FilePather (String, String)
splitExtension =
filePather P.splitExtension
splitExtension' ::
FilePather (a -> (String, String))
splitExtension' =
constant splitExtension
splitDirectories ::
FilePather [FilePath]
splitDirectories =
filePather P.splitDirectories
splitDirectories' ::
FilePather (a -> [FilePath])
splitDirectories' =
constant splitDirectories
hasTrailingPathSeparator ::
FilePather Bool
hasTrailingPathSeparator =
filePather P.hasTrailingPathSeparator
hasTrailingPathSeparator' ::
FilePather (a -> Bool)
hasTrailingPathSeparator' =
constant hasTrailingPathSeparator
fileName ::
FilePather FilePath
fileName =
filePather takeFileName
fileName' ::
FilePather (a -> FilePath)
fileName' =
constant fileName
baseName ::
FilePather FilePath
baseName =
filePather takeBaseName
baseName' ::
FilePather (a -> FilePath)
baseName' =
constant baseName
normalise ::
FilePather FilePath
normalise =
filePather P.normalise
normalise' ::
FilePather (a -> FilePath)
normalise' =
constant normalise
makeValid ::
FilePather FilePath
makeValid =
filePather P.makeValid
makeValid' ::
FilePather (a -> FilePath)
makeValid' =
constant makeValid
isRelative ::
FilePather Bool
isRelative =
filePather P.isRelative
isRelative' ::
FilePather (a -> Bool)
isRelative' =
constant isRelative
isAbsolute ::
FilePather Bool
isAbsolute =
filePather P.isAbsolute
isAbsolute' ::
FilePather (a -> Bool)
isAbsolute' =
constant isAbsolute
isValid ::
FilePather Bool
isValid =
filePather P.isValid
isValid' ::
FilePather (a -> Bool)
isValid' =
constant isValid
data FileType = File
| Directory
| Unknown
deriving (Eq, Show)
type RecursePredicate = FilePather Bool
type FilterPredicate = FilePather (FileType -> Bool)
isFile ::
Applicative f =>
f (FileType -> Bool)
isFile =
pure (== File)
isDirectory ::
Applicative f =>
f (FileType -> Bool)
isDirectory =
pure (== Directory)
isUnknown ::
Applicative f =>
f (FileType -> Bool)
isUnknown =
pure (== Unknown)
find ::
RecursePredicate
-> FilterPredicate
-> FilePath
-> IO [FilePath]
find =
find' []
where
find' :: FilePath -> RecursePredicate -> FilterPredicate -> FilePath -> IO [FilePath]
find' k r x p = let z = if null k then p else k </> p
z' t = [z | x <?> z $ t]
ifM c t f = do c' <- c
t' <- t
f' <- f
return (if c' then t' else f')
in ifM (doesFileExist z)
(return (z' File)) $
do e <- doesDirectoryExist z
if e
then if r <?> z
then do c <- getDirectoryContents z
t <- fmap join $ forM (filter (`notElem` [".", ".."]) c) (find' k r x . (z </>))
return (z' Directory ++ t)
else return (z' Directory)
else return (z' Unknown)
extensionSatisfies ::
(FilePath -> Bool)
-> FilterPredicate
extensionSatisfies f =
(const . f) <$> extension
extensionOneOf ::
[FilePath]
-> FilterPredicate
extensionOneOf =
extensionSatisfies . flip elem . map ('.':)
extensionEq ::
FilePath
-> FilterPredicate
extensionEq =
extensionOneOf . return
findHere ::
RecursePredicate
-> FilterPredicate
-> IO [FilePath]
findHere r x =
find r x =<< getCurrentDirectory
indir ::
FilePath
-> (FilePath -> IO a)
-> IO a
indir d k =
do c <- getCurrentDirectory
setCurrentDirectory d
k c `finally` setCurrentDirectory c
indir' ::
FilePath
-> IO a
-> IO a
indir' d =
indir d . const
constant ::
Functor f =>
f a
-> f (t -> a)
constant =
fmap const