From 58f570ce378086a7d6d3390233a2f70481e2d951 Mon Sep 17 00:00:00 2001 From: Bryan O'Sullivan Date: Mon, 30 Apr 2007 07:29:32 +0000 Subject: [PATCH] Working snapshot. --- System/FilePath/Find.hs | 34 ++++++++++++++++++---------------- System/FilePath/Glob.hs | 41 +++++++++++++++++++++++------------------ 2 files changed, 41 insertions(+), 34 deletions(-) diff --git a/System/FilePath/Find.hs b/System/FilePath/Find.hs index d757663..19e4d6a 100644 --- a/System/FilePath/Find.hs +++ b/System/FilePath/Find.hs @@ -38,7 +38,7 @@ module System.FilePath.Find ( , linkTarget - , (~?) + , (~~?) , (/~?) , (==?) , (/=?) @@ -52,7 +52,6 @@ module System.FilePath.Find ( , (.&.?) ) 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) @@ -60,11 +59,12 @@ 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.FilePath.Glob (GlobPattern, (~~), (/~)) import System.IO (hPutStrLn, stderr) +import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO) +import qualified Control.Exception as E 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) @@ -79,20 +79,22 @@ evalFI :: FindClause a evalFI m p d s = evalState (runFI m) (p, d, s) +mkFI :: (Info -> (a, Info)) -> FindClause a + 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) +fileStatus :: FindClause F.FileStatus + +fileStatus = mkFI $ \st@(_, _, s) -> (s, st) + type FilterPredicate = FindClause Bool type RecursionPredicate = FindClause Bool @@ -254,18 +256,18 @@ 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 +(~~?) :: FindClause FilePath + -> GlobPattern + -> FindClause Bool -(~?) = liftOp G.match +(~~?) = liftOp (~~) -infix 4 ~? +infix 4 ~~? (/~?) :: FindClause FilePath - -> G.GlobPattern - -> FindClause Bool -(/~?) = liftOp (\s p -> not (s `G.match` p)) + -> GlobPattern + -> FindClause Bool +(/~?) = liftOp (/~) infix 4 /~? diff --git a/System/FilePath/Glob.hs b/System/FilePath/Glob.hs index b09cdb1..a707956 100644 --- a/System/FilePath/Glob.hs +++ b/System/FilePath/Glob.hs @@ -1,6 +1,7 @@ module System.FilePath.Glob ( GlobPattern - , match + , (~~) + , (/~) ) where import Control.Arrow (second) @@ -21,8 +22,6 @@ spanClass c = gs [] _ -> error "unterminated escape" | otherwise = gs (d:acc) ds -type CharRange = (Char, Char) - data Ix a => SRange a = SRange [a] [(a, a)] deriving (Show) @@ -57,7 +56,7 @@ 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 + ('!':ccs') -> MatchClass False $ makeClass ccs' _ -> MatchClass True $ makeClass cc in cls : parseGlob ccs parseGlob ('(':cs) = let (gg, ggs) = spanClass ')' cs @@ -65,9 +64,9 @@ parseGlob ('(':cs) = let (gg, ggs) = spanClass ')' cs 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 + 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 @@ -112,26 +111,32 @@ matchTerms (MatchClass k c:ts) cs = matchClass cs >>= matchTerms ts 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 + 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) + 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 + matchDir cs' = case matchTerms ts cs' of + Nothing -> matchDir $ tail cs' + _ -> return cs' +matchTerms (MatchChar:_) [] = fail "end of input" +matchTerms (MatchChar:ts) (_:cs) = matchTerms ts cs -match :: GlobPattern -> FilePath -> Bool +(~~) :: FilePath -> GlobPattern -> Bool -match pat name = let terms = simplifyTerms (parseGlob pat) - in (isJust . matchTerms terms) name +name ~~ pat = let terms = simplifyTerms (parseGlob pat) + in (isJust . matchTerms terms) name + +(/~) :: FilePath -> GlobPattern -> Bool + +(/~) = (not . ) . (~~)