diff --git a/Data/Cond.hs b/Data/Cond.hs deleted file mode 100644 --- a/Data/Cond.hs +++ /dev/null @@ -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)) diff --git a/Data/Conduit/Find.hs b/Data/Conduit/Find.hs deleted file mode 100644 --- a/Data/Conduit/Find.hs +++ /dev/null @@ -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 diff --git a/conduit-find.cabal b/conduit-find.cabal --- a/conduit-find.cabal +++ b/conduit-find.cabal @@ -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 diff --git a/src/Data/Cond.hs b/src/Data/Cond.hs new file mode 100644 --- /dev/null +++ b/src/Data/Cond.hs @@ -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)) diff --git a/src/Data/Conduit/Find.hs b/src/Data/Conduit/Find.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Find.hs @@ -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 diff --git a/test/doctest.hs b/test/doctest.hs deleted file mode 100644 --- a/test/doctest.hs +++ /dev/null @@ -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 diff --git a/test/find-hs.hs b/test/find-hs.hs --- a/test/find-hs.hs +++ b/test/find-hs.hs @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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