Add new files.
This commit is contained in:
Bryan O'Sullivan
parent
488e8ae5dc
commit
919df4fef7
2 changed files with 475 additions and 0 deletions
338
System/FilePath/Find.hs
Normal file
338
System/FilePath/Find.hs
Normal file
|
|
@ -0,0 +1,338 @@
|
|||
{-# OPTIONS_GHC -fglasgow-exts #-}
|
||||
|
||||
module System.FilePath.Find (
|
||||
FileType(..)
|
||||
, FindClause
|
||||
, FilterPredicate
|
||||
, RecursionPredicate
|
||||
|
||||
, find
|
||||
, findWithHandler
|
||||
|
||||
, fold
|
||||
, foldWithHandler
|
||||
|
||||
, filePath
|
||||
, fileStatus
|
||||
, depth
|
||||
|
||||
, always
|
||||
, extension
|
||||
, directory
|
||||
, fileName
|
||||
|
||||
, fileType
|
||||
, deviceID
|
||||
, fileID
|
||||
, fileOwner
|
||||
, fileGroup
|
||||
, fileSize
|
||||
, linkCount
|
||||
, specialDeviceID
|
||||
, fileMode
|
||||
, filePerms
|
||||
, anyPerms
|
||||
, accessTime
|
||||
, modificationTime
|
||||
, statusChangeTime
|
||||
|
||||
, (~?)
|
||||
, (/~?)
|
||||
, (==?)
|
||||
, (/=?)
|
||||
, (>?)
|
||||
, (<?)
|
||||
, (>=?)
|
||||
, (<=?)
|
||||
, (&&?)
|
||||
, (||?)
|
||||
) where
|
||||
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad (foldM, forM, liftM, liftM2)
|
||||
import Control.Monad.Fix (MonadFix)
|
||||
import Control.Monad.State (State(..), evalState)
|
||||
import Data.Bits (Bits, (.&.))
|
||||
import Data.List (sort)
|
||||
import System.Directory (getDirectoryContents)
|
||||
import System.FilePath ((</>), takeDirectory, takeExtension, takeFileName)
|
||||
import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import qualified System.Posix.Files as F
|
||||
import qualified System.Posix.Types as T
|
||||
import qualified System.FilePath.Glob as G
|
||||
|
||||
type Info = (FilePath, Int, F.FileStatus)
|
||||
|
||||
newtype FindClause a = FI { runFI :: State Info a }
|
||||
deriving (Functor, Monad, MonadFix)
|
||||
|
||||
evalFI :: FindClause a
|
||||
-> FilePath
|
||||
-> Int
|
||||
-> F.FileStatus
|
||||
-> a
|
||||
|
||||
evalFI m p d s = evalState (runFI m) (p, d, s)
|
||||
|
||||
mkFI = FI . State
|
||||
|
||||
filePath :: FindClause FilePath
|
||||
|
||||
filePath = mkFI $ \st@(p, _, _) -> (p, st)
|
||||
|
||||
fileStatus :: FindClause F.FileStatus
|
||||
|
||||
fileStatus = mkFI $ \st@(_, _, s) -> (s, st)
|
||||
|
||||
depth :: FindClause Int
|
||||
|
||||
depth = mkFI $ \st@(_, d, _) -> (d, st)
|
||||
|
||||
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.Exception -> IO [FilePath])
|
||||
-> RecursionPredicate
|
||||
-> FilterPredicate
|
||||
-> FilePath
|
||||
-> IO [FilePath]
|
||||
|
||||
findWithHandler errHandler recurse filter 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 filter 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 []
|
||||
|
||||
foldWithHandler :: (FilePath -> a -> E.Exception -> IO a)
|
||||
-> RecursionPredicate
|
||||
-> (a -> FindClause a)
|
||||
-> a
|
||||
-> FilePath
|
||||
-> IO a
|
||||
|
||||
foldWithHandler errHandler recurse f state path =
|
||||
E.handle (errHandler path state) $
|
||||
F.getSymbolicLinkStatus path >>= visit state path 0
|
||||
where visit state path depth st =
|
||||
if F.isDirectory st && evalFI recurse path depth st
|
||||
then traverse state path (succ depth) st
|
||||
else return (evalFI (f state) path depth st)
|
||||
traverse state dir depth dirSt = E.handle (errHandler dir state) $
|
||||
getDirContents dir >>=
|
||||
flip foldM (evalFI (f state) dir depth dirSt) (\state name ->
|
||||
E.handle (errHandler dir state) $
|
||||
let path = dir </> name
|
||||
in F.getSymbolicLinkStatus path >>= visit state path depth)
|
||||
|
||||
fold :: RecursionPredicate
|
||||
-> (a -> FindClause a)
|
||||
-> a
|
||||
-> FilePath
|
||||
-> IO a
|
||||
|
||||
fold = foldWithHandler warnOnError
|
||||
where warnOnError path a err =
|
||||
hPutStrLn stderr (path ++ ": " ++ show err) >> return a
|
||||
|
||||
always :: FindClause Bool
|
||||
always = return True
|
||||
|
||||
extension :: FindClause FilePath
|
||||
extension = takeExtension `liftM` filePath
|
||||
|
||||
fileName :: FindClause FilePath
|
||||
fileName = takeFileName `liftM` filePath
|
||||
|
||||
directory :: FindClause FilePath
|
||||
directory = takeDirectory `liftM` filePath
|
||||
|
||||
linkTarget :: FindClause (Maybe FilePath)
|
||||
linkTarget = do
|
||||
path <- filePath
|
||||
st <- fileStatus
|
||||
return $ if F.isSymbolicLink st
|
||||
then unsafePerformIO $ E.handle (const (return Nothing))
|
||||
(Just `liftM` F.readSymbolicLink path)
|
||||
else Nothing
|
||||
|
||||
data FileType = BlockDevice
|
||||
| CharacterDevice
|
||||
| NamedPipe
|
||||
| RegularFile
|
||||
| Directory
|
||||
| SymbolicLink
|
||||
| Socket
|
||||
| Unknown
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
fileType :: FindClause FileType
|
||||
|
||||
fileType = fType `liftM` fileStatus
|
||||
where fType st | F.isBlockDevice st = BlockDevice
|
||||
fType st | F.isCharacterDevice st = CharacterDevice
|
||||
fType st | F.isNamedPipe st = NamedPipe
|
||||
fType st | F.isRegularFile st = RegularFile
|
||||
fType st | F.isDirectory st = Directory
|
||||
fType st | F.isSymbolicLink st = SymbolicLink
|
||||
fType st | F.isSocket st = Socket
|
||||
fType _ = Unknown
|
||||
|
||||
deviceID :: FindClause T.DeviceID
|
||||
deviceID = F.deviceID `liftM` fileStatus
|
||||
|
||||
fileID :: FindClause T.FileID
|
||||
fileID = F.fileID `liftM` fileStatus
|
||||
|
||||
fileOwner :: FindClause T.UserID
|
||||
fileOwner = F.fileOwner `liftM` fileStatus
|
||||
|
||||
fileGroup :: FindClause T.GroupID
|
||||
fileGroup = F.fileGroup `liftM` fileStatus
|
||||
|
||||
fileSize :: FindClause T.FileOffset
|
||||
fileSize = F.fileSize `liftM` fileStatus
|
||||
|
||||
linkCount :: FindClause T.LinkCount
|
||||
linkCount = F.linkCount `liftM` fileStatus
|
||||
|
||||
specialDeviceID :: FindClause T.DeviceID
|
||||
specialDeviceID = F.specialDeviceID `liftM` fileStatus
|
||||
|
||||
fileMode :: FindClause T.FileMode
|
||||
fileMode = F.fileMode `liftM` fileStatus
|
||||
|
||||
filePerms :: FindClause T.FileMode
|
||||
filePerms = (.&. 0777) `liftM` fileMode
|
||||
|
||||
anyPerms :: T.FileMode
|
||||
-> FindClause Bool
|
||||
anyPerms m = filePerms >>= \p -> return (p .&. m /= 0)
|
||||
|
||||
accessTime :: FindClause T.EpochTime
|
||||
accessTime = F.accessTime `liftM` fileStatus
|
||||
|
||||
modificationTime :: FindClause T.EpochTime
|
||||
modificationTime = F.modificationTime `liftM` fileStatus
|
||||
|
||||
statusChangeTime :: FindClause T.EpochTime
|
||||
statusChangeTime = F.statusChangeTime `liftM` fileStatus
|
||||
|
||||
liftOp :: Monad m => (a -> b -> c) -> m a -> b -> m c
|
||||
|
||||
liftOp f a b = a >>= \a' -> return (f a' b)
|
||||
|
||||
(~?) :: FindClause FilePath
|
||||
-> G.GlobPattern
|
||||
-> FindClause Bool
|
||||
|
||||
(~?) = liftOp G.match
|
||||
|
||||
infix 4 ~?
|
||||
|
||||
(/~?) :: FindClause FilePath
|
||||
-> G.GlobPattern
|
||||
-> FindClause Bool
|
||||
(/~?) = liftOp (\s p -> not (s `G.match` p))
|
||||
|
||||
infix 4 /~?
|
||||
|
||||
(==?) :: 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 <?
|
||||
|
||||
(.&.?) :: Bits a => FindClause a
|
||||
-> a
|
||||
-> FindClause a
|
||||
|
||||
(.&.?) = liftOp (.&.)
|
||||
|
||||
infixl 7 .&.?
|
||||
|
||||
(>=?) :: Ord a => FindClause a
|
||||
-> a
|
||||
-> FindClause Bool
|
||||
|
||||
(>=?) = liftOp (>=)
|
||||
|
||||
infix 4 >=?
|
||||
|
||||
(<=?) :: Ord a => FindClause a
|
||||
-> a
|
||||
-> FindClause Bool
|
||||
|
||||
(<=?) = liftOp (<=)
|
||||
|
||||
infix 4 <=?
|
||||
|
||||
(&&?) :: FindClause Bool
|
||||
-> FindClause Bool
|
||||
-> FindClause Bool
|
||||
|
||||
(&&?) = liftM2 (&&)
|
||||
|
||||
infixr 3 &&?
|
||||
|
||||
(||?) :: FindClause Bool
|
||||
-> FindClause Bool
|
||||
-> FindClause Bool
|
||||
|
||||
(||?) = liftM2 (||)
|
||||
|
||||
infixr 2 ||?
|
||||
137
System/FilePath/Glob.hs
Normal file
137
System/FilePath/Glob.hs
Normal file
|
|
@ -0,0 +1,137 @@
|
|||
module System.FilePath.Glob (
|
||||
GlobPattern
|
||||
, match
|
||||
) where
|
||||
|
||||
import Control.Arrow (second)
|
||||
import Data.Ix (Ix, inRange)
|
||||
import Data.List (nub)
|
||||
import Data.Maybe (isJust)
|
||||
import System.FilePath (pathSeparator)
|
||||
|
||||
type GlobPattern = String
|
||||
|
||||
spanClass :: Char -> String -> (String, String)
|
||||
|
||||
spanClass c = gs []
|
||||
where gs _ [] = error "unterminated character class"
|
||||
gs acc (d:ds) | d == c = (reverse acc, ds)
|
||||
| d == '\\' = case ds of
|
||||
(e:es) -> gs (e:'\\':acc) es
|
||||
_ -> error "unterminated escape"
|
||||
| otherwise = gs (d:acc) ds
|
||||
|
||||
type CharRange = (Char, Char)
|
||||
|
||||
data Ix a => SRange a = SRange [a] [(a, a)]
|
||||
deriving (Show)
|
||||
|
||||
inSRange :: Ix a => a -> SRange a -> Bool
|
||||
|
||||
inSRange c (SRange d s) = c `elem` d || any (flip inRange c) s
|
||||
|
||||
type CharClass = SRange Char
|
||||
|
||||
makeClass :: String -> CharClass
|
||||
|
||||
makeClass = makeClass' [] []
|
||||
where makeClass' :: [(Char, Char)] -> [Char] -> String -> CharClass
|
||||
makeClass' dense sparse [] = SRange sparse dense
|
||||
makeClass' dense sparse (a:'-':b:cs) =
|
||||
makeClass' ((a,b):dense) sparse cs
|
||||
makeClass' dense sparse (c:cs) = makeClass' dense (c:sparse) cs
|
||||
|
||||
data MatchTerm = MatchLiteral String
|
||||
| MatchAny
|
||||
| MatchDir
|
||||
| MatchChar
|
||||
| MatchClass Bool CharClass
|
||||
| MatchGroup [String]
|
||||
deriving (Show)
|
||||
|
||||
parseGlob :: GlobPattern -> [MatchTerm]
|
||||
|
||||
parseGlob [] = []
|
||||
parseGlob ('*':'*':cs) = MatchAny : parseGlob cs
|
||||
parseGlob ('*':cs) = MatchDir : parseGlob cs
|
||||
parseGlob ('?':cs) = MatchChar : parseGlob cs
|
||||
parseGlob ('[':cs) = let (cc, ccs) = spanClass ']' cs
|
||||
cls = case cc of
|
||||
('!':ccs) -> MatchClass False $ makeClass ccs
|
||||
_ -> MatchClass True $ makeClass cc
|
||||
in cls : parseGlob ccs
|
||||
parseGlob ('(':cs) = let (gg, ggs) = spanClass ')' cs
|
||||
in MatchGroup (breakGroup [] gg) : parseGlob ggs
|
||||
where breakGroup :: String -> String -> [String]
|
||||
breakGroup acc [] = [reverse acc]
|
||||
breakGroup _ ['\\'] = error "group: unterminated escape"
|
||||
breakGroup acc ('\\':c:cs) = breakGroup (c:acc) cs
|
||||
breakGroup acc ('|':cs) = reverse acc : breakGroup [] cs
|
||||
breakGroup acc (c:cs) = breakGroup (c:acc) cs
|
||||
parseGlob ['\\'] = error "glob: unterminated escape"
|
||||
parseGlob ('\\':c:cs) = MatchLiteral [c] : parseGlob cs
|
||||
parseGlob (c:cs) = MatchLiteral [c] : parseGlob cs
|
||||
|
||||
simplifyTerms :: [MatchTerm] -> [MatchTerm]
|
||||
simplifyTerms [] = []
|
||||
simplifyTerms (MatchLiteral []:as) = simplifyTerms as
|
||||
simplifyTerms (m@(MatchLiteral a):as) =
|
||||
case simplifyTerms as of
|
||||
(MatchLiteral b:bs) -> MatchLiteral (a ++ b) : bs
|
||||
bs -> m : bs
|
||||
simplifyTerms (MatchClass True (SRange [] []):as) = simplifyTerms as
|
||||
simplifyTerms (MatchClass True (SRange a@[_] []):as) =
|
||||
simplifyTerms $ MatchLiteral a : as
|
||||
simplifyTerms (MatchGroup []:as) = simplifyTerms as
|
||||
simplifyTerms (MatchGroup gs:as) =
|
||||
case commonPrefix gs of
|
||||
(p,[]) -> simplifyTerms (MatchLiteral p : as)
|
||||
(p,ss) -> simplifyTerms (MatchLiteral p : MatchGroup ss : as)
|
||||
simplifyTerms (a:as) = a:simplifyTerms as
|
||||
|
||||
commonPrefix :: [String] -> (String, [String])
|
||||
commonPrefix = second nub . pfx ""
|
||||
where pfx _ [] = ("", [])
|
||||
pfx acc ss | any null ss = (reverse acc, ss)
|
||||
| otherwise = let hs = map head ss
|
||||
h = head hs
|
||||
in if all (h==) $ tail hs
|
||||
then pfx (h:acc) $ map tail ss
|
||||
else (reverse acc, ss)
|
||||
|
||||
matchTerms :: [MatchTerm] -> String -> Maybe ()
|
||||
|
||||
matchTerms [] [] = return ()
|
||||
matchTerms [] _ = fail "residual string"
|
||||
matchTerms (MatchLiteral m:ts) cs = matchLiteral m cs >>= matchTerms ts
|
||||
where matchLiteral (a:as) (b:bs) | a == b = matchLiteral as bs
|
||||
matchLiteral [] as = return as
|
||||
matchLiteral _ _ = fail "not a prefix"
|
||||
matchTerms (MatchClass k c:ts) cs = matchClass cs >>= matchTerms ts
|
||||
where matchClass (b:bs) | (inClass && k) || not (inClass || k) = return bs
|
||||
where inClass = b `inSRange` c
|
||||
matchClass _ = fail "no match"
|
||||
matchTerms (MatchGroup g:ts) cs = matchGroup g cs >>= matchTerms ts
|
||||
where matchGroup g as | any null g = return as
|
||||
matchGroup g (a:as) | a `elem` map head g =
|
||||
matchGroup (map tail g) as
|
||||
matchGroup _ _ = fail "not in group"
|
||||
matchTerms [MatchAny] _ = return ()
|
||||
matchTerms (MatchAny:ts) cs = matchAny cs >>= matchTerms ts
|
||||
where matchAny [] = fail "no match"
|
||||
matchAny cs = case matchTerms ts cs of
|
||||
Nothing -> matchAny (tail cs)
|
||||
_ -> return cs
|
||||
matchTerms [MatchDir] cs | pathSeparator `elem` cs = fail "path separator"
|
||||
| otherwise = return ()
|
||||
matchTerms (MatchDir:ts) cs = matchDir cs >>= matchTerms ts
|
||||
where matchDir [] = fail "no match"
|
||||
matchDir (c:_) | c == pathSeparator = fail "path separator"
|
||||
matchDir cs = case matchTerms ts cs of
|
||||
Nothing -> matchDir $ tail cs
|
||||
_ -> return cs
|
||||
|
||||
match :: GlobPattern -> FilePath -> Bool
|
||||
|
||||
match pat name = let terms = simplifyTerms (parseGlob pat)
|
||||
in (isJust . matchTerms terms) name
|
||||
Loading…
Add table
Add a link
Reference in a new issue