conduit-find (empty) → 0.1.0
raw patch · 8 files changed
+1417/−0 lines, 8 filesdep +attoparsecdep +basedep +conduitsetup-changed
Dependencies added: attoparsec, base, conduit, conduit-combinators, conduit-extra, conduit-find, directory, doctest, either, exceptions, filepath, hspec, mmorph, monad-control, mtl, regex-posix, semigroups, streaming-commons, text, time, transformers, transformers-base, unix, unix-compat
Files
- Data/Cond.hs +506/−0
- Data/Conduit/Find.hs +610/−0
- LICENSE +19/−0
- Setup.hs +2/−0
- conduit-find.cabal +120/−0
- test/doctest.hs +29/−0
- test/find-hs.hs +41/−0
- test/main.hs +90/−0
+ Data/Cond.hs view
@@ -0,0 +1,506 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++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+ 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'+ {-# 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))
+ Data/Conduit/Find.hs view
@@ -0,0 +1,610 @@+{-# 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
+ LICENSE view
@@ -0,0 +1,19 @@+opyright (c) 2014 John Wiegley++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ conduit-find.cabal view
@@ -0,0 +1,120 @@+Name: conduit-find+Version: 0.1.0+Synopsis: A file-finding conduit that allows user control over traversals.+License-file: LICENSE+License: MIT+Author: John Wiegley+Maintainer: Erik de Castro Lopo <erikd@mega-nerd.com>+Build-Type: Simple+Cabal-Version: >= 1.10+Category: System++Homepage: https://github.com/erikd/conduit-find+Bug-Reports: https://github.com/erikd/conduit-find/issues++Description:+ A file-finding conduit that allows user control over traversals. Please see+ the module 'Data.Conduit.Find' for more information.++Source-repository head+ type: git+ location: https://github.com/erikd/conduit-find.git++Flag leafopt+ Description: Enable leaf optimization+ Default: True++Library+ default-language: Haskell2010+ ghc-options: -Wall -O2 -funbox-strict-fields+ if os(linux) && flag(leafopt)+ cpp-options: -DLEAFOPT=1+ build-depends:+ base >= 3 && < 5+ , conduit+ , conduit-extra+ , conduit-combinators+ , attoparsec+ , unix-compat >= 0.4.1.1+ , text >= 0.11.3.1+ , regex-posix+ , mtl+ , semigroups+ , exceptions >= 0.6+ , time+ , streaming-commons+ , transformers+ , transformers-base+ , mmorph+ , either+ , monad-control >= 1.0+ , filepath+ exposed-modules:+ Data.Cond, Data.Conduit.Find++test-suite test+ hs-source-dirs: test+ default-language: Haskell2010+ main-is: main.hs+ type: exitcode-stdio-1.0+ ghc-options: -Wall -threaded+ build-depends:+ base+ , conduit-find+ , conduit+ , conduit-combinators+ , attoparsec+ , unix-compat >= 0.4.1.1+ , text >= 0.11.3.1+ , regex-posix+ , mtl+ , time+ , either+ , semigroups+ , streaming-commons+ , exceptions+ , transformers+ , transformers-base+ , monad-control+ , mmorph+ , filepath+ , hspec >= 1.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+ default-language: Haskell2010+ Ghc-options: -threaded -O2+ Hs-source-dirs: test+ Build-depends:+ base+ , conduit-find+ , conduit+ , conduit-extra+ , conduit-combinators+ , attoparsec+ , unix >= 0.4.1.1+ , text >= 0.11.3.1+ , regex-posix+ , mtl+ , time+ , either+ , semigroups+ , streaming-commons+ , exceptions+ , transformers+ , transformers-base+ , monad-control+ , mmorph+ , filepath
+ test/doctest.hs view
@@ -0,0 +1,29 @@+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
+ test/find-hs.hs view
@@ -0,0 +1,41 @@+module Main where++import Conduit+import Control.Monad+import Control.Monad.Reader.Class+import Data.Conduit.Find+import Data.List+import System.Environment+import System.Posix.Process++main :: IO ()+main = do+ [command, dir] <- getArgs+ case command of+ "conduit" -> do+ putStrLn "Running sourceDirectoryDeep from conduit-extra"+ runResourceT $+ sourceDirectoryDeep False dir+ =$ filterC (".hs" `isSuffixOf`)+ $$ mapM_C (liftIO . putStrLn)++ "find-conduit" -> do+ putStrLn "Running findFiles from find-conduit"+ findFiles defaultFindOptions { findFollowSymlinks = False }+ dir $ do+ path <- asks entryPath+ guard (".hs" `isSuffixOf` path)+ norecurse+ liftIO $ putStrLn path++ "find-conduit2" -> do+ putStrLn "Running findFiles from find-conduit"+ runResourceT $+ sourceFindFiles defaultFindOptions { findFollowSymlinks = False }+ dir (return ())+ =$ filterC ((".hs" `isSuffixOf`) . entryPath . fst)+ $$ mapM_C (liftIO . putStrLn . entryPath . fst)++ "find" -> do+ putStrLn "Running GNU find"+ executeFile "find" True [dir, "-name", "*.hs", "-print"] Nothing
+ test/main.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Conduit+import Data.Conduit.Find+import Test.Hspec++main :: IO ()+main = hspec $ do+ describe "basic tests" $ do+ it "file passes a test" $ do+ res <- test (regular >> not_ executable) "README.md"+ res `shouldBe` True++ it "file fails a test" $ do+ res <- test (not_ regular) "README.md"+ res `shouldBe` False++ it "file fails another test" $ do+ res <- test (regular >> executable) "README.md"+ res `shouldBe` False++ it "finds files" $ do+ xs <- runResourceT $+ find "."+ (do ignoreVcs+ when_ (name_ "dist") prune+ glob "*.hs"+ not_ (glob "Setup*")+ regular+ not_ executable)+ $$ sinkList++ "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True+ "./dist/setup-config" `elem` xs `shouldBe` False+ "./Setup.hs" `elem` xs `shouldBe` False+ "./.git/config" `elem` xs `shouldBe` False++ it "finds files with a different ordering" $ do+ xs <- runResourceT $+ find "."+ (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+ "./dist/setup-config" `elem` xs `shouldBe` False+ "./Setup.hs" `elem` xs `shouldBe` False+ "./.git/config" `elem` xs `shouldBe` False++ it "finds files using a pre-pass filter" $ do+ xs <- runResourceT $+ find "."+ (do ignoreVcs+ when_ (name_ "dist") prune+ glob "*.hs"+ not_ (glob "Setup*")+ regular+ not_ executable)+ $$ sinkList++ "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True+ "./dist/setup-config" `elem` xs `shouldBe` False+ "./Setup.hs" `elem` xs `shouldBe` False+ "./.git/config" `elem` xs `shouldBe` False++ it "properly applies post-pass pruning" $ do+ xs <- runResourceT $+ find "."+ (do ignoreVcs+ maxdepth_ 1+ when_ (name_ "dist") prune+ glob "*.hs"+ not_ (glob "Setup*")+ regular+ not_ executable)+ $$ sinkList++ "./Data/Conduit/Find.hs" `elem` xs `shouldBe` False+ "./dist/setup-config" `elem` xs `shouldBe` False+ "./Setup.hs" `elem` xs `shouldBe` False+ "./.git/config" `elem` xs `shouldBe` False