find-conduit 0.3.0 → 0.4.0

raw patch · 4 files changed

+584/−327 lines, 4 filesdep +mmorphPVP ok

version bump matches the API change (PVP)

Dependencies added: mmorph

API changes (from Hackage documentation)

Files

• Data/Cond.hs +224/−134
• Data/Conduit/Find.hs +335/−167
• find-conduit.cabal +3/−1
• test/main.hs +22/−25

@@ -6,19 +6,20 @@ {-# LANGUAGE TypeFamilies #-}  module Data.Cond-    ( Result(..), toResult, fromResult-    , CondT(..), runCondT, Cond, runCond-    , if_, ifM_, apply, test-    , reject, rejectAll, norecurse-    , or_, (||:), and_, (&&:), not_, prune-    , traverseRecursively+    ( CondT(..), Cond+    , runCondT, applyCondT, runCond, applyCond+    , guardM, guard_, guardM_, apply, consider+    , matches, if_, when_, unless_, or_, and_, not_+    , ignore, norecurse, prune+    , test, recurse     ) where  import Control.Applicative import Control.Arrow (first)-import Control.Monad+import Control.Monad hiding (mapM_, sequence_) import Control.Monad.Base import Control.Monad.Catch+import Control.Monad.Morph import Control.Monad.Reader.Class import Control.Monad.State.Class import Control.Monad.Trans@@ -26,19 +27,14 @@ import Control.Monad.Trans.State (StateT(..), withStateT, evalStateT) import Data.Foldable import Data.Functor.Identity-import Data.List.NonEmpty import Data.Maybe (fromMaybe, isJust) import Data.Monoid hiding ((<>)) import Data.Semigroup-import Prelude hiding (foldr1)+import Prelude hiding (mapM_, foldr1, sequence_) --- | 'Result' is an enriched 'Maybe' type which additionally specifies whether+-- | 'Result' is an enriched 'Maybe' type which also specifies whether --   recursion should occur from the given input, and if so, how such---   recursion should be done.  It is isomorphic to:------ @--- type Result a m b = (Maybe b, Maybe (Maybe (CondT a m b)))--- @+--   recursion should be performed. data Result a m b = Ignore                   | Keep b                   | RecurseOnly (Maybe (CondT a m b))@@ -55,7 +51,15 @@     fmap f (Keep a)             = Keep (f a)     fmap f (RecurseOnly l)      = RecurseOnly (liftM (fmap f) l)     fmap f (KeepAndRecurse a l) = KeepAndRecurse (f a) (liftM (fmap f) l)+    {-# INLINE fmap #-} +instance MFunctor (Result a) where+    hoist _ Ignore                 = Ignore+    hoist _ (Keep a)               = Keep a+    hoist nat (RecurseOnly l)      = RecurseOnly (fmap (hoist nat) l)+    hoist nat (KeepAndRecurse a l) = KeepAndRecurse a (fmap (hoist nat) l)+    {-# INLINE hoist #-}+ instance Semigroup (Result a m b) where     Ignore        <> _                  = Ignore     _             <> Ignore             = Ignore@@ -69,18 +73,20 @@     _             <> KeepAndRecurse b m = KeepAndRecurse b m  instance Monoid b => Monoid (Result a m b) where-    mempty        = KeepAndRecurse mempty Nothing-    x `mappend` y = x <> y+    mempty  = KeepAndRecurse mempty Nothing+    {-# INLINE mempty #-}+    mappend = (<>)+    {-# INLINE mappend #-} -recurse :: Result a m b-recurse = RecurseOnly Nothing+accept' :: b -> Result a m b+accept' = flip KeepAndRecurse Nothing -accept :: b -> Result a m b-accept = flip KeepAndRecurse Nothing+recurse' :: Result a m b+recurse' = RecurseOnly Nothing  toResult :: Monad m => Maybe a -> forall r. Result r m a-toResult Nothing  = recurse-toResult (Just a) = accept a+toResult Nothing  = recurse'+toResult (Just a) = accept' a  fromResult :: Monad m => forall r. Result r m a -> Maybe a fromResult Ignore               = Nothing@@ -88,28 +94,30 @@ fromResult (RecurseOnly _)      = Nothing fromResult (KeepAndRecurse a _) = Just a --- | 'CondT" is an arrow that maps from 'a' to @m b@, but only if 'a'---   satisfies certain conditions.  It is a Monad, meaning each condition---   stated must be satisfied for the map to succeed (in the spirit of the---   'Maybe' short-circuiting Monad).  In fact, 'CondT' is nearly equivalent---   to @StateT a (MaybeT m) b@, with some additional complexity for---   performing recursive iterations (see the 'Result' type above).+-- | 'CondT' is an enhanced form @StateT a (MaybeT m) b@, which uses the+--   'Result' type instead of 'Maybe' to additional express whether recursion+--   should be performed on the current state.  This is used to form+--   predicates to guide recursive unfolds. -----   You can promote functions of type @a -> m (Maybe b)@ into 'CondT' using---   'apply'.  Pure functions @a -> Bool@ are lifted with 'if_', and---   @a -> m Bool@ with 'ifM_'.  In effect, @if_ f@ is the same as---   @ask >>= guard . f@.+--   Several different types may be promoted to 'CondT': --+--   [@Bool@]                  guard+--   [@m Bool@]                guardM+--   [@a -> Bool@]              guard_+--   [@a -> m Bool@]            guardM_+--   [@a -> m (Maybe b)@]       apply+--   [@a -> m (Maybe (b, a))@]  consider+-- --   Here is a trivial example: -- -- @ --   flip runCondT 42 $ do---     if_ even+--     guard_ even --     liftIO $ putStrLn "42 must be even to reach here" -----     if_ odd <|> if_ even---     if_ even &&: if_ (== 42)---     if_ ((== 0) . (`mod` 6))+--     guard_ odd <|> guard_ even+--     guard_ even &&: guard_ (== 42)+--     guard_ ((== 0) . (`mod` 6)) -- @ -- --   'CondT' is typically invoked using 'runCondT', in which case it maps 'a'@@ -122,23 +130,31 @@  type Cond a = CondT a Identity -instance Monad m => Semigroup (CondT a m b) where-    (<>) = (>>)+instance (Monad m, Semigroup b) => Semigroup (CondT a m b) where+    (<>) = liftM2 (<>)+    {-# INLINE (<>) #-} -instance Monad m => Monoid (CondT a m a) where-    mempty  = ask-    mappend = (<>)+instance (Monad m, Monoid b) => Monoid (CondT a m b) where+    mempty  = CondT $ return $ accept' mempty+    {-# INLINE mempty #-}+    mappend = liftM2 mappend+    {-# INLINE mappend #-}  instance Monad m => Functor (CondT a m) where     fmap f (CondT g) = CondT (liftM (fmap f) g)+    {-# INLINE fmap #-}  instance Monad m => Applicative (CondT a m) where     pure  = return+    {-# INLINE pure #-}     (<*>) = ap+    {-# INLINE (<*>) #-}  instance Monad m => Monad (CondT a m) where-    return = CondT . return . accept+    return = CondT . return . accept'+    {-# INLINE return #-}     fail _ = mzero+    {-# INLINE fail #-}     CondT f >>= k = CondT $ do         r <- f         case r of@@ -153,26 +169,41 @@             KeepAndRecurse b _ -> getCondT (k b)  instance Monad m => MonadReader a (CondT a m) where-    ask               = CondT $ liftM accept get+    ask               = CondT $ gets accept'+    {-# INLINE ask #-}     local f (CondT m) = CondT $ withStateT f m-    reader f          = f <$> ask+    {-# INLINE local #-}+    reader f          = liftM f ask+    {-# INLINE reader #-}  instance Monad m => MonadState a (CondT a m) where-    get     = CondT $ accept `liftM` get-    put s   = CondT $ accept `liftM` put s-    state f = CondT $ state (fmap (first accept) f)+    get     = CondT $ gets accept'+    {-# INLINE get #-}+    put s   = CondT $ liftM accept' $ put s+    {-# INLINE put #-}+    state f = CondT $ state (fmap (first accept') f)+    {-# INLINE state #-} -instance Monad m => MonadPlus (CondT a m) where-    mzero = CondT $ return recurse-    CondT f `mplus` CondT g = CondT $ do+instance Monad m => Alternative (CondT a m) where+    empty = CondT $ return recurse'+    {-# INLINE empty #-}+    CondT f <|> CondT g = CondT $ do         r <- f         case r of             x@(Keep _) -> return x             x@(KeepAndRecurse _ _) -> return x             _ -> g+    {-# INLINE (<|>) #-} +instance Monad m => MonadPlus (CondT a m) where+    mzero = empty+    {-# INLINE mzero #-}+    mplus = (<|>)+    {-# INLINE mplus #-}+ instance MonadThrow m => MonadThrow (CondT a m) where-  throwM = CondT . throwM+    throwM = CondT . throwM+    {-# INLINE throwM #-}  instance MonadCatch m => MonadCatch (CondT a m) where     catch (CondT m) c = CondT $ m `catch` \e -> getCondT (c e)@@ -183,118 +214,177 @@       where q u = CondT . u . getCondT  instance MonadBase b m => MonadBase b (CondT a m) where-    liftBase m = CondT $ accept `liftM` liftBase m+    liftBase m = CondT $ liftM accept' $ liftBase m+    {-# INLINE liftBase #-}  instance MonadIO m => MonadIO (CondT a m) where-    liftIO m = CondT $ accept `liftM` liftIO m+    liftIO m = CondT $ liftM accept' $ liftIO m+    {-# INLINE liftIO #-}  instance MonadTrans (CondT a) where-    lift m = CondT $ accept `liftM` lift m+    lift m = CondT $ liftM accept' $ lift m+    {-# INLINE lift #-}  instance MonadBaseControl b m => MonadBaseControl b (CondT r m) where     newtype StM (CondT r m) a =         CondTStM { unCondTStM :: StM m (Result r m a, r) }     liftBaseWith f = CondT $ StateT $ \s ->-        liftM (\x -> (accept x, s)) $ liftBaseWith $ \runInBase -> f $ \k ->+        liftM (\x -> (accept' x, s)) $ liftBaseWith $ \runInBase -> f $ \k ->             liftM CondTStM $ runInBase $ runStateT (getCondT k) s     restoreM = CondT . StateT . const . restoreM . unCondTStM     {-# INLINE liftBaseWith #-}     {-# INLINE restoreM #-} +instance MFunctor (CondT a) where+    hoist nat (CondT m) = CondT $ hoist nat (liftM (hoist nat) m)+    {-# INLINE hoist #-}+ runCondT :: Monad m => CondT a m b -> a -> m (Maybe b)-runCondT (CondT f) a = do-    r <- evalStateT f a-    return $ case r of-        Ignore             -> Nothing-        Keep b             -> Just b-        RecurseOnly _      -> Nothing-        KeepAndRecurse b _ -> Just b+runCondT (CondT f) a = fromResult `liftM` evalStateT f a+{-# INLINE runCondT #-}  runCond :: Cond a b -> a -> Maybe b runCond = (runIdentity .) . runCondT+{-# INLINE runCond #-} -if_ :: Monad m => (a -> Bool) -> CondT a m ()-if_ f = ask >>= guard . f+-- | Case analysis of applying a condition to an input value.  Note that+--   function provided should recurse, calling applyCondT again, if the given+--   condition is Just, should it wish to.  Not result value is accumulated by+--   this function, meaning you should use 'WriterT' if you wish to do so+--   (unlike the pure variant, 'applyCond', which must accumulate a value to+--   have any meaning).+applyCondT :: Monad m+           => a+           -> CondT a m b+           -> (a -> Maybe b -> Maybe (CondT a m b) -> m ())+           -> m ()+applyCondT a c k = do+    (r, a') <- runStateT (getCondT c) a+    case r of+        Ignore              -> k a' Nothing  Nothing+        Keep b              -> k a' (Just b) Nothing+        RecurseOnly c'      -> k a' Nothing  (Just (fromMaybe c c'))+        KeepAndRecurse b c' -> k a' (Just b) (Just (fromMaybe c c')) -ifM_ :: Monad m => (a -> m Bool) -> CondT a m ()-ifM_ f = ask >>= lift . f >>= guard+-- | Case analysis of applying a pure condition to an input value.  Note that+--   the user is responsible for recursively calling this function if the+--   resulting condition is a Just value.  Each step of the recursion must+--   return a Monoid so that a final result may be collected.+applyCond :: Monoid c+          => a+          -> Cond a b+          -> (a -> Maybe b -> Maybe (Cond a b) -> c)+          -> c+applyCond a c k = case runIdentity (runStateT (getCondT c) a) of+    (Ignore, a')              -> k a' Nothing  Nothing+    (Keep b, a')              -> k a' (Just b) Nothing+    (RecurseOnly c', a')      -> k a' Nothing  (Just (fromMaybe c c'))+    (KeepAndRecurse b c', a') -> k a' (Just b) (Just (fromMaybe c c')) +guardM :: Monad m => m Bool -> CondT a m ()+guardM m = lift m >>= guard+{-# INLINE guardM #-}++guard_ :: Monad m => (a -> Bool) -> CondT a m ()+guard_ f = ask >>= guard . f+{-# INLINE guard_ #-}++guardM_ :: Monad m => (a -> m Bool) -> CondT a m ()+guardM_ f = ask >>= lift . f >>= guard+{-# INLINE guardM_ #-}+ apply :: Monad m => (a -> m (Maybe b)) -> CondT a m b-apply f = CondT $ liftM toResult . lift . f =<< get+apply f = CondT $ get >>= liftM toResult . lift . f+{-# INLINE apply #-} -test :: Monad m => CondT a m b -> a -> m Bool-test = (liftM isJust .) . runCondT+consider :: Monad m => (a -> m (Maybe (b, a))) -> CondT a m b+consider f = CondT $ do+    a <- get+    mres <- lift $ f a+    case mres of+        Nothing      -> return Ignore+        Just (b, a') -> put a' >> return (accept' b)+{-# INLINE consider #-} --- | 'reject' rejects the current entry, but allows recursion.  This is the---   same as 'mzero'.-reject :: Monad m => CondT a m b-reject = mzero+matches :: Monad m => CondT a m b -> CondT a m Bool+matches = fmap isJust . optional+{-# INLINE matches #-} --- | 'rejectAll' rejects the entry and all of its descendents.-rejectAll :: Monad m => CondT a m b-rejectAll = CondT $ return Ignore+if_ :: Monad m => CondT a m b -> CondT a m c -> CondT a m c -> CondT a m c+if_ c x y = CondT $ do+    r <- getCondT c+    getCondT $ case r of+        Ignore             -> y+        Keep _             -> x+        RecurseOnly _      -> y+        KeepAndRecurse _ _ -> x+{-# INLINE if_ #-} --- | 'norecurse' indicates that recursion should not be performed on the current---   item.  Note that this library doesn't perform any actual recursion; that---   is up to the consumer of the final 'Result' value, typically---   'applyCondT'.-norecurse :: Monad m => CondT a m ()-norecurse = CondT $ return (Keep ())+when_ :: Monad m => CondT a m b -> CondT a m () -> CondT a m ()+when_ c x = if_ c x (return ())+{-# INLINE when_ #-} -or_ :: Monad m => NonEmpty (CondT a m b) -> CondT a m b-or_ = foldr1 mplus+unless_ :: Monad m => CondT a m b -> CondT a m () -> CondT a m ()+unless_ c = if_ c (return ())+{-# INLINE unless_ #-} -infixr 3 &&:-(||:) :: Monad m => CondT a m b -> CondT a m b -> CondT a m b-(||:) = mplus+-- | Check whether at least one of the given conditions is true.  This is a+--   synonym for 'Data.Foldable.asum'.+or_ :: Monad m => [CondT a m b] -> CondT a m b+or_ = asum+{-# INLINE or_ #-} -and_ :: Monad m => [CondT a m b] -> CondT a m [b]-and_ = foldl' (\acc x -> (:) <$> x <*> acc) (return [])+-- | Check that all of the given conditions are true.  This is a synonym for+--   'Data.Foldable.sequence_'.+and_ :: Monad m => [CondT a m b] -> CondT a m ()+and_ = sequence_+{-# INLINE and_ #-} -infixr 2 ||:-(&&:) :: Monad m => CondT a m b -> CondT a m c -> CondT a m (b, c)-(&&:) = liftM2 (,)+-- | 'not_' inverts the meaning of the given predicate.+not_ :: Monad m => CondT a m b -> CondT a m ()+not_ c = when_ c ignore+{-# INLINE not_ #-} --- | 'not_' inverts the meaning of the given predicate while preserving---   recursion.-not_ :: Monad m => CondT a m () -> CondT a m ()-not_ (CondT f) = CondT $ go `liftM` f-  where-    go Ignore               = accept ()-    go (Keep _)             = recurse-    go (RecurseOnly _)      = accept ()-    go (KeepAndRecurse _ _) = recurse+-- | 'ignore' ignores the current entry, but allows recursion into its+--   descendents.  This is the same as 'mzero'.+ignore :: Monad m => CondT a m b+ignore = mzero+{-# INLINE ignore #-} --- | 'prune' is like 'not_', but does not preserve recursion.  It should be read---   as "prune this entry and all its descendents if the predicate matches".---   It is the same as @x ||: rejectAll@.-prune :: Monad m => CondT a m () -> CondT a m ()-prune (CondT f) = CondT $ go `liftM` f-  where-    go Ignore               = accept ()-    go (Keep _)             = Ignore-    go (RecurseOnly _)      = accept ()-    go (KeepAndRecurse _ _) = Ignore+-- | 'prune' is a synonym for both ignoring an entry and its descendents. It+--   is the same as 'ignore >> norecurse'.+prune :: Monad m => CondT a m ()+prune = CondT $ return Ignore+{-# INLINE prune #-} --- | This function expresses the pattern of recursive traversal, directed by a---   'CondT' predicate.  It does not require that the structure being traversed---   in memory, as it might very well be a filesystem, the decision tree of an---   algorithm, etc.  It works very nicely with conduits, in order to iterate---   over the traversal in constant space.-traverseRecursively :: (Monad m, Monad n)-                    => a-                    -> CondT a m b-                    -> (a -> b -> n ())-                    -> (forall x. m x -> n x)-                    -> (a -> (a -> n ()) -> n ())-                    -> n ()-traverseRecursively a c f trans getChildren = do-    r <- trans $ evalStateT (getCondT c) a-    case r of-        Ignore             -> return ()-        Keep b             -> f a b-        RecurseOnly m      -> descend (fromMaybe c m)-        KeepAndRecurse b m -> f a b >> descend (fromMaybe c m)-  where-    descend next = getChildren a $ \child ->-        traverseRecursively child next f trans getChildren+-- | 'norecurse' prevents recursion into the current entry's descendents, but+--   does not ignore the entry itself.+norecurse :: Monad m => CondT a m ()+norecurse = CondT $ return $ Keep ()+{-# INLINE norecurse #-}++test :: Monad m => CondT a m b -> a -> m Bool+test = (liftM isJust .) . runCondT+{-# INLINE test #-}++-- | 'recurse' changes the recursion predicate for any child elements.  For+--   example, the following file-finding predicate looks for all @*.hs@ files,+--   but under any @.git@ directory, only looks for a file named @config@:+--+-- @+-- if_ (name_ \".git\" \>\> directory)+--     (ignore \>\> recurse (name_ \"config\"))+--     (glob \"*.hs\")+-- @+--+-- If this code had used @recurse (glob \"*.hs\"))@ instead in the else case,+-- it would have meant that @.git@ is only looked for at the top-level of the+-- search (i.e., the top-most element).+recurse :: Monad m => CondT a m b -> CondT a m b+recurse c = CondT $ do+    r <- getCondT c+    return $ case r of+        Ignore             -> Ignore+        Keep b             -> Keep b+        RecurseOnly _      -> RecurseOnly (Just c)+        KeepAndRecurse b _ -> KeepAndRecurse b (Just c)

@@ -1,6 +1,7 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}  module Data.Conduit.Find     (@@ -18,32 +19,49 @@      -- * Finding functions       find-    , find'-    , lfind-    , lfind'+    , findFilesSource+    , findFiles+    , findFilePaths+    , test+    , ltest     , stat     , lstat-    , test-    , findRaw+    , hasStatus -    -- * File path predicates-    , ignoreVcs-    , regex+      -- * File path predicates     , glob+    , regex+    , ignoreVcs++      -- * GNU find compatibility predicates+    , depth_+    , maxdepth_+    , mindepth_+    , ignoreReaddirRace_+    , noIgnoreReaddirRace_+    , amin_+    , atime_+    , anewer_+    , empty_+    , executable_+    , gid_+    , name_+    , getDepth     , filename_     , filenameS_-    , filepath_-    , filepathS_-    , withPath+    , pathname_+    , pathnameS_+    , getFilePath+    , follow_+    , prune_      -- * File entry predicates (uses stat information)     , regular+    , directory     , hasMode     , executable-    , depth-    , lastAccessed-    , lastModified-    , withFileStatus+    , lastAccessed_+    , lastModified_      -- * Predicate combinators     , module Cond@@ -55,12 +73,15 @@  import           Conduit import           Control.Applicative-import           Control.Monad+import           Control.Exception+import           Control.Monad hiding (forM_)+import           Control.Monad.Morph import           Control.Monad.State.Class-import           Data.Attoparsec.Text+import           Data.Attoparsec.Text as A import           Data.Bits import qualified Data.Cond as Cond import           Data.Cond hiding (test)+import           Data.Foldable hiding (elem, find) import           Data.Maybe (fromMaybe) import           Data.Monoid import           Data.Text (Text, unpack, pack)@@ -167,35 +188,239 @@ See 'Data.Cond' for more details on the Monad used to build predicates. -} -type Predicate m a = CondT a m ()+data FindOptions = FindOptions+    { findFollowSymlinks    :: Bool+    , findContentsFirst     :: Bool+    , findIgnoreReaddirRace :: Bool+    , findIgnoreResults     :: Bool+    } +defaultFindOptions :: FindOptions+defaultFindOptions = FindOptions+    { findFollowSymlinks    = True+    , findContentsFirst     = False+    , findIgnoreReaddirRace = False+    , findIgnoreResults     = False+    }+ data FileEntry = FileEntry-    { entryPath   :: FilePath-    , entryDepth  :: Int-    , entryStatus :: Maybe FileStatus+    { entryPath        :: !FilePath+    , entryDepth       :: !Int+    , entryFindOptions :: !(FindOptions)+    , entryStatus      :: !(Maybe FileStatus)       -- ^ This is Nothing until we determine stat should be called.     } +newFileEntry :: FilePath -> Int -> FindOptions -> FileEntry+newFileEntry p d f = FileEntry p d f Nothing+ instance Show FileEntry where     show entry = "FileEntry "               ++ show (entryPath entry)               ++ " " ++ show (entryDepth entry) -newFileEntry :: FilePath -> Int -> FileEntry-newFileEntry p d = FileEntry p d Nothing+getFilePath :: Monad m => CondT FileEntry m FilePath+getFilePath = gets entryPath --- | Return all entries, except for those within version-control metadata---   directories (and not including the version control directory itself either).-ignoreVcs :: Monad m => Predicate m FileEntry-ignoreVcs = prune (filename_ (`elem` vcsDirs))+pathname_ :: Monad m => (FilePath -> Bool) -> CondT FileEntry m ()+pathname_ f = guard . f =<< getFilePath++pathnameS_ :: Monad m => (String -> Bool) -> CondT FileEntry m ()+pathnameS_ f = pathname_ (f . encodeString)++filename_ :: Monad m => (FilePath -> Bool) -> CondT FileEntry m ()+filename_ f = pathname_ (f . filename)++filenameS_ :: Monad m => (String -> Bool) -> CondT FileEntry m ()+filenameS_ f = pathname_ (f . encodeString . filename)++getDepth :: Monad m => CondT FileEntry m Int+getDepth = gets entryDepth++modifyFindOptions :: Monad m+                  => (FindOptions -> FindOptions)+                  -> CondT FileEntry m ()+modifyFindOptions f =+    modify $ \e -> e { entryFindOptions = f (entryFindOptions e) }++------------------------------------------------------------------------+-- Workalike options for emulating GNU find.+------------------------------------------------------------------------++depth_ :: Monad m => CondT FileEntry m ()+depth_ = modifyFindOptions $ \opts -> opts { findContentsFirst = True }++follow_ :: Monad m => CondT FileEntry m ()+follow_ = modifyFindOptions $ \opts -> opts { findFollowSymlinks = True }++ignoreReaddirRace_ :: Monad m => CondT FileEntry m ()+ignoreReaddirRace_ =+    modifyFindOptions $ \opts -> opts { findIgnoreReaddirRace = True }++noIgnoreReaddirRace_ :: Monad m => CondT FileEntry m ()+noIgnoreReaddirRace_ =+    modifyFindOptions $ \opts -> opts { findIgnoreReaddirRace = False }++maxdepth_ :: Monad m => Int -> CondT FileEntry m ()+maxdepth_ l = getDepth >>= guard . (<= l)++mindepth_ :: Monad m => Int -> CondT FileEntry m ()+mindepth_ l = getDepth >>= guard . (>= l)++prune_ :: Monad m => CondT a m ()+prune_ = prune++-- xdev_ = error "NYI"++timeComp :: MonadIO m+         => ((UTCTime -> Bool) -> CondT FileEntry m ()) -> Int+         -> CondT FileEntry m ()+timeComp f n = do+    now <- liftIO getCurrentTime+    f (\t -> diffUTCTime now t > fromIntegral n)++amin_ :: MonadIO m => Int -> CondT FileEntry m ()+amin_ n = timeComp lastAccessed_ (n * 60)++atime_ :: MonadIO m => Int -> CondT FileEntry m ()+atime_ n = timeComp lastAccessed_ (n * 24 * 3600)++anewer_ :: MonadIO m => FilePath -> CondT FileEntry m ()+anewer_ path = do+    e  <- get+    es <- applyStat Nothing+    ms <- getStat Nothing e { entryPath   = path+                            , entryStatus = Nothing+                            }+    case ms of+        Nothing     -> prune >> error "This is never reached"+        Just (s, _) -> guard $ diffUTCTime (f s) (f es) > 0   where-    vcsDirs = [ ".git", "CVS", "RCS", "SCCS", ".svn", ".hg", "_darcs" ]+    f = posixSecondsToUTCTime . accessTimeHiRes -regex :: Monad m => Text -> Predicate m FileEntry-regex pat = filename_ (=~ pat)+-- cmin_ = error "NYI"+-- cnewer_ = error "NYI"+-- ctime_ = error "NYI" +empty_ :: MonadIO m => CondT FileEntry m ()+empty_ = (regular   >> hasStatus ((== 0) . fileSize))+     <|> (directory >> hasStatus ((== 2) . linkCount))++executable_ :: MonadIO m => CondT FileEntry m ()+executable_ = executable++gid_ :: MonadIO m => Int -> CondT FileEntry m ()+gid_ n = hasStatus ((== n) . fromIntegral . fileGroup)++{-+group_ name+ilname_ pat+iname_ pat+inum_ n+ipath_ pat+iregex_ pat+iwholename_ pat+links_ n+lname_ pat+mmin_+mtime_+-}++name_ :: Monad m => FilePath -> CondT FileEntry m ()+name_ = filename_ . (==)++{-+newer_ path+newerXY_ ref+nogroup_+nouser_+path_ pat+perm_ mode :: Perm+readable_+regex_ pat+samefile_ path+size_ n :: Size+type_ c+uid_ n+used_ n+user_ name+wholename_ pat+writable_+xtype_ c+-}++------------------------------------------------------------------------++-- | Get the current status for the file.  If the status being requested is+--   already cached in the entry information, simply return it from there.+getStat :: MonadIO m+        => Maybe Bool+        -> FileEntry+        -> m (Maybe (FileStatus, FileEntry))+getStat mfollow entry = case entryStatus entry of+    Just s+        | maybe True (== follow entry) mfollow ->+            return $ Just (s, entry)+        | otherwise -> fmap (, entry) `liftM` wrapStat+    Nothing -> do+        ms <- wrapStat+        case ms of+            Just s  -> return $ Just (s, entry { entryStatus = Just s })+            Nothing -> return Nothing+  where+    follow = findFollowSymlinks . entryFindOptions+    doStat = (if fromMaybe (follow entry) mfollow+              then getFileStatus+              else getSymbolicLinkStatus) $ encodeString (entryPath entry)+    wrapStat = liftIO $ catch (Just <$> doStat) $ \e ->+        if findIgnoreReaddirRace opts+        then return Nothing+        else throwIO (e :: IOException)+      where+        opts = entryFindOptions entry++applyStat :: MonadIO m => Maybe Bool -> CondT FileEntry m FileStatus+applyStat mfollow = do+    e <- get+    ms <- lift (getStat mfollow e)+    case ms of+        Nothing      -> prune >> error "This is never reached"+        Just (s, e') -> s <$ put e'++lstat :: MonadIO m => CondT FileEntry m FileStatus+lstat = applyStat (Just False)++stat :: MonadIO m => CondT FileEntry m FileStatus+stat = applyStat (Just True)++hasStatus :: MonadIO m => (FileStatus -> Bool) -> CondT FileEntry m ()+hasStatus f = guard . f =<< applyStat Nothing++regular :: MonadIO m => CondT FileEntry m ()+regular = hasStatus isRegularFile++executable :: MonadIO m => CondT FileEntry m ()+executable = hasMode ownerExecuteMode++directory :: MonadIO m => CondT FileEntry m ()+directory = hasStatus isDirectory++hasMode :: MonadIO m => FileMode -> CondT FileEntry m ()+hasMode m = hasStatus (\s -> fileMode s .&. m /= 0)++withStatusTime :: MonadIO m+               => (FileStatus -> POSIXTime) -> (UTCTime -> Bool)+               -> CondT FileEntry m ()+withStatusTime g f = hasStatus (f . posixSecondsToUTCTime . g)++lastAccessed_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m ()+lastAccessed_ = withStatusTime accessTimeHiRes++lastModified_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m ()+lastModified_ = withStatusTime modificationTimeHiRes+ -- | This is a re-export of 'Text.Regex.Posix.=~', with the types changed for---   ease of use with this module.  For example, you can simply say:+--   use with this module.  For example, you can simply say: -- -- @ --    filename_ (=~ \"\\\\.hs$\")@@ -209,9 +434,19 @@ (=~) :: FilePath -> Text -> Bool str =~ pat = encodeString str R.=~ unpack pat +regex :: Monad m => Text -> CondT FileEntry m ()+regex pat = filename_ (=~ pat)++-- | Return all entries, except for those within version-control metadata+--   directories (and not including the version control directory itself either).+ignoreVcs :: Monad m => CondT FileEntry m ()+ignoreVcs = when_ (filename_ (`elem` vcsDirs)) prune+  where+    vcsDirs = [ ".git", "CVS", "RCS", "SCCS", ".svn", ".hg", "_darcs" ]+ -- | Find every entry whose filename part matching the given filename globbing --   expression.  For example: @glob "*.hs"@.-glob :: Monad m => Text -> Predicate m FileEntry+glob :: Monad m => Text -> CondT FileEntry m () glob g = case parseOnly globParser g of     Left e  -> error $ "Failed to parse glob: " ++ e     Right x -> regex ("^" <> x <> "$")@@ -223,7 +458,7 @@         <|> string "[]]" *> return "[]]"         <|> (\x y z -> pack ((x:y) ++ [z]))                 <$> char '['-                <*> manyTill anyChar (try (char ']'))+                <*> manyTill anyChar (A.try (char ']'))                 <*> char ']'         <|> do             x <- anyChar@@ -231,145 +466,78 @@                             then ['\\', x]                             else [x] -doStat :: MonadIO m => (String -> IO FileStatus) -> Predicate m FileEntry-doStat getstatus = do-    entry <- get-    s <- liftIO $ getstatus (encodeString (entryPath entry))-    put $ entry { entryStatus = Just s }--lstat :: MonadIO m => Predicate m FileEntry-lstat = doStat getSymbolicLinkStatus--stat :: MonadIO m => Predicate m FileEntry-stat = doStat getFileStatus--getStatus :: FileEntry -> FileStatus-getStatus e = fromMaybe-    (error $ "FileStatus has not been determined for: " ++ show (entryPath e))-    (entryStatus e)--withFileStatus :: Monad m-               => (FileStatus -> m Bool)-               -> Predicate m FileEntry-withFileStatus f = ifM_ (f . getStatus)--status :: Monad m => (FileStatus -> Bool) -> Predicate m FileEntry-status f = withFileStatus (return . f)--regular :: Monad m => Predicate m FileEntry-regular = status isRegularFile--directory :: Monad m => Predicate m FileEntry-directory = status isDirectory--hasMode :: Monad m => FileMode -> Predicate m FileEntry-hasMode m = status (\s -> fileMode s .&. m /= 0)--executable :: Monad m => Predicate m FileEntry-executable = hasMode ownerExecuteMode--withPath :: Monad m-         => (FilePath -> m Bool)-         -> Predicate m FileEntry-withPath f = ifM_ (f . entryPath)--filename_ :: Monad m => (FilePath -> Bool) -> Predicate m FileEntry-filename_ f = withPath (return . f . filename)--filenameS_ :: Monad m => (String -> Bool) -> Predicate m FileEntry-filenameS_ f = withPath (return . f . encodeString . filename)--filepath_ :: Monad m => (FilePath -> Bool) -> Predicate m FileEntry-filepath_ f = withPath (return . f)--filepathS_ :: Monad m => (String -> Bool) -> Predicate m FileEntry-filepathS_ f = withPath (return . f . encodeString)--depth :: Monad m => (Int -> Bool) -> Predicate m FileEntry-depth f = if_ (f . entryDepth)--withStatusTime :: Monad m-               => (UTCTime -> Bool) -> (FileStatus -> POSIXTime)-               -> Predicate m FileEntry-withStatusTime f g = status (f . posixSecondsToUTCTime . g)+-- | Find file entries in a directory tree, recursively, applying the given+--   recursion predicate to the search.  This conduit yields pairs of type+--   @(FileEntry, a)@, where is the return value from the predicate at each+--   step.+findFilesSource :: (MonadIO m, MonadResource m)+                => FindOptions+                -> FilePath+                -> CondT FileEntry m a+                -> Producer m (FileEntry, a)+findFilesSource opts startPath predicate =+    wrap $ go (newFileEntry startPath 0 opts) $ hoist lift predicate+  where+    wrap = mapInput (const ()) (const Nothing) -lastAccessed :: Monad m => (UTCTime -> Bool) -> Predicate m FileEntry-lastAccessed = flip withStatusTime accessTimeHiRes+    go x pr = applyCondT x pr $ \e mb mcond -> do+        let opts' = entryFindOptions e+            this  = unless (findIgnoreResults opts') $+                        yieldEntry e mb+            next  = walkChildren e mcond+        if findContentsFirst opts'+            then next >> this+            else this >> next -lastModified :: Monad m => (UTCTime -> Bool) -> Predicate m FileEntry-lastModified = flip withStatusTime modificationTimeHiRes+    yieldEntry e mb =+        -- If the item matched, also yield the predicate's result value.+        forM_ mb $ yield . (e,) --- | A raw find does no processing on the FileEntry, leaving it up to the user---   to determine when and if stat should be called.  Note that unless you---   take care to indicate when recursion should happen, an error will result---   when the raw finder attempts to recurse on a non-directory.  The bare---   minimum for a proper finder should look like this for non-recursion:------ @--- findRaw \<path\> $ do---     \<apply predicates needing only pathname or depth\>---     localM stat $ do---         directory ||: norecurse---         \<apply predicates needing stat info\>--- @------ To apply predicates only to a single directory, without recursing, simply--- start (or end) the predicate with 'norecurse', and use @localM stat@ or--- @localM lstat@ at the point where you need 'FileStatus' information.-findRaw :: (MonadIO m, MonadResource m)-        => FilePath -> Bool -> Predicate m FileEntry -> Source m FileEntry-findRaw path follow predicate =-    traverseRecursively-        (newFileEntry path 0)-        predicate-        (const . yield)-        lift-        readDirectory-  where-    readDirectory (FileEntry p d mst) go = do-        -- If no status has been determined yet, we must now in order to know-        -- whether to traverse or not.-        recurse <- isDirectory <$> case mst of-            Nothing -> liftIO $ (if follow-                                 then getFileStatus-                                 else getSymbolicLinkStatus)-                              $ encodeString p-            Just st -> return st-        when recurse $-            (sourceDirectory p =$) $ awaitForever $ \fp ->-                mapInput (const ()) (const Nothing) $-                    go $ newFileEntry fp (succ d)+    walkChildren e@(FileEntry path depth opts' _) mcond =+        -- If the conditional matched, we are requested to recurse if this+        -- is a directory+        forM_ mcond $ \cond -> do+            -- If no status has been determined, we must do so now in order+            -- to know whether to actually recurse or not.+            descend <- fmap (isDirectory . fst) <$> getStat Nothing e+            when (descend == Just True) $+                (sourceDirectory path =$) $ awaitForever $ \fp ->+                    wrap $ go (newFileEntry fp (succ depth) opts') cond -basicFind :: (MonadIO m, MonadResource m)-          => Predicate m FileEntry-          -> Bool+findFiles :: (MonadIO m, MonadBaseControl IO m, MonadThrow m)+          => FindOptions           -> FilePath-          -> Predicate m FileEntry-          -> Source m FileEntry-basicFind f follow path pr = findRaw path follow $-    f >> (directory ||: norecurse) >> pr+          -> CondT FileEntry m a+          -> m ()+findFiles opts path predicate =+    runResourceT $ findFilesSource+        opts { findIgnoreResults = True } path (hoist lift predicate)+        $$ sinkNull -find' :: (MonadIO m, MonadResource m)-      => FilePath -> Predicate m FileEntry-      -> Source m FileEntry-find' = basicFind stat True+-- | A simpler version of 'findFiles', which yields only 'FilePath' values,+--   and ignores any values returned by the predicate action.+findFilePaths :: (MonadIO m, MonadResource m)+              => FindOptions+              -> FilePath+              -> CondT FileEntry m a+              -> Producer m FilePath+findFilePaths opts path predicate =+    findFilesSource opts path predicate =$= mapC (entryPath . fst) +-- | Calls 'findFilePaths' with the default set of finding options.+--   Equivalent to @findFilePaths defaultFindOptions@. find :: (MonadIO m, MonadResource m)-     => FilePath -> Predicate m FileEntry-     -> Source m FilePath-find path pr = find' path pr =$= mapC entryPath--lfind' :: (MonadIO m, MonadResource m)-       => FilePath -> Predicate m FileEntry-       -> Source m FileEntry-lfind' = basicFind lstat False+     => FilePath -> CondT FileEntry m a -> Producer m FilePath+find = findFilePaths defaultFindOptions -lfind :: (MonadIO m, MonadResource m)-      => FilePath -> Predicate m FileEntry-      -> Source m FilePath-lfind path pr = lfind' path pr =$= mapC entryPath+-- | Test a file path using the same type of predicate that is accepted by+--   'findFiles'.+test :: MonadIO m => CondT FileEntry m () -> FilePath -> m Bool+test matcher path =+    Cond.test matcher (newFileEntry path 0 defaultFindOptions) --- | Test a file path using the same type of 'Predicate' that is accepted by---   'find'.-test :: MonadIO m => Predicate m FileEntry -> FilePath -> m Bool-test matcher path = Cond.test (stat >> matcher) (newFileEntry path 0)+-- | Test a file path using the same type of predicate that is accepted by+--   'findFiles', but do not follow symlinks.+ltest :: MonadIO m => CondT FileEntry m () -> FilePath -> m Bool+ltest matcher path = Cond.test matcher+    (newFileEntry path 0 defaultFindOptions { findFollowSymlinks = False })

@@ -1,5 +1,5 @@ Name:                find-conduit-Version:             0.3.0+Version:             0.4.0 Synopsis:            A file-finding conduit that allows user control over traversals. License-file:        LICENSE License:             MIT@@ -34,6 +34,7 @@       , time       , transformers       , transformers-base+      , mmorph       , monad-control     exposed-modules:         Data.Conduit.Find@@ -63,4 +64,5 @@       , transformers       , transformers-base       , monad-control+      , mmorph       , hspec                >= 1.4

@@ -24,13 +24,12 @@         it "finds files" $ do             xs <- runResourceT $                 find "."-                    (    ignoreVcs-                     >> prune (filename_ (== "dist"))-                     >> glob "*.hs"-                     >> not_ (glob "Setup*")-                     >> regular-                     >> not_ executable-                    )+                    (do ignoreVcs+                        when_ (name_ "dist") prune+                        glob "*.hs"+                        not_ (glob "Setup*")+                        regular+                        not_ executable)                     $$ sinkList              "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True@@ -41,15 +40,15 @@         it "finds files with a different ordering" $ do             xs <- runResourceT $                 find "."-                    (    ignoreVcs-                     >> glob "*.hs"-                     >> not_ (glob "Setup*")-                     -- This prune only applies to .hs files now, so it won't-                     -- match anything, thus having no effect but burning CPU!-                     >> prune (filename_ (== "dist"))-                     >> regular-                     >> not_ executable-                    )+                    (do ignoreVcs+                        glob "*.hs"+                        not_ (glob "Setup*")+                        -- This applies only to .hs files now, so it won't+                        -- match anything, thus having no effect but burning+                        -- CPU!+                        when_ (name_ "dist") prune+                        regular+                        not_ executable)                     $$ sinkList              "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True@@ -59,15 +58,14 @@          it "finds files using a pre-pass filter" $ do             xs <- runResourceT $-                findRaw "." True+                find "."                     (do ignoreVcs-                        prune (filename_ (== "dist"))+                        when_ (name_ "dist") prune                         glob "*.hs"                         not_ (glob "Setup*")-                        stat                         regular                         not_ executable)-                    =$ mapC entryPath $$ sinkList+                    $$ sinkList              "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True             "./dist/setup-config" `elem` xs `shouldBe` False@@ -76,16 +74,15 @@          it "properly applies post-pass pruning" $ do             xs <- runResourceT $-                findRaw "." True+                find "."                     (do ignoreVcs-                        prune (depth (>=1))-                        prune (filename_ (== "dist"))+                        maxdepth_ 1+                        when_ (name_ "dist") prune                         glob "*.hs"                         not_ (glob "Setup*")-                        stat                         regular                         not_ executable)-                    =$ mapC entryPath $$ sinkList+                    $$ sinkList              "./Data/Conduit/Find.hs" `elem` xs `shouldBe` False             "./dist/setup-config" `elem` xs `shouldBe` False