Working snapshot.

--HG--
extra : convert_revision : 49a538240310e9c819a2ad33fc4589ca824a8c3f

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
+(~~?) :: FindClause FilePath
-     -> G.GlobPattern
+      -> GlobPattern
-     -> FindClause Bool
+      -> FindClause Bool
 
-(~?) = liftOp G.match
+(~~?) = liftOp (~~)
 
-infix 4 ~?
+infix 4 ~~?
 
 (/~?) :: FindClause FilePath
-      -> G.GlobPattern
+       -> GlobPattern
-      -> FindClause Bool
+       -> FindClause Bool
-(/~?) = liftOp (\s p -> not (s `G.match` p))
+(/~?) = liftOp (/~)
       
 infix 4 /~?
 

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 ('\\':c:cs') = breakGroup (c:acc) cs'
-          breakGroup acc ('|':cs) = reverse acc : breakGroup [] cs
+          breakGroup acc ('|':cs') = reverse acc : breakGroup [] cs'
-          breakGroup acc (c:cs) = breakGroup (c:acc) 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
+    where matchGroup g' as | any null g' = return as
-          matchGroup g (a:as) | a `elem` map head g =
+          matchGroup g' (a:as) | a `elem` map head g' =
-                                  matchGroup (map tail g) as
+                                   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
+          matchAny cs' = case matchTerms ts cs' of
-                          Nothing -> matchAny (tail cs)
+                          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
+          matchDir cs' = case matchTerms ts cs' of
-                        Nothing -> matchDir $ tail cs
+                         Nothing -> matchDir $ tail cs'
-                        _ -> return 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)
+name ~~ pat = let terms = simplifyTerms (parseGlob pat)
-                 in (isJust . matchTerms terms) name
+              in (isJust . matchTerms terms) name
+
+(/~) :: FilePath -> GlobPattern -> Bool
+
+(/~) = (not . ) . (~~)