diff --git a/Data/Cond.hs b/Data/Cond.hs --- a/Data/Cond.hs +++ b/Data/Cond.hs @@ -6,19 +6,20 @@ {-# LANGUAGE TypeFamilies #-} module Data.Cond - ( Result(..), toResult, fromResult - , CondT(..), runCondT, Cond, runCond - , if_, ifM_, apply, test - , reject, rejectAll, norecurse - , or_, (||:), and_, (&&:), not_, prune - , traverseRecursively + ( CondT(..), Cond + , runCondT, applyCondT, runCond, applyCond + , guardM, guard_, guardM_, apply, consider + , matches, if_, when_, unless_, or_, and_, not_ + , ignore, norecurse, prune + , test, recurse ) where import Control.Applicative import Control.Arrow (first) -import Control.Monad +import Control.Monad hiding (mapM_, sequence_) import Control.Monad.Base import Control.Monad.Catch +import Control.Monad.Morph import Control.Monad.Reader.Class import Control.Monad.State.Class import Control.Monad.Trans @@ -26,19 +27,14 @@ import Control.Monad.Trans.State (StateT(..), withStateT, evalStateT) import Data.Foldable import Data.Functor.Identity -import Data.List.NonEmpty import Data.Maybe (fromMaybe, isJust) import Data.Monoid hiding ((<>)) import Data.Semigroup -import Prelude hiding (foldr1) +import Prelude hiding (mapM_, foldr1, sequence_) --- | 'Result' is an enriched 'Maybe' type which additionally specifies whether +-- | 'Result' is an enriched 'Maybe' type which also specifies whether -- recursion should occur from the given input, and if so, how such --- recursion should be done. It is isomorphic to: --- --- @ --- type Result a m b = (Maybe b, Maybe (Maybe (CondT a m b))) --- @ +-- recursion should be performed. data Result a m b = Ignore | Keep b | RecurseOnly (Maybe (CondT a m b)) @@ -55,7 +51,15 @@ fmap f (Keep a) = Keep (f a) fmap f (RecurseOnly l) = RecurseOnly (liftM (fmap f) l) fmap f (KeepAndRecurse a l) = KeepAndRecurse (f a) (liftM (fmap f) l) + {-# INLINE fmap #-} +instance MFunctor (Result a) where + hoist _ Ignore = Ignore + hoist _ (Keep a) = Keep a + hoist nat (RecurseOnly l) = RecurseOnly (fmap (hoist nat) l) + hoist nat (KeepAndRecurse a l) = KeepAndRecurse a (fmap (hoist nat) l) + {-# INLINE hoist #-} + instance Semigroup (Result a m b) where Ignore <> _ = Ignore _ <> Ignore = Ignore @@ -69,18 +73,20 @@ _ <> KeepAndRecurse b m = KeepAndRecurse b m instance Monoid b => Monoid (Result a m b) where - mempty = KeepAndRecurse mempty Nothing - x `mappend` y = x <> y + mempty = KeepAndRecurse mempty Nothing + {-# INLINE mempty #-} + mappend = (<>) + {-# INLINE mappend #-} -recurse :: Result a m b -recurse = RecurseOnly Nothing +accept' :: b -> Result a m b +accept' = flip KeepAndRecurse Nothing -accept :: b -> Result a m b -accept = flip KeepAndRecurse Nothing +recurse' :: Result a m b +recurse' = RecurseOnly Nothing toResult :: Monad m => Maybe a -> forall r. Result r m a -toResult Nothing = recurse -toResult (Just a) = accept a +toResult Nothing = recurse' +toResult (Just a) = accept' a fromResult :: Monad m => forall r. Result r m a -> Maybe a fromResult Ignore = Nothing @@ -88,28 +94,30 @@ fromResult (RecurseOnly _) = Nothing fromResult (KeepAndRecurse a _) = Just a --- | 'CondT" is an arrow that maps from 'a' to @m b@, but only if 'a' --- satisfies certain conditions. It is a Monad, meaning each condition --- stated must be satisfied for the map to succeed (in the spirit of the --- 'Maybe' short-circuiting Monad). In fact, 'CondT' is nearly equivalent --- to @StateT a (MaybeT m) b@, with some additional complexity for --- performing recursive iterations (see the 'Result' type above). +-- | 'CondT' is an enhanced form @StateT a (MaybeT m) b@, which uses the +-- 'Result' type instead of 'Maybe' to additional express whether recursion +-- should be performed on the current state. This is used to form +-- predicates to guide recursive unfolds. -- --- You can promote functions of type @a -> m (Maybe b)@ into 'CondT' using --- 'apply'. Pure functions @a -> Bool@ are lifted with 'if_', and --- @a -> m Bool@ with 'ifM_'. In effect, @if_ f@ is the same as --- @ask >>= guard . f@. +-- Several different types may be promoted to 'CondT': -- +-- [@Bool@] guard +-- [@m Bool@] guardM +-- [@a -> Bool@] guard_ +-- [@a -> m Bool@] guardM_ +-- [@a -> m (Maybe b)@] apply +-- [@a -> m (Maybe (b, a))@] consider +-- -- Here is a trivial example: -- -- @ -- flip runCondT 42 $ do --- if_ even +-- guard_ even -- liftIO $ putStrLn "42 must be even to reach here" -- --- if_ odd <|> if_ even --- if_ even &&: if_ (== 42) --- if_ ((== 0) . (`mod` 6)) +-- guard_ odd <|> guard_ even +-- guard_ even &&: guard_ (== 42) +-- guard_ ((== 0) . (`mod` 6)) -- @ -- -- 'CondT' is typically invoked using 'runCondT', in which case it maps 'a' @@ -122,23 +130,31 @@ type Cond a = CondT a Identity -instance Monad m => Semigroup (CondT a m b) where - (<>) = (>>) +instance (Monad m, Semigroup b) => Semigroup (CondT a m b) where + (<>) = liftM2 (<>) + {-# INLINE (<>) #-} -instance Monad m => Monoid (CondT a m a) where - mempty = ask - mappend = (<>) +instance (Monad m, Monoid b) => Monoid (CondT a m b) where + mempty = CondT $ return $ accept' mempty + {-# INLINE mempty #-} + mappend = liftM2 mappend + {-# INLINE mappend #-} instance Monad m => Functor (CondT a m) where fmap f (CondT g) = CondT (liftM (fmap f) g) + {-# INLINE fmap #-} instance Monad m => Applicative (CondT a m) where pure = return + {-# INLINE pure #-} (<*>) = ap + {-# INLINE (<*>) #-} instance Monad m => Monad (CondT a m) where - return = CondT . return . accept + return = CondT . return . accept' + {-# INLINE return #-} fail _ = mzero + {-# INLINE fail #-} CondT f >>= k = CondT $ do r <- f case r of @@ -153,26 +169,41 @@ KeepAndRecurse b _ -> getCondT (k b) instance Monad m => MonadReader a (CondT a m) where - ask = CondT $ liftM accept get + ask = CondT $ gets accept' + {-# INLINE ask #-} local f (CondT m) = CondT $ withStateT f m - reader f = f <$> ask + {-# INLINE local #-} + reader f = liftM f ask + {-# INLINE reader #-} instance Monad m => MonadState a (CondT a m) where - get = CondT $ accept `liftM` get - put s = CondT $ accept `liftM` put s - state f = CondT $ state (fmap (first accept) f) + get = CondT $ gets accept' + {-# INLINE get #-} + put s = CondT $ liftM accept' $ put s + {-# INLINE put #-} + state f = CondT $ state (fmap (first accept') f) + {-# INLINE state #-} -instance Monad m => MonadPlus (CondT a m) where - mzero = CondT $ return recurse - CondT f `mplus` CondT g = CondT $ do +instance Monad m => Alternative (CondT a m) where + empty = CondT $ return recurse' + {-# INLINE empty #-} + CondT f <|> CondT g = CondT $ do r <- f case r of x@(Keep _) -> return x x@(KeepAndRecurse _ _) -> return x _ -> g + {-# INLINE (<|>) #-} +instance Monad m => MonadPlus (CondT a m) where + mzero = empty + {-# INLINE mzero #-} + mplus = (<|>) + {-# INLINE mplus #-} + instance MonadThrow m => MonadThrow (CondT a m) where - throwM = CondT . throwM + throwM = CondT . throwM + {-# INLINE throwM #-} instance MonadCatch m => MonadCatch (CondT a m) where catch (CondT m) c = CondT $ m `catch` \e -> getCondT (c e) @@ -183,118 +214,177 @@ where q u = CondT . u . getCondT instance MonadBase b m => MonadBase b (CondT a m) where - liftBase m = CondT $ accept `liftM` liftBase m + liftBase m = CondT $ liftM accept' $ liftBase m + {-# INLINE liftBase #-} instance MonadIO m => MonadIO (CondT a m) where - liftIO m = CondT $ accept `liftM` liftIO m + liftIO m = CondT $ liftM accept' $ liftIO m + {-# INLINE liftIO #-} instance MonadTrans (CondT a) where - lift m = CondT $ accept `liftM` lift m + lift m = CondT $ liftM accept' $ lift m + {-# INLINE lift #-} instance MonadBaseControl b m => MonadBaseControl b (CondT r m) where newtype StM (CondT r m) a = CondTStM { unCondTStM :: StM m (Result r m a, r) } liftBaseWith f = CondT $ StateT $ \s -> - liftM (\x -> (accept x, s)) $ liftBaseWith $ \runInBase -> f $ \k -> + liftM (\x -> (accept' x, s)) $ liftBaseWith $ \runInBase -> f $ \k -> liftM CondTStM $ runInBase $ runStateT (getCondT k) s restoreM = CondT . StateT . const . restoreM . unCondTStM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} +instance MFunctor (CondT a) where + hoist nat (CondT m) = CondT $ hoist nat (liftM (hoist nat) m) + {-# INLINE hoist #-} + runCondT :: Monad m => CondT a m b -> a -> m (Maybe b) -runCondT (CondT f) a = do - r <- evalStateT f a - return $ case r of - Ignore -> Nothing - Keep b -> Just b - RecurseOnly _ -> Nothing - KeepAndRecurse b _ -> Just b +runCondT (CondT f) a = fromResult `liftM` evalStateT f a +{-# INLINE runCondT #-} runCond :: Cond a b -> a -> Maybe b runCond = (runIdentity .) . runCondT +{-# INLINE runCond #-} -if_ :: Monad m => (a -> Bool) -> CondT a m () -if_ f = ask >>= guard . f +-- | Case analysis of applying a condition to an input value. Note that +-- function provided should recurse, calling applyCondT again, if the given +-- condition is Just, should it wish to. Not result value is accumulated by +-- this function, meaning you should use 'WriterT' if you wish to do so +-- (unlike the pure variant, 'applyCond', which must accumulate a value to +-- have any meaning). +applyCondT :: Monad m + => a + -> CondT a m b + -> (a -> Maybe b -> Maybe (CondT a m b) -> m ()) + -> m () +applyCondT a c k = do + (r, a') <- runStateT (getCondT c) a + case r of + Ignore -> k a' Nothing Nothing + Keep b -> k a' (Just b) Nothing + RecurseOnly c' -> k a' Nothing (Just (fromMaybe c c')) + KeepAndRecurse b c' -> k a' (Just b) (Just (fromMaybe c c')) -ifM_ :: Monad m => (a -> m Bool) -> CondT a m () -ifM_ f = ask >>= lift . f >>= guard +-- | Case analysis of applying a pure condition to an input value. Note that +-- the user is responsible for recursively calling this function if the +-- resulting condition is a Just value. Each step of the recursion must +-- return a Monoid so that a final result may be collected. +applyCond :: Monoid c + => a + -> Cond a b + -> (a -> Maybe b -> Maybe (Cond a b) -> c) + -> c +applyCond a c k = case runIdentity (runStateT (getCondT c) a) of + (Ignore, a') -> k a' Nothing Nothing + (Keep b, a') -> k a' (Just b) Nothing + (RecurseOnly c', a') -> k a' Nothing (Just (fromMaybe c c')) + (KeepAndRecurse b c', a') -> k a' (Just b) (Just (fromMaybe c c')) +guardM :: Monad m => m Bool -> CondT a m () +guardM m = lift m >>= guard +{-# INLINE guardM #-} + +guard_ :: Monad m => (a -> Bool) -> CondT a m () +guard_ f = ask >>= guard . f +{-# INLINE guard_ #-} + +guardM_ :: Monad m => (a -> m Bool) -> CondT a m () +guardM_ f = ask >>= lift . f >>= guard +{-# INLINE guardM_ #-} + apply :: Monad m => (a -> m (Maybe b)) -> CondT a m b -apply f = CondT $ liftM toResult . lift . f =<< get +apply f = CondT $ get >>= liftM toResult . lift . f +{-# INLINE apply #-} -test :: Monad m => CondT a m b -> a -> m Bool -test = (liftM isJust .) . runCondT +consider :: Monad m => (a -> m (Maybe (b, a))) -> CondT a m b +consider f = CondT $ do + a <- get + mres <- lift $ f a + case mres of + Nothing -> return Ignore + Just (b, a') -> put a' >> return (accept' b) +{-# INLINE consider #-} --- | 'reject' rejects the current entry, but allows recursion. This is the --- same as 'mzero'. -reject :: Monad m => CondT a m b -reject = mzero +matches :: Monad m => CondT a m b -> CondT a m Bool +matches = fmap isJust . optional +{-# INLINE matches #-} --- | 'rejectAll' rejects the entry and all of its descendents. -rejectAll :: Monad m => CondT a m b -rejectAll = CondT $ return Ignore +if_ :: Monad m => CondT a m b -> CondT a m c -> CondT a m c -> CondT a m c +if_ c x y = CondT $ do + r <- getCondT c + getCondT $ case r of + Ignore -> y + Keep _ -> x + RecurseOnly _ -> y + KeepAndRecurse _ _ -> x +{-# INLINE if_ #-} --- | 'norecurse' indicates that recursion should not be performed on the current --- item. Note that this library doesn't perform any actual recursion; that --- is up to the consumer of the final 'Result' value, typically --- 'applyCondT'. -norecurse :: Monad m => CondT a m () -norecurse = CondT $ return (Keep ()) +when_ :: Monad m => CondT a m b -> CondT a m () -> CondT a m () +when_ c x = if_ c x (return ()) +{-# INLINE when_ #-} -or_ :: Monad m => NonEmpty (CondT a m b) -> CondT a m b -or_ = foldr1 mplus +unless_ :: Monad m => CondT a m b -> CondT a m () -> CondT a m () +unless_ c = if_ c (return ()) +{-# INLINE unless_ #-} -infixr 3 &&: -(||:) :: Monad m => CondT a m b -> CondT a m b -> CondT a m b -(||:) = mplus +-- | Check whether at least one of the given conditions is true. This is a +-- synonym for 'Data.Foldable.asum'. +or_ :: Monad m => [CondT a m b] -> CondT a m b +or_ = asum +{-# INLINE or_ #-} -and_ :: Monad m => [CondT a m b] -> CondT a m [b] -and_ = foldl' (\acc x -> (:) <$> x <*> acc) (return []) +-- | Check that all of the given conditions are true. This is a synonym for +-- 'Data.Foldable.sequence_'. +and_ :: Monad m => [CondT a m b] -> CondT a m () +and_ = sequence_ +{-# INLINE and_ #-} -infixr 2 ||: -(&&:) :: Monad m => CondT a m b -> CondT a m c -> CondT a m (b, c) -(&&:) = liftM2 (,) +-- | 'not_' inverts the meaning of the given predicate. +not_ :: Monad m => CondT a m b -> CondT a m () +not_ c = when_ c ignore +{-# INLINE not_ #-} --- | 'not_' inverts the meaning of the given predicate while preserving --- recursion. -not_ :: Monad m => CondT a m () -> CondT a m () -not_ (CondT f) = CondT $ go `liftM` f - where - go Ignore = accept () - go (Keep _) = recurse - go (RecurseOnly _) = accept () - go (KeepAndRecurse _ _) = recurse +-- | 'ignore' ignores the current entry, but allows recursion into its +-- descendents. This is the same as 'mzero'. +ignore :: Monad m => CondT a m b +ignore = mzero +{-# INLINE ignore #-} --- | 'prune' is like 'not_', but does not preserve recursion. It should be read --- as "prune this entry and all its descendents if the predicate matches". --- It is the same as @x ||: rejectAll@. -prune :: Monad m => CondT a m () -> CondT a m () -prune (CondT f) = CondT $ go `liftM` f - where - go Ignore = accept () - go (Keep _) = Ignore - go (RecurseOnly _) = accept () - go (KeepAndRecurse _ _) = Ignore +-- | 'prune' is a synonym for both ignoring an entry and its descendents. It +-- is the same as 'ignore >> norecurse'. +prune :: Monad m => CondT a m () +prune = CondT $ return Ignore +{-# INLINE prune #-} --- | This function expresses the pattern of recursive traversal, directed by a --- 'CondT' predicate. It does not require that the structure being traversed --- in memory, as it might very well be a filesystem, the decision tree of an --- algorithm, etc. It works very nicely with conduits, in order to iterate --- over the traversal in constant space. -traverseRecursively :: (Monad m, Monad n) - => a - -> CondT a m b - -> (a -> b -> n ()) - -> (forall x. m x -> n x) - -> (a -> (a -> n ()) -> n ()) - -> n () -traverseRecursively a c f trans getChildren = do - r <- trans $ evalStateT (getCondT c) a - case r of - Ignore -> return () - Keep b -> f a b - RecurseOnly m -> descend (fromMaybe c m) - KeepAndRecurse b m -> f a b >> descend (fromMaybe c m) - where - descend next = getChildren a $ \child -> - traverseRecursively child next f trans getChildren +-- | 'norecurse' prevents recursion into the current entry's descendents, but +-- does not ignore the entry itself. +norecurse :: Monad m => CondT a m () +norecurse = CondT $ return $ Keep () +{-# INLINE norecurse #-} + +test :: Monad m => CondT a m b -> a -> m Bool +test = (liftM isJust .) . runCondT +{-# INLINE test #-} + +-- | 'recurse' changes the recursion predicate for any child elements. For +-- example, the following file-finding predicate looks for all @*.hs@ files, +-- but under any @.git@ directory, only looks for a file named @config@: +-- +-- @ +-- if_ (name_ \".git\" \>\> directory) +-- (ignore \>\> recurse (name_ \"config\")) +-- (glob \"*.hs\") +-- @ +-- +-- If this code had used @recurse (glob \"*.hs\"))@ instead in the else case, +-- it would have meant that @.git@ is only looked for at the top-level of the +-- search (i.e., the top-most element). +recurse :: Monad m => CondT a m b -> CondT a m b +recurse c = CondT $ do + r <- getCondT c + return $ case r of + Ignore -> Ignore + Keep b -> Keep b + RecurseOnly _ -> RecurseOnly (Just c) + KeepAndRecurse b _ -> KeepAndRecurse b (Just c) diff --git a/Data/Conduit/Find.hs b/Data/Conduit/Find.hs --- a/Data/Conduit/Find.hs +++ b/Data/Conduit/Find.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} module Data.Conduit.Find ( @@ -18,32 +19,49 @@ -- * Finding functions find - , find' - , lfind - , lfind' + , findFilesSource + , findFiles + , findFilePaths + , test + , ltest , stat , lstat - , test - , findRaw + , hasStatus - -- * File path predicates - , ignoreVcs - , regex + -- * File path predicates , glob + , regex + , ignoreVcs + + -- * GNU find compatibility predicates + , depth_ + , maxdepth_ + , mindepth_ + , ignoreReaddirRace_ + , noIgnoreReaddirRace_ + , amin_ + , atime_ + , anewer_ + , empty_ + , executable_ + , gid_ + , name_ + , getDepth , filename_ , filenameS_ - , filepath_ - , filepathS_ - , withPath + , pathname_ + , pathnameS_ + , getFilePath + , follow_ + , prune_ -- * File entry predicates (uses stat information) , regular + , directory , hasMode , executable - , depth - , lastAccessed - , lastModified - , withFileStatus + , lastAccessed_ + , lastModified_ -- * Predicate combinators , module Cond @@ -55,12 +73,15 @@ import Conduit import Control.Applicative -import Control.Monad +import Control.Exception +import Control.Monad hiding (forM_) +import Control.Monad.Morph import Control.Monad.State.Class -import Data.Attoparsec.Text +import Data.Attoparsec.Text as A import Data.Bits import qualified Data.Cond as Cond import Data.Cond hiding (test) +import Data.Foldable hiding (elem, find) import Data.Maybe (fromMaybe) import Data.Monoid import Data.Text (Text, unpack, pack) @@ -167,35 +188,239 @@ See 'Data.Cond' for more details on the Monad used to build predicates. -} -type Predicate m a = CondT a m () +data FindOptions = FindOptions + { findFollowSymlinks :: Bool + , findContentsFirst :: Bool + , findIgnoreReaddirRace :: Bool + , findIgnoreResults :: Bool + } +defaultFindOptions :: FindOptions +defaultFindOptions = FindOptions + { findFollowSymlinks = True + , findContentsFirst = False + , findIgnoreReaddirRace = False + , findIgnoreResults = False + } + data FileEntry = FileEntry - { entryPath :: FilePath - , entryDepth :: Int - , entryStatus :: Maybe FileStatus + { entryPath :: !FilePath + , entryDepth :: !Int + , entryFindOptions :: !(FindOptions) + , entryStatus :: !(Maybe FileStatus) -- ^ This is Nothing until we determine stat should be called. } +newFileEntry :: FilePath -> Int -> FindOptions -> FileEntry +newFileEntry p d f = FileEntry p d f Nothing + instance Show FileEntry where show entry = "FileEntry " ++ show (entryPath entry) ++ " " ++ show (entryDepth entry) -newFileEntry :: FilePath -> Int -> FileEntry -newFileEntry p d = FileEntry p d Nothing +getFilePath :: Monad m => CondT FileEntry m FilePath +getFilePath = gets entryPath --- | Return all entries, except for those within version-control metadata --- directories (and not including the version control directory itself either). -ignoreVcs :: Monad m => Predicate m FileEntry -ignoreVcs = prune (filename_ (`elem` vcsDirs)) +pathname_ :: Monad m => (FilePath -> Bool) -> CondT FileEntry m () +pathname_ f = guard . f =<< getFilePath + +pathnameS_ :: Monad m => (String -> Bool) -> CondT FileEntry m () +pathnameS_ f = pathname_ (f . encodeString) + +filename_ :: Monad m => (FilePath -> Bool) -> CondT FileEntry m () +filename_ f = pathname_ (f . filename) + +filenameS_ :: Monad m => (String -> Bool) -> CondT FileEntry m () +filenameS_ f = pathname_ (f . encodeString . filename) + +getDepth :: Monad m => CondT FileEntry m Int +getDepth = gets entryDepth + +modifyFindOptions :: Monad m + => (FindOptions -> FindOptions) + -> CondT FileEntry m () +modifyFindOptions f = + modify $ \e -> e { entryFindOptions = f (entryFindOptions e) } + +------------------------------------------------------------------------ +-- Workalike options for emulating GNU find. +------------------------------------------------------------------------ + +depth_ :: Monad m => CondT FileEntry m () +depth_ = modifyFindOptions $ \opts -> opts { findContentsFirst = True } + +follow_ :: Monad m => CondT FileEntry m () +follow_ = modifyFindOptions $ \opts -> opts { findFollowSymlinks = True } + +ignoreReaddirRace_ :: Monad m => CondT FileEntry m () +ignoreReaddirRace_ = + modifyFindOptions $ \opts -> opts { findIgnoreReaddirRace = True } + +noIgnoreReaddirRace_ :: Monad m => CondT FileEntry m () +noIgnoreReaddirRace_ = + modifyFindOptions $ \opts -> opts { findIgnoreReaddirRace = False } + +maxdepth_ :: Monad m => Int -> CondT FileEntry m () +maxdepth_ l = getDepth >>= guard . (<= l) + +mindepth_ :: Monad m => Int -> CondT FileEntry m () +mindepth_ l = getDepth >>= guard . (>= l) + +prune_ :: Monad m => CondT a m () +prune_ = prune + +-- xdev_ = error "NYI" + +timeComp :: MonadIO m + => ((UTCTime -> Bool) -> CondT FileEntry m ()) -> Int + -> CondT FileEntry m () +timeComp f n = do + now <- liftIO getCurrentTime + f (\t -> diffUTCTime now t > fromIntegral n) + +amin_ :: MonadIO m => Int -> CondT FileEntry m () +amin_ n = timeComp lastAccessed_ (n * 60) + +atime_ :: MonadIO m => Int -> CondT FileEntry m () +atime_ n = timeComp lastAccessed_ (n * 24 * 3600) + +anewer_ :: MonadIO m => FilePath -> CondT FileEntry m () +anewer_ path = do + e <- get + es <- applyStat Nothing + ms <- getStat Nothing e { entryPath = path + , entryStatus = Nothing + } + case ms of + Nothing -> prune >> error "This is never reached" + Just (s, _) -> guard $ diffUTCTime (f s) (f es) > 0 where - vcsDirs = [ ".git", "CVS", "RCS", "SCCS", ".svn", ".hg", "_darcs" ] + f = posixSecondsToUTCTime . accessTimeHiRes -regex :: Monad m => Text -> Predicate m FileEntry -regex pat = filename_ (=~ pat) +-- cmin_ = error "NYI" +-- cnewer_ = error "NYI" +-- ctime_ = error "NYI" +empty_ :: MonadIO m => CondT FileEntry m () +empty_ = (regular >> hasStatus ((== 0) . fileSize)) + <|> (directory >> hasStatus ((== 2) . linkCount)) + +executable_ :: MonadIO m => CondT FileEntry m () +executable_ = executable + +gid_ :: MonadIO m => Int -> CondT FileEntry m () +gid_ n = hasStatus ((== n) . fromIntegral . fileGroup) + +{- +group_ name +ilname_ pat +iname_ pat +inum_ n +ipath_ pat +iregex_ pat +iwholename_ pat +links_ n +lname_ pat +mmin_ +mtime_ +-} + +name_ :: Monad m => FilePath -> CondT FileEntry m () +name_ = filename_ . (==) + +{- +newer_ path +newerXY_ ref +nogroup_ +nouser_ +path_ pat +perm_ mode :: Perm +readable_ +regex_ pat +samefile_ path +size_ n :: Size +type_ c +uid_ n +used_ n +user_ name +wholename_ pat +writable_ +xtype_ c +-} + +------------------------------------------------------------------------ + +-- | Get the current status for the file. If the status being requested is +-- already cached in the entry information, simply return it from there. +getStat :: MonadIO m + => Maybe Bool + -> FileEntry + -> m (Maybe (FileStatus, FileEntry)) +getStat mfollow entry = case entryStatus entry of + Just s + | maybe True (== follow entry) mfollow -> + return $ Just (s, entry) + | otherwise -> fmap (, entry) `liftM` wrapStat + Nothing -> do + ms <- wrapStat + case ms of + Just s -> return $ Just (s, entry { entryStatus = Just s }) + Nothing -> return Nothing + where + follow = findFollowSymlinks . entryFindOptions + doStat = (if fromMaybe (follow entry) mfollow + then getFileStatus + else getSymbolicLinkStatus) $ encodeString (entryPath entry) + wrapStat = liftIO $ catch (Just <$> doStat) $ \e -> + if findIgnoreReaddirRace opts + then return Nothing + else throwIO (e :: IOException) + where + opts = entryFindOptions entry + +applyStat :: MonadIO m => Maybe Bool -> CondT FileEntry m FileStatus +applyStat mfollow = do + e <- get + ms <- lift (getStat mfollow e) + case ms of + Nothing -> prune >> error "This is never reached" + Just (s, e') -> s <$ put e' + +lstat :: MonadIO m => CondT FileEntry m FileStatus +lstat = applyStat (Just False) + +stat :: MonadIO m => CondT FileEntry m FileStatus +stat = applyStat (Just True) + +hasStatus :: MonadIO m => (FileStatus -> Bool) -> CondT FileEntry m () +hasStatus f = guard . f =<< applyStat Nothing + +regular :: MonadIO m => CondT FileEntry m () +regular = hasStatus isRegularFile + +executable :: MonadIO m => CondT FileEntry m () +executable = hasMode ownerExecuteMode + +directory :: MonadIO m => CondT FileEntry m () +directory = hasStatus isDirectory + +hasMode :: MonadIO m => FileMode -> CondT FileEntry m () +hasMode m = hasStatus (\s -> fileMode s .&. m /= 0) + +withStatusTime :: MonadIO m + => (FileStatus -> POSIXTime) -> (UTCTime -> Bool) + -> CondT FileEntry m () +withStatusTime g f = hasStatus (f . posixSecondsToUTCTime . g) + +lastAccessed_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m () +lastAccessed_ = withStatusTime accessTimeHiRes + +lastModified_ :: MonadIO m => (UTCTime -> Bool) -> CondT FileEntry m () +lastModified_ = withStatusTime modificationTimeHiRes + -- | This is a re-export of 'Text.Regex.Posix.=~', with the types changed for --- ease of use with this module. For example, you can simply say: +-- use with this module. For example, you can simply say: -- -- @ -- filename_ (=~ \"\\\\.hs$\") @@ -209,9 +434,19 @@ (=~) :: FilePath -> Text -> Bool str =~ pat = encodeString str R.=~ unpack pat +regex :: Monad m => Text -> CondT FileEntry m () +regex pat = filename_ (=~ pat) + +-- | Return all entries, except for those within version-control metadata +-- directories (and not including the version control directory itself either). +ignoreVcs :: Monad m => CondT FileEntry m () +ignoreVcs = when_ (filename_ (`elem` vcsDirs)) prune + where + vcsDirs = [ ".git", "CVS", "RCS", "SCCS", ".svn", ".hg", "_darcs" ] + -- | Find every entry whose filename part matching the given filename globbing -- expression. For example: @glob "*.hs"@. -glob :: Monad m => Text -> Predicate m FileEntry +glob :: Monad m => Text -> CondT FileEntry m () glob g = case parseOnly globParser g of Left e -> error $ "Failed to parse glob: " ++ e Right x -> regex ("^" <> x <> "$") @@ -223,7 +458,7 @@ <|> string "[]]" *> return "[]]" <|> (\x y z -> pack ((x:y) ++ [z])) <$> char '[' - <*> manyTill anyChar (try (char ']')) + <*> manyTill anyChar (A.try (char ']')) <*> char ']' <|> do x <- anyChar @@ -231,145 +466,78 @@ then ['\\', x] else [x] -doStat :: MonadIO m => (String -> IO FileStatus) -> Predicate m FileEntry -doStat getstatus = do - entry <- get - s <- liftIO $ getstatus (encodeString (entryPath entry)) - put $ entry { entryStatus = Just s } - -lstat :: MonadIO m => Predicate m FileEntry -lstat = doStat getSymbolicLinkStatus - -stat :: MonadIO m => Predicate m FileEntry -stat = doStat getFileStatus - -getStatus :: FileEntry -> FileStatus -getStatus e = fromMaybe - (error $ "FileStatus has not been determined for: " ++ show (entryPath e)) - (entryStatus e) - -withFileStatus :: Monad m - => (FileStatus -> m Bool) - -> Predicate m FileEntry -withFileStatus f = ifM_ (f . getStatus) - -status :: Monad m => (FileStatus -> Bool) -> Predicate m FileEntry -status f = withFileStatus (return . f) - -regular :: Monad m => Predicate m FileEntry -regular = status isRegularFile - -directory :: Monad m => Predicate m FileEntry -directory = status isDirectory - -hasMode :: Monad m => FileMode -> Predicate m FileEntry -hasMode m = status (\s -> fileMode s .&. m /= 0) - -executable :: Monad m => Predicate m FileEntry -executable = hasMode ownerExecuteMode - -withPath :: Monad m - => (FilePath -> m Bool) - -> Predicate m FileEntry -withPath f = ifM_ (f . entryPath) - -filename_ :: Monad m => (FilePath -> Bool) -> Predicate m FileEntry -filename_ f = withPath (return . f . filename) - -filenameS_ :: Monad m => (String -> Bool) -> Predicate m FileEntry -filenameS_ f = withPath (return . f . encodeString . filename) - -filepath_ :: Monad m => (FilePath -> Bool) -> Predicate m FileEntry -filepath_ f = withPath (return . f) - -filepathS_ :: Monad m => (String -> Bool) -> Predicate m FileEntry -filepathS_ f = withPath (return . f . encodeString) - -depth :: Monad m => (Int -> Bool) -> Predicate m FileEntry -depth f = if_ (f . entryDepth) - -withStatusTime :: Monad m - => (UTCTime -> Bool) -> (FileStatus -> POSIXTime) - -> Predicate m FileEntry -withStatusTime f g = status (f . posixSecondsToUTCTime . g) +-- | Find file entries in a directory tree, recursively, applying the given +-- recursion predicate to the search. This conduit yields pairs of type +-- @(FileEntry, a)@, where is the return value from the predicate at each +-- step. +findFilesSource :: (MonadIO m, MonadResource m) + => FindOptions + -> FilePath + -> CondT FileEntry m a + -> Producer m (FileEntry, a) +findFilesSource opts startPath predicate = + wrap $ go (newFileEntry startPath 0 opts) $ hoist lift predicate + where + wrap = mapInput (const ()) (const Nothing) -lastAccessed :: Monad m => (UTCTime -> Bool) -> Predicate m FileEntry -lastAccessed = flip withStatusTime accessTimeHiRes + go x pr = applyCondT x pr $ \e mb mcond -> do + let opts' = entryFindOptions e + this = unless (findIgnoreResults opts') $ + yieldEntry e mb + next = walkChildren e mcond + if findContentsFirst opts' + then next >> this + else this >> next -lastModified :: Monad m => (UTCTime -> Bool) -> Predicate m FileEntry -lastModified = flip withStatusTime modificationTimeHiRes + yieldEntry e mb = + -- If the item matched, also yield the predicate's result value. + forM_ mb $ yield . (e,) --- | A raw find does no processing on the FileEntry, leaving it up to the user --- to determine when and if stat should be called. Note that unless you --- take care to indicate when recursion should happen, an error will result --- when the raw finder attempts to recurse on a non-directory. The bare --- minimum for a proper finder should look like this for non-recursion: --- --- @ --- findRaw \ $ do --- \ --- localM stat $ do --- directory ||: norecurse --- \ --- @ --- --- To apply predicates only to a single directory, without recursing, simply --- start (or end) the predicate with 'norecurse', and use @localM stat@ or --- @localM lstat@ at the point where you need 'FileStatus' information. -findRaw :: (MonadIO m, MonadResource m) - => FilePath -> Bool -> Predicate m FileEntry -> Source m FileEntry -findRaw path follow predicate = - traverseRecursively - (newFileEntry path 0) - predicate - (const . yield) - lift - readDirectory - where - readDirectory (FileEntry p d mst) go = do - -- If no status has been determined yet, we must now in order to know - -- whether to traverse or not. - recurse <- isDirectory <$> case mst of - Nothing -> liftIO $ (if follow - then getFileStatus - else getSymbolicLinkStatus) - $ encodeString p - Just st -> return st - when recurse $ - (sourceDirectory p =$) $ awaitForever $ \fp -> - mapInput (const ()) (const Nothing) $ - go $ newFileEntry fp (succ d) + walkChildren e@(FileEntry path depth opts' _) mcond = + -- If the conditional matched, we are requested to recurse if this + -- is a directory + forM_ mcond $ \cond -> do + -- If no status has been determined, we must do so now in order + -- to know whether to actually recurse or not. + descend <- fmap (isDirectory . fst) <$> getStat Nothing e + when (descend == Just True) $ + (sourceDirectory path =$) $ awaitForever $ \fp -> + wrap $ go (newFileEntry fp (succ depth) opts') cond -basicFind :: (MonadIO m, MonadResource m) - => Predicate m FileEntry - -> Bool +findFiles :: (MonadIO m, MonadBaseControl IO m, MonadThrow m) + => FindOptions -> FilePath - -> Predicate m FileEntry - -> Source m FileEntry -basicFind f follow path pr = findRaw path follow $ - f >> (directory ||: norecurse) >> pr + -> CondT FileEntry m a + -> m () +findFiles opts path predicate = + runResourceT $ findFilesSource + opts { findIgnoreResults = True } path (hoist lift predicate) + $$ sinkNull -find' :: (MonadIO m, MonadResource m) - => FilePath -> Predicate m FileEntry - -> Source m FileEntry -find' = basicFind stat True +-- | A simpler version of 'findFiles', which yields only 'FilePath' values, +-- and ignores any values returned by the predicate action. +findFilePaths :: (MonadIO m, MonadResource m) + => FindOptions + -> FilePath + -> CondT FileEntry m a + -> Producer m FilePath +findFilePaths opts path predicate = + findFilesSource opts path predicate =$= mapC (entryPath . fst) +-- | Calls 'findFilePaths' with the default set of finding options. +-- Equivalent to @findFilePaths defaultFindOptions@. find :: (MonadIO m, MonadResource m) - => FilePath -> Predicate m FileEntry - -> Source m FilePath -find path pr = find' path pr =$= mapC entryPath - -lfind' :: (MonadIO m, MonadResource m) - => FilePath -> Predicate m FileEntry - -> Source m FileEntry -lfind' = basicFind lstat False + => FilePath -> CondT FileEntry m a -> Producer m FilePath +find = findFilePaths defaultFindOptions -lfind :: (MonadIO m, MonadResource m) - => FilePath -> Predicate m FileEntry - -> Source m FilePath -lfind path pr = lfind' path pr =$= mapC entryPath +-- | Test a file path using the same type of predicate that is accepted by +-- 'findFiles'. +test :: MonadIO m => CondT FileEntry m () -> FilePath -> m Bool +test matcher path = + Cond.test matcher (newFileEntry path 0 defaultFindOptions) --- | Test a file path using the same type of 'Predicate' that is accepted by --- 'find'. -test :: MonadIO m => Predicate m FileEntry -> FilePath -> m Bool -test matcher path = Cond.test (stat >> matcher) (newFileEntry path 0) +-- | Test a file path using the same type of predicate that is accepted by +-- 'findFiles', but do not follow symlinks. +ltest :: MonadIO m => CondT FileEntry m () -> FilePath -> m Bool +ltest matcher path = Cond.test matcher + (newFileEntry path 0 defaultFindOptions { findFollowSymlinks = False }) diff --git a/find-conduit.cabal b/find-conduit.cabal --- a/find-conduit.cabal +++ b/find-conduit.cabal @@ -1,5 +1,5 @@ Name: find-conduit -Version: 0.3.0 +Version: 0.4.0 Synopsis: A file-finding conduit that allows user control over traversals. License-file: LICENSE License: MIT @@ -34,6 +34,7 @@ , time , transformers , transformers-base + , mmorph , monad-control exposed-modules: Data.Conduit.Find @@ -63,4 +64,5 @@ , transformers , transformers-base , monad-control + , mmorph , hspec >= 1.4 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -24,13 +24,12 @@ it "finds files" $ do xs <- runResourceT $ find "." - ( ignoreVcs - >> prune (filename_ (== "dist")) - >> glob "*.hs" - >> not_ (glob "Setup*") - >> regular - >> not_ executable - ) + (do ignoreVcs + when_ (name_ "dist") prune + glob "*.hs" + not_ (glob "Setup*") + regular + not_ executable) $$ sinkList "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True @@ -41,15 +40,15 @@ it "finds files with a different ordering" $ do xs <- runResourceT $ find "." - ( ignoreVcs - >> glob "*.hs" - >> not_ (glob "Setup*") - -- This prune only applies to .hs files now, so it won't - -- match anything, thus having no effect but burning CPU! - >> prune (filename_ (== "dist")) - >> regular - >> not_ executable - ) + (do ignoreVcs + glob "*.hs" + not_ (glob "Setup*") + -- This applies only to .hs files now, so it won't + -- match anything, thus having no effect but burning + -- CPU! + when_ (name_ "dist") prune + regular + not_ executable) $$ sinkList "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True @@ -59,15 +58,14 @@ it "finds files using a pre-pass filter" $ do xs <- runResourceT $ - findRaw "." True + find "." (do ignoreVcs - prune (filename_ (== "dist")) + when_ (name_ "dist") prune glob "*.hs" not_ (glob "Setup*") - stat regular not_ executable) - =$ mapC entryPath $$ sinkList + $$ sinkList "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True "./dist/setup-config" `elem` xs `shouldBe` False @@ -76,16 +74,15 @@ it "properly applies post-pass pruning" $ do xs <- runResourceT $ - findRaw "." True + find "." (do ignoreVcs - prune (depth (>=1)) - prune (filename_ (== "dist")) + maxdepth_ 1 + when_ (name_ "dist") prune glob "*.hs" not_ (glob "Setup*") - stat regular not_ executable) - =$ mapC entryPath $$ sinkList + $$ sinkList "./Data/Conduit/Find.hs" `elem` xs `shouldBe` False "./dist/setup-config" `elem` xs `shouldBe` False