conduit-find 0.1.0.3 → 0.1.0.4

raw patch · 8 files changed

+1265/−1208 lines, 8 filesdep +resourcetdep +transformers-eitherdep +unliftio-coredep −directorydep −doctestdep ~basedep ~conduitdep ~filepathPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: resourcet, transformers-either, unliftio-core

Dependencies removed: directory, doctest

Dependency ranges changed: base, conduit, filepath, semigroups, text, unix, unix-compat

API changes (from Hackage documentation)

Files

• Data/Cond.hs +0/−515
• Data/Conduit/Find.hs +0/−610
• conduit-find.cabal +36/−18
• src/Data/Cond.hs +560/−0
• src/Data/Conduit/Find.hs +618/−0
• test/doctest.hs +0/−29
• test/find-hs.hs +32/−14
• test/main.hs +19/−22

@@ -1,515 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-}--module Data.Cond-    ( CondT(..), Cond--    -- * Executing CondT-    , runCondT, runCond, applyCondT, applyCond--    -- * Promotions-    , guardM, guard_, guardM_, apply, consider--    -- * Boolean logic-    , matches, if_, when_, unless_, or_, and_, not_--    -- * Basic conditionals-    , ignore, norecurse, prune--    -- * Helper functions-    , recurse, test--    -- * Isomorphism with a stateful EitherT-    , CondEitherT(..), fromCondT, toCondT-    ) where--import Control.Applicative-import Control.Arrow (first)-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-import Control.Monad.Trans.Control-import Control.Monad.Trans.Either-import Control.Monad.Trans.State (StateT(..), withStateT, evalStateT)-import Data.Foldable-import Data.Functor.Identity-import Data.Maybe (fromMaybe, isJust)-import Data.Monoid hiding ((<>))-import Data.Semigroup-import Prelude hiding (mapM_, foldr1, sequence_)---- | '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 performed.-data Result a m b = Ignore-                  | Keep b-                  | RecurseOnly (Maybe (CondT a m b))-                  | KeepAndRecurse b (Maybe (CondT a m b))--instance Show b => Show (Result a m b) where-    show Ignore               = "Ignore"-    show (Keep a)             = "Keep " ++ show a-    show (RecurseOnly _)      = "RecurseOnly"-    show (KeepAndRecurse a _) = "KeepAndRecurse " ++ show a--instance Monad m => Functor (Result a m) where-    fmap _ Ignore               = Ignore-    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-    RecurseOnly _ <> Keep _             = Ignore-    RecurseOnly _ <> KeepAndRecurse _ m = RecurseOnly m-    RecurseOnly m <> _                  = RecurseOnly m-    Keep _        <> RecurseOnly _      = Ignore-    _             <> RecurseOnly m      = RecurseOnly m-    _             <> Keep b             = Keep b-    Keep _        <> KeepAndRecurse b _ = Keep b-    _             <> KeepAndRecurse b m = KeepAndRecurse b m-    {-# INLINE (<>) #-}--instance Monoid b => Monoid (Result a m b) where-    mempty  = KeepAndRecurse mempty Nothing-    {-# INLINE mempty #-}-    mappend = (<>)-    {-# INLINE mappend #-}--getResult :: Result a m b -> (Maybe b, Maybe (CondT a m b))-getResult Ignore               = (Nothing, Nothing)-getResult (Keep b)             = (Just b, Nothing)-getResult (RecurseOnly c)      = (Nothing, c)-getResult (KeepAndRecurse b c) = (Just b, c)--setRecursion :: CondT a m b -> Result a m b -> Result a m b-setRecursion _ Ignore               = Ignore-setRecursion _ (Keep b)             = Keep b-setRecursion c (RecurseOnly _)      = RecurseOnly (Just c)-setRecursion c (KeepAndRecurse b _) = KeepAndRecurse b (Just c)--accept' :: b -> Result a m b-accept' = flip KeepAndRecurse Nothing--recurse' :: Result a m b-recurse' = RecurseOnly Nothing---- | Convert from a 'Maybe' value to its corresponding 'Result'.------ >>> maybeToResult Nothing :: Result () Identity ()--- RecurseOnly--- >>> maybeToResult (Just ()) :: Result () Identity ()--- KeepAndRecurse ()-maybeToResult :: Maybe a -> Result r m a-maybeToResult Nothing  = recurse'-maybeToResult (Just a) = accept' a--maybeFromResult :: Result r m a -> Maybe a-maybeFromResult Ignore               = Nothing-maybeFromResult (Keep a)             = Just a-maybeFromResult (RecurseOnly _)      = Nothing-maybeFromResult (KeepAndRecurse a _) = Just a---- | 'CondT' is a kind of @StateT a (MaybeT m) b@, which uses a special---   'Result' type instead of 'Maybe' to express whether recursion should be---   performed from the item under consideration.  This is used to build---   predicates that can guide recursive traversals.------ Several different types may be promoted to 'CondT':------   [@Bool@]                  Using 'guard'------   [@m Bool@]                Using 'guardM'------   [@a -> Bool@]              Using 'guard_'------   [@a -> m Bool@]            Using 'guardM_'------   [@a -> m (Maybe b)@]       Using 'apply'------   [@a -> m (Maybe (b, a))@]  Using 'consider'------ Here is a trivial example:------ @--- flip runCondT 42 $ do---   guard_ even---   liftIO $ putStrLn "42 must be even to reach here"---   guard_ odd \<|\> guard_ even---   guard_ (== 42)--- @------ If 'CondT' is executed using 'runCondT', it return a @Maybe b@ if the--- predicate matched.  It can also be run with 'applyCondT', which does case--- analysis on the 'Result', specifying how recursion should be performed from--- the given 'a' value.-newtype CondT a m b = CondT { getCondT :: StateT a m (Result a m b) }--type Cond a = CondT a Identity--instance Show (CondT a m b) where-    show _ = "CondT"--instance (Monad m, Semigroup b) => Semigroup (CondT a m b) where-    (<>) = liftM2 (<>)-    {-# INLINE (<>) #-}--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-#if __GLASGOW_HASKELL__ < 710-    -- GHC 8.0.1 seems to go into some sort of optimiser loop with -O1 and above-    -- if this is `liftM`, but for GHC 7.8 `Applicative` is not a super class-    -- of `Monad` so we still need this.-    -- See: https://ghc.haskell.org/trac/ghc/ticket/12425-    fmap f (CondT g) = CondT (liftM (fmap f) g)-#else-    fmap f (CondT g) = CondT (liftA (fmap f) g)-#endif-    {-# 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'-    {-# INLINE return #-}-    fail _ = mzero-    {-# INLINE fail #-}-    CondT f >>= k = CondT $ do-        r <- f-        case r of-            Ignore -> return Ignore-            Keep b -> do-                n <- getCondT (k b)-                return $ case n of-                    RecurseOnly _      -> Ignore-                    KeepAndRecurse c _ -> Keep c-                    _                  -> n-            RecurseOnly l -> return $ RecurseOnly (fmap (>>= k) l)-            KeepAndRecurse b _ -> getCondT (k b)--instance Monad m => MonadReader a (CondT a m) where-    ask               = CondT $ gets accept'-    {-# INLINE ask #-}-    local f (CondT m) = CondT $ withStateT f m-    {-# INLINE local #-}-    reader f          = liftM f ask-    {-# INLINE reader #-}--instance Monad m => MonadState a (CondT a m) where-    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 => 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-    {-# INLINE throwM #-}--instance MonadCatch m => MonadCatch (CondT a m) where-    catch (CondT m) c = CondT $ m `catch` \e -> getCondT (c e)--instance MonadMask m => MonadMask (CondT a m) where-    mask a = CondT $ mask $ \u -> getCondT (a $ q u)-      where q u = CondT . u . getCondT-    uninterruptibleMask a =-        CondT $ uninterruptibleMask $ \u -> getCondT (a $ q u)-      where q u = CondT . u . getCondT--instance MonadBase b m => MonadBase b (CondT a m) where-    liftBase m = CondT $ liftM accept' $ liftBase m-    {-# INLINE liftBase #-}--instance MonadIO m => MonadIO (CondT a m) where-    liftIO m = CondT $ liftM accept' $ liftIO m-    {-# INLINE liftIO #-}--instance MonadTrans (CondT a) where-    lift m = CondT $ liftM accept' $ lift m-    {-# INLINE lift #-}--instance MonadBaseControl b m => MonadBaseControl b (CondT r m) where-    type StM (CondT r m) a = StM m (Result r m a, r)-    liftBaseWith f = CondT $ StateT $ \s ->-        liftM (\x -> (accept' x, s)) $ liftBaseWith $ \runInBase -> f $ \k ->-            runInBase $ runStateT (getCondT k) s-    restoreM = CondT . StateT . const . restoreM-    {-# 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 = maybeFromResult `liftM` evalStateT f a-{-# INLINE runCondT #-}--runCond :: Cond a b -> a -> Maybe b-runCond = (runIdentity .) . runCondT-{-# INLINE runCond #-}---- | Case analysis of applying a condition to an input value.  The result is a---   pair whose first part is a pair of Maybes specifying if the input matched---   and if recursion is expected from this value, and whose second part is---   the (possibly) mutated input value.-applyCondT :: Monad m-           => a-           -> CondT a m b-           -> m ((Maybe b, Maybe (CondT a m b)), a)-applyCondT a cond = do-    -- Apply a condition to the input value, determining the result and the-    -- mutated value.-    (r, a') <- runStateT (getCondT cond) a--    -- Convert from the 'Result' to a pair of Maybes: one to specify if the-    -- predicate succeeded, and the other to specify if recursion should be-    -- performed.  If there is no sub-recursion specified, return 'cond'.-    return (fmap (Just . fromMaybe cond) (getResult r), a')-{-# INLINE applyCondT #-}---- | Case analysis of applying a pure condition to an input value.  The result---   is a pair whose first part is a pair of Maybes specifying if the input---   matched and if recursion is expected from this value, and whose second---   part is the (possibly) mutated input value.-applyCond :: a -> Cond a b -> ((Maybe b, Maybe (Cond a b)), a)-applyCond a cond = first (fmap (Just . fromMaybe cond) . getResult)-                       (runIdentity (runStateT (getCondT cond) a))-{-# INLINE applyCond #-}--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 = asks f >>= guard-{-# 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 $ get >>= liftM maybeToResult . lift . f-{-# INLINE apply #-}--consider :: Monad m => (a -> m (Maybe (b, a))) -> CondT a m b-consider f = CondT $ do-    mres <- lift . f =<< get-    case mres of-        Nothing      -> return Ignore-        Just (b, a') -> put a' >> return (accept' b)-{-# INLINE consider #-}---- | Return True or False depending on whether the given condition matches or---   not.  This differs from simply stating the condition in that it itself---   always succeeds.------ >>> flip runCond "foo.hs" $ matches (guard =<< asks (== "foo.hs"))--- Just True--- >>> flip runCond "foo.hs" $ matches (guard =<< asks (== "foo.hi"))--- Just False-matches :: Monad m => CondT a m b -> CondT a m Bool-matches = fmap isJust . optional-{-# INLINE matches #-}---- | A variant of ifM which branches on whether the condition succeeds or not.---   Note that @if_ x@ is equivalent to @ifM (matches x)@, and is provided---   solely for convenience.------ >>> let good = guard_ (== "foo.hs") :: Cond String ()--- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()--- >>> flip runCond "foo.hs" $ if_ good (return "Success") (return "Failure")--- Just "Success"--- >>> flip runCond "foo.hs" $ if_ bad (return "Success") (return "Failure")--- Just "Failure"-if_ :: Monad m => CondT a m r -> CondT a m b -> CondT a m b -> CondT a m b-if_ c x y =-    CondT $ getCondT . maybe y (const x) . maybeFromResult =<< getCondT c-{-# INLINE if_ #-}---- | 'when_' is just like 'when', except that it executes the body if the---   condition passes, rather than based on a Bool value.------ >>> let good = guard_ (== "foo.hs") :: Cond String ()--- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()--- >>> flip runCond "foo.hs" $ when_ good ignore--- Nothing--- >>> flip runCond "foo.hs" $ when_ bad ignore--- Just ()-when_ :: Monad m => CondT a m r -> CondT a m () -> CondT a m ()-when_ c x = if_ c (void x) (return ())-{-# INLINE when_ #-}---- | 'when_' is just like 'when', except that it executes the body if the---   condition fails, rather than based on a Bool value.------ >>> let good = guard_ (== "foo.hs") :: Cond String ()--- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()--- >>> flip runCond "foo.hs" $ unless_ bad ignore--- Nothing--- >>> flip runCond "foo.hs" $ unless_ good ignore--- Just ()-unless_ :: Monad m => CondT a m r -> CondT a m () -> CondT a m ()-unless_ c = if_ c (return ()) . void-{-# INLINE unless_ #-}---- | Check whether at least one of the given conditions is true.  This is a---   synonym for 'Data.Foldable.asum'.------ >>> let good = guard_ (== "foo.hs") :: Cond String ()--- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()--- >>> flip runCond "foo.hs" $ or_ [bad, good]--- Just ()--- >>> flip runCond "foo.hs" $ or_ [bad]--- Nothing-or_ :: Monad m => [CondT a m b] -> CondT a m b-or_ = asum-{-# INLINE or_ #-}---- | Check that all of the given conditions are true.  This is a synonym for---   'Data.Foldable.sequence_'.------ >>> let good = guard_ (== "foo.hs") :: Cond String ()--- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()--- >>> flip runCond "foo.hs" $ and_ [bad, good]--- Nothing--- >>> flip runCond "foo.hs" $ and_ [good]--- Just ()-and_ :: Monad m => [CondT a m b] -> CondT a m ()-and_ = sequence_-{-# INLINE and_ #-}---- | 'not_' inverts the meaning of the given predicate.------ >>> let good = guard_ (== "foo.hs") :: Cond String ()--- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()--- >>> flip runCond "foo.hs" $ not_ bad >> return "Success"--- Just "Success"--- >>> flip runCond "foo.hs" $ not_ good >> return "Shouldn't reach here"--- Nothing-not_ :: Monad m => CondT a m b -> CondT a m ()-not_ c = when_ c ignore-{-# INLINE not_ #-}---- | '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 #-}---- | '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 #-}---- | '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 b-prune = CondT $ return Ignore-{-# INLINE prune #-}---- | '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 looks only for a file named @config@:------ @--- if_ (name_ \".git\" \>\> directory)---     (ignore \>\> recurse (name_ \"config\"))---     (glob \"*.hs\")--- @------ NOTE: 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 $ setRecursion c `liftM` getCondT c-{-# INLINE recurse #-}---- | A specialized variant of 'runCondT' that simply returns True or False.------ >>> let good = guard_ (== "foo.hs") :: Cond String ()--- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()--- >>> runIdentity $ test "foo.hs" $ not_ bad >> return "Success"--- True--- >>> runIdentity $ test "foo.hs" $ not_ good >> return "Shouldn't reach here"--- False-test :: Monad m => a -> CondT a m b -> m Bool-test = (liftM isJust .) . flip runCondT-{-# INLINE test #-}---- | This type is for documentation only, and shows the isomorphism between---   'CondT' and 'CondEitherT'.  The reason for using 'Result' is that it---   makes meaning of the constructors more explicit.-newtype CondEitherT a m b = CondEitherT-    (StateT a (EitherT (Maybe (Maybe (CondEitherT a m b))) m)-         (b, Maybe (Maybe (CondEitherT a m b))))---- | Witness one half of the isomorphism from 'CondT' to 'CondEitherT'.-fromCondT :: Monad m => CondT a m b -> CondEitherT a m b-fromCondT (CondT f) = CondEitherT $ do-    s <- get-    (r, s') <- lift $ lift $ runStateT f s-    case r of-        Ignore             -> lift $ left Nothing-        Keep a             -> put s' >> return (a, Nothing)-        RecurseOnly m      -> lift $ left (Just (fmap fromCondT m))-        KeepAndRecurse a m -> put s' >> return (a, Just (fmap fromCondT m))---- | Witness the other half of the isomorphism from 'CondEitherT' to 'CondT'.-toCondT :: Monad m => CondEitherT a m b -> CondT a m b-toCondT (CondEitherT f) = CondT $ do-    s <- get-    eres <- lift $ runEitherT $ runStateT f s-    case eres of-        Left Nothing             -> return Ignore-        Right ((a, Nothing), s') -> put s' >> return (Keep a)-        Left (Just m)            -> return $ RecurseOnly (fmap toCondT m)-        Right ((a, Just m), s')  ->-            put s' >> return (KeepAndRecurse a (fmap toCondT m))

@@ -1,610 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.Conduit.Find-    (-    -- * Introduction-    -- $intro--    -- ** Basic comparison with GNU find-    -- $gnufind--    -- ** Performance-    -- $performance--    -- ** Other notes-    -- $notes--    -- * Finding functions-      sourceFindFiles-    , find-    , findFiles-    , findFilePaths-    , FindOptions(..)-    , defaultFindOptions-    , test-    , ltest-    , stat-    , lstat-    , hasStatus--      -- * File path predicates-    , glob-    , regex-    , ignoreVcs--      -- * GNU find compatibility predicates-    , depth_-    , follow_-    , noleaf_-    , prune_-    , maxdepth_-    , mindepth_-    , ignoreErrors_-    , noIgnoreErrors_-    , amin_-    , atime_-    , anewer_-    , empty_-    , executable_-    , gid_-    , name_-    , getDepth-    , filename_-    , pathname_-    , getFilePath--    -- * File entry predicates (uses stat information)-    , regular-    , directory-    , hasMode-    , executable-    , lastAccessed_-    , lastModified_--    -- * Predicate combinators-    , module Cond-    , (=~)--    -- * Types and type classes-    , FileEntry(..)-    ) where--import           Conduit-import           Control.Applicative-import           Control.Exception-import           Control.Monad hiding (forM_, forM)-import           Control.Monad.Morph-import           Control.Monad.State.Class-import           Data.Attoparsec.Text as A-import           Data.Bits-import qualified Data.Cond as Cond-import           Data.Cond hiding (test)-import qualified Data.Conduit.Filesystem as CF-#if LEAFOPT-import           Data.IORef-#endif-import           Data.Maybe (fromMaybe,fromJust)-import           Data.Monoid-import           Data.Text (Text, unpack, pack)-import           Data.Time-import           Data.Time.Clock.POSIX-import qualified System.FilePath as FP-import           System.PosixCompat.Files-import           System.PosixCompat.Types-import           Text.Regex.Posix ((=~))--{- $intro--**find-conduit** is essentially a souped version of GNU find for Haskell,-using a DSL to provide both ease of us, and extensive flexbility.--In its simplest form, let's compare some uses of find to find-conduit.  Bear-in mind that the result of the find function is a conduit, so you're expected-to either sink it to a list, or operate on the file paths as they are yielded.--}--{- $gnufind--A typical find command:--@-find src -name '*.hs' -type f -print-@--Would in find-conduit be:--@-find "src" (glob \"*.hs\" \<\> regular) $$ mapM_C (liftIO . print)-@--The 'glob' predicate matches the file basename against the globbing pattern,-while the 'regular' predicate matches plain files.--A more complicated example:--@-find . -size +100M -perm 644 -mtime 1-@--Now in find-conduit:--@-let megs = 1024 * 1024-    days = 86400-now <- liftIO getCurrentTime-find \".\" ( fileSize (> 100*megs)-        \<\> hasMode 0o644-        \<\> lastModified (> addUTCTime now (-(1*days)))-         )-@--Appending predicates like this expressing an "and" relationship.  Use '<|>' to-express "or".  You can also negate any predicate:--@-find \".\" (not_ (hasMode 0o644))-@--By default, predicates, whether matching or not, will allow recursion into-directories.  In order to express that matching predicate should disallow-recursion, use 'prune':--@-find \".\" (prune (depth (> 2)))-@--This is the same as using '-maxdepth 2' in find.--@-find \".\" (prune (filename_ (== \"dist\")))-@--This is the same as:--@-find . \\( -name dist -prune \\) -o -print-@--}--{- $performance--find-conduit strives to make file-finding a well performing operation.  To-this end, a composed Predicate will only call stat once per entry being-considered; and if you prune a directory, it is not traversed at all.--By default, 'find' calls stat for every file before it applies the predicate,-in order to ensure that only one such call is needed.  Sometimes, however, you-know just from the FilePath that you don't want to consider a certain file, or-you want to prune a directory tree.--To support these types of optimized queries, a variant of find is provided-called 'findWithPreFilter'.  This takes two predicates: one that is applied to-only the FilePath, before stat (or lstat) is called; and one that is applied-to the full file information after the stat.--}--{- $notes--See 'Data.Cond' for more details on the Monad used to build predicates.--}--data FindOptions = FindOptions-    { findFollowSymlinks   :: !Bool-    , findContentsFirst    :: !Bool-    , findIgnoreErrors     :: !Bool-    , findIgnoreResults    :: !Bool-    , findLeafOptimization :: !Bool-    }--defaultFindOptions :: FindOptions-defaultFindOptions = FindOptions-    { findFollowSymlinks   = True-    , findContentsFirst    = False-    , findIgnoreErrors     = False-    , findIgnoreResults    = False-    , findLeafOptimization = True-    }--data FileEntry = FileEntry-    { entryPath        :: !FP.FilePath-    , entryDepth       :: !Int-    , entryFindOptions :: !FindOptions-    , entryStatus      :: !(Maybe FileStatus)-      -- ^ This is Nothing until we determine stat should be called.-    }--newFileEntry :: FP.FilePath -> Int -> FindOptions -> FileEntry-newFileEntry fp d f = FileEntry fp d f Nothing--instance Show FileEntry where-    show entry = "FileEntry "-              ++ show (entryPath entry)-              ++ " " ++ show (entryDepth entry)--getFilePath :: Monad m => CondT FileEntry m FP.FilePath-getFilePath = gets entryPath--pathname_ :: Monad m => (FP.FilePath -> Bool) -> CondT FileEntry m ()-pathname_ f = guard . f =<< getFilePath--filename_ :: Monad m => (FP.FilePath -> Bool) -> CondT FileEntry m ()-filename_ f = pathname_ (f . FP.takeFileName)--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 }--noleaf_ :: Monad m => CondT FileEntry m ()-noleaf_ = modifyFindOptions $ \opts -> opts { findLeafOptimization = False }--prune_ :: Monad m => CondT a m ()-prune_ = prune--ignoreErrors_ :: Monad m => CondT FileEntry m ()-ignoreErrors_ =-    modifyFindOptions $ \opts -> opts { findIgnoreErrors = True }--noIgnoreErrors_ :: Monad m => CondT FileEntry m ()-noIgnoreErrors_ =-    modifyFindOptions $ \opts -> opts { findIgnoreErrors = 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)---- 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 => FP.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-    f = posixSecondsToUTCTime . realToFrac . accessTime---- 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 => FP.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--}----------------------------------------------------------------------------statFilePath :: Bool -> Bool -> FP.FilePath -> IO (Maybe FileStatus)-statFilePath follow ignoreErrors path = do-    let doStat = (if follow-                  then getFileStatus-                  else getSymbolicLinkStatus) path-    catch (Just <$> doStat) $ \e ->-        if ignoreErrors-        then return Nothing-        else throwIO (e :: IOException)---- | 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-        return $ case ms of-            Just s  -> Just (s, entry { entryStatus = Just s })-            Nothing -> Nothing-  where-    follow   = findFollowSymlinks . entryFindOptions-    wrapStat = liftIO $ statFilePath-        (fromMaybe (findFollowSymlinks opts) mfollow)-        (findIgnoreErrors opts)-        (entryPath entry)-      where-        opts = entryFindOptions entry--applyStat :: MonadIO m => Maybe Bool -> CondT FileEntry m FileStatus-applyStat mfollow = do-    ms <- lift . getStat mfollow =<< get-    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 -> EpochTime) -> (UTCTime -> Bool)-               -> CondT FileEntry m ()-withStatusTime g f = hasStatus (f . posixSecondsToUTCTime . realToFrac . g)--lastAccessed_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m ()-lastAccessed_ = withStatusTime accessTime--lastModified_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m ()-lastModified_ = withStatusTime modificationTime--regex :: Monad m => String -> 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 => String -> CondT FileEntry m ()-glob g = case parseOnly globParser (pack g) of-    Left e  -> error $ "Failed to parse glob: " ++ e-    Right x -> regex ("^" <> unpack x <> "$")-  where-    globParser :: Parser Text-    globParser = fmap mconcat $ many $-            char '*' *> return ".*"-        <|> char '?' *> return "."-        <|> string "[]]" *> return "[]]"-        <|> (\x y z -> pack ((x:y) ++ [z]))-                <$> char '['-                <*> manyTill anyChar (A.try (char ']'))-                <*> char ']'-        <|> do-            x <- anyChar-            return . pack $ if x `elem` (".()^$" :: String)-                            then ['\\', x]-                            else [x]--#if LEAFOPT-type DirCounter = IORef LinkCount--newDirCounter :: MonadIO m => m DirCounter-newDirCounter = liftIO $ newIORef 1-#else-type DirCounter = ()--newDirCounter :: MonadIO m => m DirCounter-newDirCounter = return ()-#endif---- | 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.-sourceFindFiles :: MonadResource m-                => FindOptions-                -> FilePath-                -> CondT FileEntry m a-                -> Producer m (FileEntry, a)-sourceFindFiles findOptions startPath predicate = do-    startDc <- newDirCounter-    walk startDc-        (newFileEntry startPath 0 findOptions)-        startPath-        predicate-  where-    walk :: MonadResource m-         => DirCounter-         -> FileEntry-         -> FP.FilePath-         -> CondT FileEntry m a-         -> Producer m (FileEntry, a)-    walk !dc !entry !path !cond = do-        ((!mres, !mcond), !entry') <- lift $ applyCondT entry cond-        let opts' = entryFindOptions entry-            this  = unless (findIgnoreResults opts') $-                        yieldEntry entry' mres-            next  = walkChildren dc entry' path mcond-        if findContentsFirst opts'-            then next >> this-            else this >> next-      where-        yieldEntry _      Nothing    = return ()-        yieldEntry entry' (Just res) = yield (entry', res)--    walkChildren :: MonadResource m-                 => DirCounter-                 -> FileEntry-                 -> FP.FilePath-                 -> Maybe (CondT FileEntry m a)-                 -> Producer m (FileEntry, a)-    walkChildren _ _ _ Nothing = return ()-    -- If the conditional matched, we are requested to recurse if this is a-    -- directory-    walkChildren !dc !entry !path (Just !cond) = do-        st <- lift $ checkIfDirectory dc entry path-        when (fmap isDirectory st == Just True) $ do-#if LEAFOPT-            -- Update directory count for the parent directory.-            liftIO $ modifyIORef dc pred-            -- Track the directory count for this child path.-            let leafOpt = findLeafOptimization (entryFindOptions entry)-            let lc = linkCount (fromJust st) - 2-                opts' = (entryFindOptions entry)-                    { findLeafOptimization = leafOpt && lc >= 0-                    }-            dc' <- liftIO $ newIORef lc-#else-            let dc'   = dc-                opts' = entryFindOptions entry-#endif-            CF.sourceDirectory path =$= awaitForever (go dc' opts')-      where-        go dc' opts' fp =-            let entry' = newFileEntry fp (succ (entryDepth entry)) opts'-            in walk dc' entry' fp cond--    -- Return True if the given entry is a directory.  We can sometimes use-    -- "leaf optimization" on Linux to answer this question without performing-    -- a stat call.  This is possible because the link count of a directory is-    -- two more than the number of sub-directories it contains, so we've seen-    -- that many sub-directories, the remaining entries must be files.-    checkIfDirectory :: MonadResource m-                     => DirCounter-                     -> FileEntry-                     -> FP.FilePath-                     -> m (Maybe FileStatus)-    checkIfDirectory !dc !entry !path = do-#if LEAFOPT-        let leafOpt = findLeafOptimization (entryFindOptions entry)-        doStat <- if leafOpt-                  then (> 0) <$> liftIO (readIORef dc)-                  else return True-#else-        let doStat = dc == () -- to quiet hlint warnings-#endif-        let opts = entryFindOptions entry-        if doStat-            then liftIO $ statFilePath-                (findFollowSymlinks opts)-                (findIgnoreErrors opts)-                path-            else return Nothing--findFiles :: (MonadIO m, MonadBaseControl IO m, MonadThrow m)-          => FindOptions-          -> FilePath-          -> CondT FileEntry m a-          -> m ()-findFiles opts path predicate =-    runResourceT $-        sourceFindFiles opts { findIgnoreResults = True } path-            (hoist lift predicate) $$ sinkNull---- | 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 =-    sourceFindFiles opts path predicate =$= mapC (entryPath . fst)---- | Calls 'findFilePaths' with the default set of finding options.---   Equivalent to @findFilePaths defaultFindOptions@.-find :: MonadResource m-     => FilePath -> CondT FileEntry m a -> Producer m FilePath-find = findFilePaths defaultFindOptions---- | 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 (newFileEntry path 0 defaultFindOptions) matcher---- | 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-        (newFileEntry path 0 defaultFindOptions-            { findFollowSymlinks = False })-        matcher

@@ -1,5 +1,5 @@ Name:                conduit-find-Version:             0.1.0.3+Version:             0.1.0.4 Synopsis:            A file-finding conduit that allows user control over traversals. License-file:        LICENSE License:             MIT@@ -8,6 +8,16 @@ Build-Type:          Simple Cabal-Version:       >= 1.10 Category:            System+Stability:           Stable+tested-with:+  GHC ==8.10.7+   || ==9.0.2+   || ==9.2.8+   || ==9.4.8+   || ==9.6.7+   || ==9.8.4+   || ==9.10.2+   || ==9.12.1  Homepage:            https://github.com/erikd/conduit-find Bug-Reports:         https://github.com/erikd/conduit-find/issues@@ -27,28 +37,32 @@ Library     default-language:   Haskell2010     ghc-options: -Wall -O2 -funbox-strict-fields+    hs-source-dirs: src     if os(linux) && flag(leafopt)         cpp-options: -DLEAFOPT=1     build-depends:         base                 >= 3 && < 5-      , conduit+      , conduit              >= 1.2       , conduit-extra       , conduit-combinators       , attoparsec       , unix-compat          >= 0.4.1.1-      , text                 >= 0.11.3.1+      , text                 >= 2.0 && < 2.2       , regex-posix       , mtl       , semigroups       , exceptions           >= 0.6       , time+      , resourcet            >= 1.1 && < 1.4       , streaming-commons       , transformers       , transformers-base+      , transformers-either  >= 0.1 && < 0.2       , mmorph       , either       , monad-control        >= 1.0       , filepath+      , unliftio-core     exposed-modules:         Data.Cond, Data.Conduit.Find @@ -64,8 +78,8 @@       , conduit       , conduit-combinators       , attoparsec-      , unix-compat          >= 0.4.1.1-      , text                 >= 0.11.3.1+      , unix-compat+      , text                 >= 2.0 && < 2.2       , regex-posix       , mtl       , time@@ -79,18 +93,20 @@       , mmorph       , filepath       , hspec                >= 1.4+      , resourcet+      , unliftio-core -Test-suite doctests-    Default-language: Haskell2010-    Type:    exitcode-stdio-1.0-    Main-is: doctest.hs-    Hs-source-dirs: test-    Build-depends:-        base-      , directory    >= 1.0-      , doctest      >= 0.8-      , filepath     >= 1.3-      , semigroups   >= 0.4+-- Test-suite doctests+--     Default-language: Haskell2010+--     Type:    exitcode-stdio-1.0+--     Main-is: doctest.hs+--     Hs-source-dirs: test+--     Build-depends:+--         base+--       , directory    >= 1.0+--       , doctest      >= 0.8+--       , filepath     >= 1.3+--       , semigroups   >= 0.4  Executable find-hs     Main-is:     find-hs.hs@@ -104,8 +120,8 @@       , conduit-extra       , conduit-combinators       , attoparsec-      , unix                 >= 0.4.1.1-      , text                 >= 0.11.3.1+      , unix+      , text                 >= 2.0 && < 2.2       , regex-posix       , mtl       , time@@ -118,3 +134,5 @@       , monad-control       , mmorph       , filepath+      , resourcet+      , unliftio-core

@@ -0,0 +1,560 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Cond+    ( CondT(..), Cond++    -- * Executing CondT+    , runCondT, runCond, applyCondT, applyCond++    -- * Promotions+    , guardM, guard_, guardM_, apply, consider++    -- * Boolean logic+    , matches, if_, when_, unless_, or_, and_, not_++    -- * Basic conditionals+    , ignore, norecurse, prune++    -- * Helper functions+    , recurse, test++    -- * Isomorphism with a stateful EitherT+    , CondEitherT(..), fromCondT, toCondT+    ) where++import Control.Applicative (Alternative (..), liftA2, optional)+import Control.Arrow (first)+import GHC.Stack (HasCallStack)+import Control.Monad hiding (mapM_, sequence_)+import Control.Monad.Base (MonadBase (..))+import Control.Monad.Catch (MonadCatch (..), MonadMask (..), MonadThrow (..), ExitCase (..))+import Control.Monad.Morph (MFunctor, hoist)+import Control.Monad.Reader.Class (MonadReader (..), asks)+import Control.Monad.State.Class (MonadState (..), gets)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans (MonadTrans (..))+import Control.Monad.Trans.Control (MonadBaseControl (..))+import Control.Monad.Trans.Either (EitherT, left, runEitherT)+import Control.Monad.Trans.State (StateT (..), withStateT, evalStateT)+import Data.Foldable (asum)+import Data.Functor.Identity (Identity (..))+import Data.Maybe (fromMaybe, isJust)+++-- | '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 performed.+data Result a m b = Ignore+                  | Keep b+                  | RecurseOnly (Maybe (CondT a m b))+                  | KeepAndRecurse b (Maybe (CondT a m b))++instance Show b => Show (Result a m b) where+    show Ignore               = "Ignore"+    show (Keep a)             = "Keep " ++ show a+    show (RecurseOnly _)      = "RecurseOnly"+    show (KeepAndRecurse a _) = "KeepAndRecurse " ++ show a++instance Monad m => Functor (Result a m) where+    fmap _ Ignore               = Ignore+    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+    RecurseOnly _ <> Keep _             = Ignore+    RecurseOnly _ <> KeepAndRecurse _ m = RecurseOnly m+    RecurseOnly m <> _                  = RecurseOnly m+    Keep _        <> RecurseOnly _      = Ignore+    _             <> RecurseOnly m      = RecurseOnly m+    _             <> Keep b             = Keep b+    Keep _        <> KeepAndRecurse b _ = Keep b+    _             <> KeepAndRecurse b m = KeepAndRecurse b m+    {-# INLINE (<>) #-}++instance Monoid b => Monoid (Result a m b) where+    mempty  = KeepAndRecurse mempty Nothing+    {-# INLINE mempty #-}+    mappend = (<>)+    {-# INLINE mappend #-}++getResult :: Result a m b -> (Maybe b, Maybe (CondT a m b))+getResult Ignore               = (Nothing, Nothing)+getResult (Keep b)             = (Just b, Nothing)+getResult (RecurseOnly c)      = (Nothing, c)+getResult (KeepAndRecurse b c) = (Just b, c)++setRecursion :: CondT a m b -> Result a m b -> Result a m b+setRecursion _ Ignore               = Ignore+setRecursion _ (Keep b)             = Keep b+setRecursion c (RecurseOnly _)      = RecurseOnly (Just c)+setRecursion c (KeepAndRecurse b _) = KeepAndRecurse b (Just c)++accept' :: b -> Result a m b+accept' = flip KeepAndRecurse Nothing++recurse' :: Result a m b+recurse' = RecurseOnly Nothing++-- | Convert from a 'Maybe' value to its corresponding 'Result'.+--+-- >>> maybeToResult Nothing :: Result () Identity ()+-- RecurseOnly+-- >>> maybeToResult (Just ()) :: Result () Identity ()+-- KeepAndRecurse ()+maybeToResult :: Maybe a -> Result r m a+maybeToResult Nothing  = recurse'+maybeToResult (Just a) = accept' a++maybeFromResult :: Result r m a -> Maybe a+maybeFromResult Ignore               = Nothing+maybeFromResult (Keep a)             = Just a+maybeFromResult (RecurseOnly _)      = Nothing+maybeFromResult (KeepAndRecurse a _) = Just a++-- | 'CondT' is a kind of @StateT a (MaybeT m) b@, which uses a special+--   'Result' type instead of 'Maybe' to express whether recursion should be+--   performed from the item under consideration.  This is used to build+--   predicates that can guide recursive traversals.+--+-- Several different types may be promoted to 'CondT':+--+--   [@Bool@]                  Using 'guard'+--+--   [@m Bool@]                Using 'guardM'+--+--   [@a -> Bool@]              Using 'guard_'+--+--   [@a -> m Bool@]            Using 'guardM_'+--+--   [@a -> m (Maybe b)@]       Using 'apply'+--+--   [@a -> m (Maybe (b, a))@]  Using 'consider'+--+-- Here is a trivial example:+--+-- @+-- flip runCondT 42 $ do+--   guard_ even+--   liftIO $ putStrLn "42 must be even to reach here"+--   guard_ odd \<|\> guard_ even+--   guard_ (== 42)+-- @+--+-- If 'CondT' is executed using 'runCondT', it return a @Maybe b@ if the+-- predicate matched.  It can also be run with 'applyCondT', which does case+-- analysis on the 'Result', specifying how recursion should be performed from+-- the given 'a' value.+newtype CondT a m b = CondT { getCondT :: StateT a m (Result a m b) }++type Cond a = CondT a Identity++instance Show (CondT a m b) where+    show _ = "CondT"++instance (Monad m, Semigroup b) => Semigroup (CondT a m b) where+    (<>) = liftM2 (<>)+    {-# INLINE (<>) #-}++instance (Monad m, Monoid b) => Monoid (CondT a m b) where+    mempty  = CondT $ return $ accept' mempty+    {-# INLINE mempty #-}++instance Monad m => Functor (CondT a m) where+    fmap f (CondT g) = CondT (fmap (fmap f) g)+    {-# INLINE fmap #-}++instance Monad m => Applicative (CondT a m) where+    pure  = CondT . pure . accept' -- pure+    {-# INLINE pure #-}+    (<*>) = ap+    {-# INLINE (<*>) #-}++instance Monad m => Monad (CondT a m) where+    -- return = CondT . pure . accept'+    -- {-# INLINE return #-}+    CondT f >>= k = CondT $ do+        r <- f+        case r of+            Ignore -> return Ignore+            Keep b -> do+                n <- getCondT (k b)+                return $ case n of+                    RecurseOnly _      -> Ignore+                    KeepAndRecurse c _ -> Keep c+                    _                  -> n+            RecurseOnly l -> return $ RecurseOnly (fmap (>>= k) l)+            KeepAndRecurse b _ -> getCondT (k b)++instance MonadFail m => MonadFail (CondT a m) where+    fail _ = mzero+    {-# INLINE fail #-}++instance Monad m => MonadReader a (CondT a m) where+    ask               = CondT $ gets accept'+    {-# INLINE ask #-}+    local f (CondT m) = CondT $ withStateT f m+    {-# INLINE local #-}+    reader f          = liftM f ask+    {-# INLINE reader #-}++instance Monad m => MonadState a (CondT a m) where+    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 => 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+    {-# INLINE throwM #-}++instance MonadCatch m => MonadCatch (CondT a m) where+    catch (CondT m) c = CondT $ m `catch` \e -> getCondT (c e)++instance MonadMask m => MonadMask (CondT aa m) where+    mask a = CondT $ mask $ \u -> getCondT (a $ q u)+      where q u = CondT . u . getCondT++    uninterruptibleMask a =+        CondT $ uninterruptibleMask $ \u -> getCondT (a $ q u)+      where q u = CondT . u . getCondT+    generalBracket :: forall a b c. HasCallStack =>+      CondT aa m a ->+      (a -> ExitCase b -> CondT aa m c) ->+      (a -> CondT aa m b) ->+      CondT aa m (b, c)+    generalBracket acquire release use = CondT go+      where+        arg1 :: StateT aa m (Result aa m a)+        arg1 = getCondT acquire+        arg2 :: (Result aa m a) -> ExitCase (Result aa m b) -> StateT aa m (Result aa m c)+        arg2 a b = case a of+          Ignore -> pure Ignore+          Keep a' ->+            case b of+              ExitCaseSuccess b' ->+                case b' of+                  Ignore -> getCondT $ release a' ExitCaseAbort+                  Keep b'' -> getCondT $ release a' (ExitCaseSuccess b'')+                  RecurseOnly _mb -> getCondT $ release a' ExitCaseAbort -- set mb?+                  KeepAndRecurse b'' _mb -> getCondT $ release a' (ExitCaseSuccess b'') -- set mb?+              ExitCaseException se -> getCondT $ release a' (ExitCaseException se)+              ExitCaseAbort -> getCondT $ release a' ExitCaseAbort+          RecurseOnly _ma ->+            pure Ignore+          KeepAndRecurse a' _ma ->+            case b of+              ExitCaseSuccess b' ->+                case b' of+                  Ignore -> getCondT $ release a' ExitCaseAbort+                  Keep b'' -> getCondT $ release a' (ExitCaseSuccess b'')+                  RecurseOnly _mb -> getCondT $ release a' ExitCaseAbort -- set mb?+                  KeepAndRecurse b'' _mb -> getCondT $ release a' (ExitCaseSuccess b'') -- set mb?+              ExitCaseException se -> getCondT $ release a' (ExitCaseException se)+              ExitCaseAbort -> getCondT $ release a' ExitCaseAbort++        arg3 :: (Result aa m a) -> StateT aa m (Result aa m b)+        arg3 a = getCondT (CondT (pure a) >>= use)++        go = do+          generalBracket arg1 arg2 arg3 >>= \case+            -- anyway looks like a total nonsense - i give up+            (Keep b, Keep c) -> pure $ Keep (b, c)+            (RecurseOnly mb, RecurseOnly mc) -> pure $ RecurseOnly (liftA2 (,) <$> mb <*> mc)+            (KeepAndRecurse b mb, KeepAndRecurse c mc) ->+              pure $ KeepAndRecurse (b, c) (liftA2 (,) <$> mb <*> mc)+            (Keep b, KeepAndRecurse c _) -> pure $ Keep (b, c)+            (KeepAndRecurse b _, Keep c) -> pure $ Keep (b, c)+            (KeepAndRecurse _ mb, RecurseOnly mc) -> pure $ RecurseOnly (liftA2 (,) <$> mb <*> mc)+            (RecurseOnly mb, KeepAndRecurse _ mc) -> pure $ RecurseOnly (liftA2 (,) <$> mb <*> mc)+            _ -> pure Ignore++instance MonadBase b m => MonadBase b (CondT a m) where+    liftBase m = CondT $ liftM accept' $ liftBase m+    {-# INLINE liftBase #-}++instance MonadIO m => MonadIO (CondT a m) where+    liftIO m = CondT $ liftM accept' $ liftIO m+    {-# INLINE liftIO #-}++instance MonadTrans (CondT a) where+    lift m = CondT $ liftM accept' $ lift m+    {-# INLINE lift #-}++instance MonadBaseControl b m => MonadBaseControl b (CondT r m) where+    type StM (CondT r m) a = StM m (Result r m a, r)+    liftBaseWith f = CondT $ StateT $ \s ->+        liftM (\x -> (accept' x, s)) $ liftBaseWith $ \runInBase -> f $ \k ->+            runInBase $ runStateT (getCondT k) s+    restoreM = CondT . StateT . const . restoreM+    {-# 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 = maybeFromResult `liftM` evalStateT f a+{-# INLINE runCondT #-}++runCond :: Cond a b -> a -> Maybe b+runCond = (runIdentity .) . runCondT+{-# INLINE runCond #-}++-- | Case analysis of applying a condition to an input value.  The result is a+--   pair whose first part is a pair of Maybes specifying if the input matched+--   and if recursion is expected from this value, and whose second part is+--   the (possibly) mutated input value.+applyCondT :: Monad m+           => a+           -> CondT a m b+           -> m ((Maybe b, Maybe (CondT a m b)), a)+applyCondT a cond = do+    -- Apply a condition to the input value, determining the result and the+    -- mutated value.+    (r, a') <- runStateT (getCondT cond) a++    -- Convert from the 'Result' to a pair of Maybes: one to specify if the+    -- predicate succeeded, and the other to specify if recursion should be+    -- performed.  If there is no sub-recursion specified, return 'cond'.+    return (fmap (Just . fromMaybe cond) (getResult r), a')+{-# INLINE applyCondT #-}++-- | Case analysis of applying a pure condition to an input value.  The result+--   is a pair whose first part is a pair of Maybes specifying if the input+--   matched and if recursion is expected from this value, and whose second+--   part is the (possibly) mutated input value.+applyCond :: a -> Cond a b -> ((Maybe b, Maybe (Cond a b)), a)+applyCond a cond = first (fmap (Just . fromMaybe cond) . getResult)+                       (runIdentity (runStateT (getCondT cond) a))+{-# INLINE applyCond #-}++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 = asks f >>= guard+{-# 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 $ get >>= liftM maybeToResult . lift . f+{-# INLINE apply #-}++consider :: Monad m => (a -> m (Maybe (b, a))) -> CondT a m b+consider f = CondT $ do+    mres <- lift . f =<< get+    case mres of+        Nothing      -> return Ignore+        Just (b, a') -> put a' >> return (accept' b)+{-# INLINE consider #-}++-- | Return True or False depending on whether the given condition matches or+--   not.  This differs from simply stating the condition in that it itself+--   always succeeds.+--+-- >>> flip runCond "foo.hs" $ matches (guard =<< asks (== "foo.hs"))+-- Just True+-- >>> flip runCond "foo.hs" $ matches (guard =<< asks (== "foo.hi"))+-- Just False+matches :: Monad m => CondT a m b -> CondT a m Bool+matches = fmap isJust . optional+{-# INLINE matches #-}++-- | A variant of ifM which branches on whether the condition succeeds or not.+--   Note that @if_ x@ is equivalent to @ifM (matches x)@, and is provided+--   solely for convenience.+--+-- >>> let good = guard_ (== "foo.hs") :: Cond String ()+-- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()+-- >>> flip runCond "foo.hs" $ if_ good (return "Success") (return "Failure")+-- Just "Success"+-- >>> flip runCond "foo.hs" $ if_ bad (return "Success") (return "Failure")+-- Just "Failure"+if_ :: Monad m => CondT a m r -> CondT a m b -> CondT a m b -> CondT a m b+if_ c x y =+    CondT $ getCondT . maybe y (const x) . maybeFromResult =<< getCondT c+{-# INLINE if_ #-}++-- | 'when_' is just like 'when', except that it executes the body if the+--   condition passes, rather than based on a Bool value.+--+-- >>> let good = guard_ (== "foo.hs") :: Cond String ()+-- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()+-- >>> flip runCond "foo.hs" $ when_ good ignore+-- Nothing+-- >>> flip runCond "foo.hs" $ when_ bad ignore+-- Just ()+when_ :: Monad m => CondT a m r -> CondT a m () -> CondT a m ()+when_ c x = if_ c (void x) (return ())+{-# INLINE when_ #-}++-- | 'when_' is just like 'when', except that it executes the body if the+--   condition fails, rather than based on a Bool value.+--+-- >>> let good = guard_ (== "foo.hs") :: Cond String ()+-- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()+-- >>> flip runCond "foo.hs" $ unless_ bad ignore+-- Nothing+-- >>> flip runCond "foo.hs" $ unless_ good ignore+-- Just ()+unless_ :: Monad m => CondT a m r -> CondT a m () -> CondT a m ()+unless_ c = if_ c (return ()) . void+{-# INLINE unless_ #-}++-- | Check whether at least one of the given conditions is true.  This is a+--   synonym for 'Data.Foldable.asum'.+--+-- >>> let good = guard_ (== "foo.hs") :: Cond String ()+-- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()+-- >>> flip runCond "foo.hs" $ or_ [bad, good]+-- Just ()+-- >>> flip runCond "foo.hs" $ or_ [bad]+-- Nothing+or_ :: Monad m => [CondT a m b] -> CondT a m b+or_ = asum+{-# INLINE or_ #-}++-- | Check that all of the given conditions are true.  This is a synonym for+--   'Data.Foldable.sequence_'.+--+-- >>> let good = guard_ (== "foo.hs") :: Cond String ()+-- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()+-- >>> flip runCond "foo.hs" $ and_ [bad, good]+-- Nothing+-- >>> flip runCond "foo.hs" $ and_ [good]+-- Just ()+and_ :: Monad m => [CondT a m b] -> CondT a m ()+and_ = sequence_+{-# INLINE and_ #-}++-- | 'not_' inverts the meaning of the given predicate.+--+-- >>> let good = guard_ (== "foo.hs") :: Cond String ()+-- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()+-- >>> flip runCond "foo.hs" $ not_ bad >> return "Success"+-- Just "Success"+-- >>> flip runCond "foo.hs" $ not_ good >> return "Shouldn't reach here"+-- Nothing+not_ :: Monad m => CondT a m b -> CondT a m ()+not_ c = when_ c ignore+{-# INLINE not_ #-}++-- | '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 #-}++-- | '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 #-}++-- | '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 b+prune = CondT $ return Ignore+{-# INLINE prune #-}++-- | '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 looks only for a file named @config@:+--+-- @+-- if_ (name_ \".git\" \>\> directory)+--     (ignore \>\> recurse (name_ \"config\"))+--     (glob \"*.hs\")+-- @+--+-- NOTE: 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 $ setRecursion c `liftM` getCondT c+{-# INLINE recurse #-}++-- | A specialized variant of 'runCondT' that simply returns True or False.+--+-- >>> let good = guard_ (== "foo.hs") :: Cond String ()+-- >>> let bad  = guard_ (== "foo.hi") :: Cond String ()+-- >>> runIdentity $ test "foo.hs" $ not_ bad >> return "Success"+-- True+-- >>> runIdentity $ test "foo.hs" $ not_ good >> return "Shouldn't reach here"+-- False+test :: Monad m => a -> CondT a m b -> m Bool+test = (liftM isJust .) . flip runCondT+{-# INLINE test #-}++-- | This type is for documentation only, and shows the isomorphism between+--   'CondT' and 'CondEitherT'.  The reason for using 'Result' is that it+--   makes meaning of the constructors more explicit.+newtype CondEitherT a m b = CondEitherT+    (StateT a (EitherT (Maybe (Maybe (CondEitherT a m b))) m)+         (b, Maybe (Maybe (CondEitherT a m b))))++-- | Witness one half of the isomorphism from 'CondT' to 'CondEitherT'.+fromCondT :: Monad m => CondT a m b -> CondEitherT a m b+fromCondT (CondT f) = CondEitherT $ do+    s <- get+    (r, s') <- lift $ lift $ runStateT f s+    case r of+        Ignore             -> lift $ left Nothing+        Keep a             -> put s' >> return (a, Nothing)+        RecurseOnly m      -> lift $ left (Just (fmap fromCondT m))+        KeepAndRecurse a m -> put s' >> return (a, Just (fmap fromCondT m))++-- | Witness the other half of the isomorphism from 'CondEitherT' to 'CondT'.+toCondT :: Monad m => CondEitherT a m b -> CondT a m b+toCondT (CondEitherT f) = CondT $ do+    s <- get+    eres <- lift $ runEitherT $ runStateT f s+    case eres of+        Left Nothing             -> return Ignore+        Right ((a, Nothing), s') -> put s' >> return (Keep a)+        Left (Just m)            -> return $ RecurseOnly (fmap toCondT m)+        Right ((a, Just m), s')  ->+            put s' >> return (KeepAndRecurse a (fmap toCondT m))

@@ -0,0 +1,618 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Data.Conduit.Find+    (+    -- * Introduction+    -- $intro++    -- ** Basic comparison with GNU find+    -- $gnufind++    -- ** Performance+    -- $performance++    -- ** Other notes+    -- $notes++    -- * Finding functions+      sourceFindFiles+    , find+    , findFiles+    , findFilePaths+    , FindOptions(..)+    , defaultFindOptions+    , test+    , ltest+    , stat+    , lstat+    , hasStatus++      -- * File path predicates+    , glob+    , regex+    , ignoreVcs++      -- * GNU find compatibility predicates+    , depth_+    , follow_+    , noleaf_+    , prune_+    , maxdepth_+    , mindepth_+    , ignoreErrors_+    , noIgnoreErrors_+    , amin_+    , atime_+    , anewer_+    , empty_+    , executable_+    , gid_+    , name_+    , getDepth+    , filename_+    , pathname_+    , getFilePath++    -- * File entry predicates (uses stat information)+    , regular+    , directory+    , hasMode+    , executable+    , lastAccessed_+    , lastModified_++    -- * Predicate combinators+    , module Cond+    , (=~)++    -- * Types and type classes+    , FileEntry(..)+    ) where++import           Control.Applicative (Alternative (..))+import           Control.Exception (IOException, catch, throwIO)+import           Control.Monad hiding (forM_, forM)+import           Control.Monad.Catch (MonadThrow)+import           Control.Monad.IO.Class (MonadIO, liftIO)+import           Control.Monad.IO.Unlift (MonadUnliftIO)+import           Control.Monad.Morph (hoist, lift)+import           Control.Monad.State.Class (get, gets, modify, put)+import           Control.Monad.Trans.Control (MonadBaseControl)+import           Control.Monad.Trans.Resource (MonadResource)++import           Data.Attoparsec.Text as A+import           Data.Bits ((.&.))+import           Data.Conduit (ConduitT, runConduitRes, (.|))+import qualified Data.Conduit as DC+import qualified Data.Conduit.List as DCL+import qualified Data.Cond as Cond+import           Data.Cond hiding (test)+import qualified Data.Conduit.Filesystem as CF+#if LEAFOPT+import           Data.IORef (IORef, newIORef, modifyIORef, readIORef)+#endif+import           Data.Maybe (fromMaybe, fromJust)+import           Data.Text (Text, unpack, pack)+import           Data.Time (UTCTime,  diffUTCTime)+import           Data.Time.Clock.POSIX (getCurrentTime, posixSecondsToUTCTime)+import qualified System.FilePath as FP+import           System.PosixCompat.Files (FileStatus, linkCount)+import qualified System.PosixCompat.Files as Files+import           System.PosixCompat.Types (EpochTime, FileMode)+import           Text.Regex.Posix ((=~))++{- $intro++**find-conduit** is essentially a souped version of GNU find for Haskell,+using a DSL to provide both ease of us, and extensive flexbility.++In its simplest form, let's compare some uses of find to find-conduit.  Bear+in mind that the result of the find function is a conduit, so you're expected+to either sink it to a list, or operate on the file paths as they are yielded.+-}++{- $gnufind++A typical find command:++@+find src -name '*.hs' -type f -print+@++Would in find-conduit be:++@+find "src" (glob \"*.hs\" \<\> regular) $$ mapM_C (liftIO . print)+@++The 'glob' predicate matches the file basename against the globbing pattern,+while the 'regular' predicate matches plain files.++A more complicated example:++@+find . -size +100M -perm 644 -mtime 1+@++Now in find-conduit:++@+let megs = 1024 * 1024+    days = 86400+now <- liftIO getCurrentTime+find \".\" ( fileSize (> 100*megs)+        \<\> hasMode 0o644+        \<\> lastModified (> addUTCTime now (-(1*days)))+         )+@++Appending predicates like this expressing an "and" relationship.  Use '<|>' to+express "or".  You can also negate any predicate:++@+find \".\" (not_ (hasMode 0o644))+@++By default, predicates, whether matching or not, will allow recursion into+directories.  In order to express that matching predicate should disallow+recursion, use 'prune':++@+find \".\" (prune (depth (> 2)))+@++This is the same as using '-maxdepth 2' in find.++@+find \".\" (prune (filename_ (== \"dist\")))+@++This is the same as:++@+find . \\( -name dist -prune \\) -o -print+@+-}++{- $performance++find-conduit strives to make file-finding a well performing operation.  To+this end, a composed Predicate will only call stat once per entry being+considered; and if you prune a directory, it is not traversed at all.++By default, 'find' calls stat for every file before it applies the predicate,+in order to ensure that only one such call is needed.  Sometimes, however, you+know just from the FilePath that you don't want to consider a certain file, or+you want to prune a directory tree.++To support these types of optimized queries, a variant of find is provided+called 'findWithPreFilter'.  This takes two predicates: one that is applied to+only the FilePath, before stat (or lstat) is called; and one that is applied+to the full file information after the stat.+-}++{- $notes++See 'Data.Cond' for more details on the Monad used to build predicates.+-}++data FindOptions = FindOptions+    { findFollowSymlinks   :: !Bool+    , findContentsFirst    :: !Bool+    , findIgnoreErrors     :: !Bool+    , findIgnoreResults    :: !Bool+    , findLeafOptimization :: !Bool+    }++defaultFindOptions :: FindOptions+defaultFindOptions = FindOptions+    { findFollowSymlinks   = True+    , findContentsFirst    = False+    , findIgnoreErrors     = False+    , findIgnoreResults    = False+    , findLeafOptimization = True+    }++data FileEntry = FileEntry+    { entryPath        :: !FP.FilePath+    , entryDepth       :: !Int+    , entryFindOptions :: !FindOptions+    , entryStatus      :: !(Maybe FileStatus)+      -- ^ This is Nothing until we determine stat should be called.+    }++newFileEntry :: FP.FilePath -> Int -> FindOptions -> FileEntry+newFileEntry fp d f = FileEntry fp d f Nothing++instance Show FileEntry where+    show entry = "FileEntry "+              ++ show (entryPath entry)+              ++ " " ++ show (entryDepth entry)++getFilePath :: Monad m => CondT FileEntry m FP.FilePath+getFilePath = gets entryPath++pathname_ :: Monad m => (FP.FilePath -> Bool) -> CondT FileEntry m ()+pathname_ f = guard . f =<< getFilePath++filename_ :: Monad m => (FP.FilePath -> Bool) -> CondT FileEntry m ()+filename_ f = pathname_ (f . FP.takeFileName)++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 }++noleaf_ :: Monad m => CondT FileEntry m ()+noleaf_ = modifyFindOptions $ \opts -> opts { findLeafOptimization = False }++prune_ :: Monad m => CondT a m ()+prune_ = prune++ignoreErrors_ :: Monad m => CondT FileEntry m ()+ignoreErrors_ =+    modifyFindOptions $ \opts -> opts { findIgnoreErrors = True }++noIgnoreErrors_ :: Monad m => CondT FileEntry m ()+noIgnoreErrors_ =+    modifyFindOptions $ \opts -> opts { findIgnoreErrors = 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)++-- 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 => FP.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+    f = posixSecondsToUTCTime . realToFrac . Files.accessTime++-- cmin_ = error "NYI"+-- cnewer_ = error "NYI"+-- ctime_ = error "NYI"++empty_ :: MonadIO m => CondT FileEntry m ()+empty_ = (regular   >> hasStatus ((== 0) . Files.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 . Files.fileGroup)++{-+group_ name+ilname_ pat+iname_ pat+inum_ n+ipath_ pat+iregex_ pat+iwholename_ pat+links_ n+lname_ pat+mmin_+mtime_+-}++name_ :: Monad m => FP.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+-}++------------------------------------------------------------------------++statFilePath :: Bool -> Bool -> FP.FilePath -> IO (Maybe FileStatus)+statFilePath follow ignoreErrors path = do+    let doStat = (if follow+                  then Files.getFileStatus+                  else Files.getSymbolicLinkStatus) path+    catch (Just <$> doStat) $ \e ->+        if ignoreErrors+        then return Nothing+        else throwIO (e :: IOException)++-- | 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+        return $ case ms of+            Just s  -> Just (s, entry { entryStatus = Just s })+            Nothing -> Nothing+  where+    follow   = findFollowSymlinks . entryFindOptions+    wrapStat = liftIO $ statFilePath+        (fromMaybe (findFollowSymlinks opts) mfollow)+        (findIgnoreErrors opts)+        (entryPath entry)+      where+        opts = entryFindOptions entry++applyStat :: MonadIO m => Maybe Bool -> CondT FileEntry m FileStatus+applyStat mfollow = do+    ms <- lift . getStat mfollow =<< get+    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 Files.isRegularFile++executable :: MonadIO m => CondT FileEntry m ()+executable = hasMode Files.ownerExecuteMode++directory :: MonadIO m => CondT FileEntry m ()+directory = hasStatus Files.isDirectory++hasMode :: MonadIO m => FileMode -> CondT FileEntry m ()+hasMode m = hasStatus (\s -> Files.fileMode s .&. m /= 0)++withStatusTime :: MonadIO m+               => (FileStatus -> EpochTime) -> (UTCTime -> Bool)+               -> CondT FileEntry m ()+withStatusTime g f = hasStatus (f . posixSecondsToUTCTime . realToFrac . g)++lastAccessed_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m ()+lastAccessed_ = withStatusTime Files.accessTime++lastModified_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m ()+lastModified_ = withStatusTime Files.modificationTime++regex :: Monad m => String -> 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 => String -> CondT FileEntry m ()+glob g = case parseOnly globParser (pack g) of+    Left e  -> error $ "Failed to parse glob: " ++ e+    Right x -> regex ("^" <> unpack x <> "$")+  where+    globParser :: Parser Text+    globParser = fmap mconcat $ many $+            char '*' *> return ".*"+        <|> char '?' *> return "."+        <|> string "[]]" *> return "[]]"+        <|> (\x y z -> pack ((x:y) ++ [z]))+                <$> char '['+                <*> manyTill anyChar (A.try (char ']'))+                <*> char ']'+        <|> do+            x <- anyChar+            return . pack $ if x `elem` (".()^$" :: String)+                            then ['\\', x]+                            else [x]++#if LEAFOPT+type DirCounter = IORef Word++newDirCounter :: MonadIO m => m DirCounter+newDirCounter = liftIO $ newIORef 1+#else+type DirCounter = ()++newDirCounter :: MonadIO m => m DirCounter+newDirCounter = return ()+#endif++-- | 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.+sourceFindFiles :: MonadResource m+                => FindOptions+                -> FilePath+                -> CondT FileEntry m a+                -> ConduitT i (FileEntry, a) m ()+sourceFindFiles findOptions startPath predicate = do+    startDc <- newDirCounter+    walk startDc+        (newFileEntry startPath 0 findOptions)+        startPath+        predicate+  where+    walk :: MonadResource m+         => DirCounter+         -> FileEntry+         -> FP.FilePath+         -> CondT FileEntry m a+         -> ConduitT i (FileEntry, a) m ()+    walk !dc !entry !path !cond = do+        ((!mres, !mcond), !entry') <- lift $ applyCondT entry cond+        let opts' = entryFindOptions entry+            this  = unless (findIgnoreResults opts') $+                        yieldEntry entry' mres+            next  = walkChildren dc entry' path mcond+        if findContentsFirst opts'+            then next >> this+            else this >> next+      where+        yieldEntry _      Nothing    = return ()+        yieldEntry entry' (Just res) = DC.yield (entry', res)++    walkChildren :: MonadResource m+                 => DirCounter+                 -> FileEntry+                 -> FP.FilePath+                 -> Maybe (CondT FileEntry m a)+                 -> ConduitT i (FileEntry, a) m ()+    walkChildren _ _ _ Nothing = return ()+    -- If the conditional matched, we are requested to recurse if this is a+    -- directory+    walkChildren !dc !entry !path (Just !cond) = do+        st <- lift $ checkIfDirectory dc entry path+        when (fmap Files.isDirectory st == Just True) $ do+#if LEAFOPT+            -- Update directory count for the parent directory.+            liftIO $ modifyIORef dc pred+            -- Track the directory count for this child path.+            let leafOpt = findLeafOptimization (entryFindOptions entry)+            let lc = linkCount (fromJust st) - 2+                opts' = (entryFindOptions entry)+                    { findLeafOptimization = leafOpt && lc >= 0+                    }+            dc' <- liftIO $ newIORef (fromIntegral lc :: Word)+#else+            let dc'   = dc+                opts' = entryFindOptions entry+#endif+            CF.sourceDirectory path .| DC.awaitForever (go dc' opts')+      where+        go dc' opts' fp =+            let entry' = newFileEntry fp (succ (entryDepth entry)) opts'+            in walk dc' entry' fp cond++    -- Return True if the given entry is a directory.  We can sometimes use+    -- "leaf optimization" on Linux to answer this question without performing+    -- a stat call.  This is possible because the link count of a directory is+    -- two more than the number of sub-directories it contains, so we've seen+    -- that many sub-directories, the remaining entries must be files.+    checkIfDirectory :: MonadResource m+                     => DirCounter+                     -> FileEntry+                     -> FP.FilePath+                     -> m (Maybe FileStatus)+    checkIfDirectory !dc !entry !path = do+#if LEAFOPT+        let leafOpt = findLeafOptimization (entryFindOptions entry)+        doStat <- if leafOpt+                  then (> 0) <$> liftIO (readIORef dc)+                  else return True+#else+        let doStat = dc == () -- to quiet hlint warnings+#endif+        let opts = entryFindOptions entry+        if doStat+            then liftIO $ statFilePath+                (findFollowSymlinks opts)+                (findIgnoreErrors opts)+                path+            else return Nothing++findFiles :: (MonadIO m, MonadBaseControl IO m, MonadThrow m, MonadUnliftIO m)+          => FindOptions+          -> FilePath+          -> CondT FileEntry m a+          -> m ()+findFiles opts path predicate =+    runConduitRes $+        sourceFindFiles opts { findIgnoreResults = True } path+            (hoist lift predicate) .| DCL.sinkNull++-- | 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+              -> ConduitT i FilePath m ()+findFilePaths opts path predicate =+    sourceFindFiles opts path predicate .| DCL.map (entryPath . fst)++-- | Calls 'findFilePaths' with the default set of finding options.+--   Equivalent to @findFilePaths defaultFindOptions@.+find :: MonadResource m+     => FilePath -> CondT FileEntry m a -> DC.ConduitT i FilePath m ()+find = findFilePaths defaultFindOptions++-- | 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 (newFileEntry path 0 defaultFindOptions) matcher++-- | 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+        (newFileEntry path 0 defaultFindOptions+            { findFollowSymlinks = False })+        matcher

@@ -1,29 +0,0 @@-module Main where--import Test.DocTest-import System.Directory-import System.FilePath-import Control.Applicative-import Control.Monad-import Data.List--main :: IO ()-main = getSources >>= \sources -> doctest $-    "-iData"-  : "-idist/build/autogen"-  : "-optP-include"-  : "-optPdist/build/autogen/cabal_macros.h"-  : sources--getSources :: IO [FilePath]-getSources =-    filter (\n -> ".hs" `isSuffixOf` n) <$> go "./Data"-  where-    go dir = do-      (dirs, files) <- getFilesAndDirectories dir-      (files ++) . concat <$> mapM go dirs--getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])-getFilesAndDirectories dir = do-  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir-  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c

@@ -1,41 +1,59 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+ module Main where -import Conduit-import Control.Monad-import Control.Monad.Reader.Class+import Data.Conduit ((.|), runConduitRes)+import Control.Monad (guard, void)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader.Class (asks) import Data.Conduit.Find-import Data.List-import System.Environment-import System.Posix.Process+import Data.Conduit.List qualified as DCL+import Data.List (isSuffixOf)+import System.Environment (getArgs)+import System.Posix.Process (executeFile)+import Data.Conduit.Filesystem (sourceDirectoryDeep) + main :: IO () main = do-    [command, dir] <- getArgs+    getArgs >>= \case+      [command, dir] -> runCommand command dir+      [command] -> runCommand command "."+      [] -> runCommand "find" "."+      o -> fail $ "Bad arguments: " <> show o++runCommand command dir =     case command of         "conduit" -> do             putStrLn "Running sourceDirectoryDeep from conduit-extra"-            runResourceT $+            runConduitRes $                 sourceDirectoryDeep False dir-                    =$ filterC (".hs" `isSuffixOf`)-                    $$ mapM_C (liftIO . putStrLn)+                    .| DCL.filter (".hs" `isSuffixOf`)+                    .| DCL.mapM_ (liftIO . putStrLn)+                    .| DCL.sinkNull          "find-conduit" -> do             putStrLn "Running findFiles from find-conduit"             findFiles defaultFindOptions { findFollowSymlinks = False }                 dir $ do                     path <- asks entryPath-                    guard (".hs" `isSuffixOf` path)+                    void $ guard (".hs" `isSuffixOf` path)                     norecurse                     liftIO $ putStrLn path          "find-conduit2" -> do             putStrLn "Running findFiles from find-conduit"-            runResourceT $+            runConduitRes $                 sourceFindFiles defaultFindOptions { findFollowSymlinks = False }                     dir (return ())-                    =$ filterC ((".hs" `isSuffixOf`) . entryPath . fst)-                    $$ mapM_C (liftIO . putStrLn . entryPath . fst)+                    .| DCL.filter ((".hs" `isSuffixOf`) . entryPath . fst)+                    .| DCL.mapM_ (liftIO . putStrLn . entryPath . fst)+                    .| DCL.sinkNull          "find" -> do             putStrLn "Running GNU find"             executeFile "find" True [dir, "-name", "*.hs", "-print"] Nothing++        _ ->+            putStrLn $ "Unknown command " ++ show command

@@ -1,9 +1,11 @@+{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-}  module Main where -import Conduit+import Data.Conduit import Data.Conduit.Find+import Data.Conduit.List qualified as DCL import Test.Hspec  main :: IO ()@@ -22,23 +24,20 @@             res `shouldBe` False          it "finds files" $ do-            xs <- runResourceT $+            xs <- runConduitRes $                 find "."                     (do ignoreVcs-                        when_ (name_ "dist") prune                         glob "*.hs"-                        not_ (glob "Setup*")                         regular                         not_ executable)-                    $$ sinkList+                    .| DCL.consume -            "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True-            "./dist/setup-config" `elem` xs `shouldBe` False-            "./Setup.hs" `elem` xs `shouldBe` False+            "./src/Data/Conduit/Find.hs" `elem` xs `shouldBe` True+            "./dist-newstyle/setup-config" `elem` xs `shouldBe` False             "./.git/config" `elem` xs `shouldBe` False          it "finds files with a different ordering" $ do-            xs <- runResourceT $+            xs <- runConduitRes $                 find "."                     (do ignoreVcs                         glob "*.hs"@@ -46,34 +45,32 @@                         -- This applies only to .hs files now, so it won't                         -- match anything, thus having no effect but burning                         -- CPU!-                        when_ (name_ "dist") prune+                        when_ (name_ "dist-newstyle") prune                         regular                         not_ executable)-                    $$ sinkList+                    .| DCL.consume -            "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True-            "./dist/setup-config" `elem` xs `shouldBe` False-            "./Setup.hs" `elem` xs `shouldBe` False+            "./src/Data/Conduit/Find.hs" `elem` xs `shouldBe` True+            "./dist-newstyle/setup-config" `elem` xs `shouldBe` False             "./.git/config" `elem` xs `shouldBe` False          it "finds files using a pre-pass filter" $ do-            xs <- runResourceT $+            xs <- runConduitRes $                 find "."                     (do ignoreVcs-                        when_ (name_ "dist") prune+                        when_ (name_ "dist-newstyle") prune                         glob "*.hs"                         not_ (glob "Setup*")                         regular                         not_ executable)-                    $$ sinkList+                    .| DCL.consume -            "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True-            "./dist/setup-config" `elem` xs `shouldBe` False-            "./Setup.hs" `elem` xs `shouldBe` False+            "./src/Data/Conduit/Find.hs" `elem` xs `shouldBe` True+            "./dist-newstyle/setup-config" `elem` xs `shouldBe` False             "./.git/config" `elem` xs `shouldBe` False          it "properly applies post-pass pruning" $ do-            xs <- runResourceT $+            xs <- runConduitRes $                 find "."                     (do ignoreVcs                         maxdepth_ 1@@ -82,7 +79,7 @@                         not_ (glob "Setup*")                         regular                         not_ executable)-                    $$ sinkList+                    .| DCL.consume              "./Data/Conduit/Find.hs" `elem` xs `shouldBe` False             "./dist/setup-config" `elem` xs `shouldBe` False