From 919df4fef71bdce4e4eea4ae35b3937f44c3407f Mon Sep 17 00:00:00 2001
From: Bryan O'Sullivan <bos@serpentine.com>
Date: Mon, 30 Apr 2007 06:30:30 +0000
Subject: [PATCH] Add new files.

---
 System/FilePath/Find.hs | 338 ++++++++++++++++++++++++++++++++++++++++
 System/FilePath/Glob.hs | 137 ++++++++++++++++
 2 files changed, 475 insertions(+)
 create mode 100644 System/FilePath/Find.hs
 create mode 100644 System/FilePath/Glob.hs

diff --git a/System/FilePath/Find.hs b/System/FilePath/Find.hs
new file mode 100644
index 0000000..e612180
--- /dev/null
+++ b/System/FilePath/Find.hs
@@ -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 ||?
diff --git a/System/FilePath/Glob.hs b/System/FilePath/Glob.hs
new file mode 100644
index 0000000..b09cdb1
--- /dev/null
+++ b/System/FilePath/Glob.hs
@@ -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