module System.FilePath.FindCompat where
import qualified System.PosixCompat.Files as F
import Control.Monad.State
import qualified Control.Exception.Extensible as E
import System.IO
import Data.List (sort)
import System.Directory (getDirectoryContents)
import System.IO.Unsafe (unsafeInterleaveIO)
import System.FilePath ((</>))
import Data.Bits (Bits, (.&.))
data FileInfo = FileInfo
{
infoPath :: FilePath
, infoDepth :: Int
, infoStatus :: F.FileStatus
} deriving (Eq)
instance Eq F.FileStatus where
a == b = F.deviceID a == F.deviceID b && F.fileID a == F.fileID b
data FileType = BlockDevice
| CharacterDevice
| NamedPipe
| RegularFile
| Directory
| SymbolicLink
| Socket
| Unknown
deriving (Eq, Ord, Show)
fileType :: FindClause FileType
fileType = statusType `liftM` fileStatus
statusType :: F.FileStatus -> FileType
statusType st | F.isBlockDevice st = BlockDevice
statusType st | F.isCharacterDevice st = CharacterDevice
statusType st | F.isNamedPipe st = NamedPipe
statusType st | F.isRegularFile st = RegularFile
statusType st | F.isDirectory st = Directory
statusType st | F.isSymbolicLink st = SymbolicLink
statusType st | F.isSocket st = Socket
statusType _ = Unknown
mkFI :: FilePath -> Int -> F.FileStatus -> FileInfo
mkFI = FileInfo
newtype FindClause a = FC { runFC :: State FileInfo a }
deriving (Functor, Monad)
evalClause :: FindClause a -> FileInfo -> a
evalClause = evalState . runFC
evalFI :: FindClause a
-> FilePath
-> Int
-> F.FileStatus
-> a
evalFI m p d s = evalClause m (mkFI p d s)
mkFindClause :: (FileInfo -> (a, FileInfo)) -> FindClause a
mkFindClause = FC . State
fileInfo :: FindClause FileInfo
fileInfo = mkFindClause $ \st -> (st, st)
fileStatus :: FindClause F.FileStatus
fileStatus = infoStatus `liftM` fileInfo
type FilterPredicate = FindClause Bool
type RecursionPredicate = FindClause Bool
getDirContents :: FilePath -> IO [FilePath]
getDirContents dir = (sort . filter goodName) `liftM` getDirectoryContents dir
where goodName "." = False
goodName ".." = False
goodName _ = True
findWithHandler ::
(FilePath -> E.SomeException -> IO [FilePath])
-> RecursionPredicate
-> FilterPredicate
-> FilePath
-> IO [FilePath]
findWithHandler errHandler recurse filt path =
E.handle (errHandler path) $ F.getSymbolicLinkStatus path >>= visit path 0
where visit path' depth st =
if F.isDirectory st && evalFI recurse path' depth st
then unsafeInterleaveIO (traverse path' (succ depth) st)
else filterPath path' depth st []
traverse dir depth dirSt = do
names <- E.catch (getDirContents dir) (errHandler dir)
filteredPaths <- forM names $ \name -> do
let path' = dir </> name
unsafeInterleaveIO $ E.handle (errHandler path)
(F.getSymbolicLinkStatus path' >>= visit path' depth)
filterPath dir depth dirSt (concat filteredPaths)
filterPath path' depth st result =
return $ if evalFI filt path' depth st
then path:result
else result
find :: RecursionPredicate
-> FilterPredicate
-> FilePath
-> IO [FilePath]
find = findWithHandler warnOnError
where warnOnError path err =
hPutStrLn stderr (path ++ ": " ++ show err) >> return []
always :: FindClause Bool
always = return True
filePath :: FindClause FilePath
filePath = infoPath `liftM` fileInfo
liftOp :: Monad m => (a -> b -> c) -> m a -> b -> m c
liftOp f a b = a >>= \a' -> return (f a' b)
(==?) :: Eq a => FindClause a -> a -> FindClause Bool
(==?) = liftOp (==)
infix 4 ==?
(/=?) :: Eq a => FindClause a -> a -> FindClause Bool
(/=?) = liftOp (/=)
infix 4 /=?
(>?) :: Ord a => FindClause a -> a -> FindClause Bool
(>?) = liftOp (>)
infix 4 >?
(<?) :: Ord a => FindClause a -> a -> FindClause Bool
(<?) = liftOp (<)
infix 4 <?
(>=?) :: Ord a => FindClause a -> a -> FindClause Bool
(>=?) = liftOp (>=)
infix 4 >=?
(<=?) :: Ord a => FindClause a -> a -> FindClause Bool
(<=?) = liftOp (<=)
infix 4 <=?
(.&.?) :: Bits a => FindClause a -> a -> FindClause a
(.&.?) = liftOp (.&.)
infixl 7 .&.?
(&&?) :: FindClause Bool -> FindClause Bool -> FindClause Bool
(&&?) = liftM2 (&&)
infixr 3 &&?
(||?) :: FindClause Bool -> FindClause Bool -> FindClause Bool
(||?) = liftM2 (||)
infixr 2 ||?