find-conduit 0.2.3 → 0.3.0

raw patch · 5 files changed

+466/−508 lines, 5 filesdep +exceptionsdep +monad-controldep +transformersdep −profunctorsPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, monad-control, transformers, transformers-base

Dependencies removed: profunctors

API changes (from Hackage documentation)

Files

• Data/Cond.hs +300/−0
• Data/Conduit/Find.hs +127/−190
• Data/Conduit/Find/Looped.hs +0/−283
• find-conduit.cabal +10/−3
• test/main.hs +29/−32

@@ -0,0 +1,300 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Cond+    ( Result(..), toResult, fromResult+    , CondT(..), runCondT, Cond, runCond+    , if_, ifM_, apply, test+    , reject, rejectAll, norecurse+    , or_, (||:), and_, (&&:), not_, prune+    , traverseRecursively+    ) where++import Control.Applicative+import Control.Arrow (first)+import Control.Monad+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Trans+import Control.Monad.Trans.Control+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)++-- | 'Result' is an enriched 'Maybe' type which additionally 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)))+-- @+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)++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++instance Monoid b => Monoid (Result a m b) where+    mempty        = KeepAndRecurse mempty Nothing+    x `mappend` y = x <> y++recurse :: Result a m b+recurse = RecurseOnly Nothing++accept :: b -> Result a m b+accept = flip KeepAndRecurse Nothing++toResult :: Monad m => Maybe a -> forall r. Result r m a+toResult Nothing  = recurse+toResult (Just a) = accept a++fromResult :: Monad m => forall r. Result r m a -> Maybe a+fromResult Ignore               = Nothing+fromResult (Keep a)             = Just a+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).+--+--   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@.+--+--   Here is a trivial example:+--+-- @+--   flip runCondT 42 $ do+--     if_ even+--     liftIO $ putStrLn "42 must be even to reach here"+--+--     if_ odd <|> if_ even+--     if_ even &&: if_ (== 42)+--     if_ ((== 0) . (`mod` 6))+-- @+--+--   'CondT' is typically invoked using 'runCondT', in which case it maps 'a'+--   to 'Maybe b'.  It can also be run with 'applyCondT', which does case+--   analysis on the final 'Result' type, specifying how recursion should be+--   performed from the given 'a' value.  This is useful when applying+--   Conduits to structural traversals, and was the motivation behind this+--   type.+newtype CondT a m b = CondT { getCondT :: StateT a m (Result a m b) }++type Cond a = CondT a Identity++instance Monad m => Semigroup (CondT a m b) where+    (<>) = (>>)++instance Monad m => Monoid (CondT a m a) where+    mempty  = ask+    mappend = (<>)++instance Monad m => Functor (CondT a m) where+    fmap f (CondT g) = CondT (liftM (fmap f) g)++instance Monad m => Applicative (CondT a m) where+    pure  = return+    (<*>) = ap++instance Monad m => Monad (CondT a m) where+    return = CondT . return . accept+    fail _ = mzero+    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 $ liftM accept get+    local f (CondT m) = CondT $ withStateT f m+    reader f          = f <$> ask++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)++instance Monad m => MonadPlus (CondT a m) where+    mzero = CondT $ return recurse+    CondT f `mplus` CondT g = CondT $ do+        r <- f+        case r of+            x@(Keep _) -> return x+            x@(KeepAndRecurse _ _) -> return x+            _ -> g++instance MonadThrow m => MonadThrow (CondT a m) where+  throwM = CondT . throwM++instance MonadCatch m => MonadCatch (CondT a m) where+    catch (CondT m) c = CondT $ m `catch` \e -> getCondT (c e)+    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 $ accept `liftM` liftBase m++instance MonadIO m => MonadIO (CondT a m) where+    liftIO m = CondT $ accept `liftM` liftIO m++instance MonadTrans (CondT a) where+    lift m = CondT $ accept `liftM` lift m++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 CondTStM $ runInBase $ runStateT (getCondT k) s+    restoreM = CondT . StateT . const . restoreM . unCondTStM+    {-# INLINE liftBaseWith #-}+    {-# INLINE restoreM #-}++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++runCond :: Cond a b -> a -> Maybe b+runCond = (runIdentity .) . runCondT++if_ :: Monad m => (a -> Bool) -> CondT a m ()+if_ f = ask >>= guard . f++ifM_ :: Monad m => (a -> m Bool) -> CondT a m ()+ifM_ f = ask >>= lift . f >>= guard++apply :: Monad m => (a -> m (Maybe b)) -> CondT a m b+apply f = CondT $ liftM toResult . lift . f =<< get++test :: Monad m => CondT a m b -> a -> m Bool+test = (liftM isJust .) . runCondT++-- | 'reject' rejects the current entry, but allows recursion.  This is the+--   same as 'mzero'.+reject :: Monad m => CondT a m b+reject = mzero++-- | 'rejectAll' rejects the entry and all of its descendents.+rejectAll :: Monad m => CondT a m b+rejectAll = CondT $ return Ignore++-- | '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 ())++or_ :: Monad m => NonEmpty (CondT a m b) -> CondT a m b+or_ = foldr1 mplus++infixr 3 &&:+(||:) :: Monad m => CondT a m b -> CondT a m b -> CondT a m b+(||:) = mplus++and_ :: Monad m => [CondT a m b] -> CondT a m [b]+and_ = foldl' (\acc x -> (:) <$> x <*> acc) (return [])++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 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++-- | '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++-- | 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

@@ -1,5 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}  module Data.Conduit.Find     (@@ -20,11 +21,10 @@     , find'     , lfind     , lfind'-    , findWithPreFilter-    , readPaths     , stat     , lstat     , test+    , findRaw      -- * File path predicates     , ignoreVcs@@ -35,7 +35,6 @@     , filepath_     , filepathS_     , withPath-    , entryPath      -- * File entry predicates (uses stat information)     , regular@@ -44,39 +43,33 @@     , depth     , lastAccessed     , lastModified-    , withStatus+    , withFileStatus      -- * Predicate combinators-    , or_-    , and_-    , not_-    , prune-    , matchAll-    , ignoreAll-    , consider+    , module Cond     , (=~)      -- * Types and type classes     , FileEntry(..)-    , Predicate-    , HasFileInfo(..)     ) where -import Conduit-import Control.Applicative-import Control.Arrow-import Control.Monad-import Data.Attoparsec.Text-import Data.Bits-import Data.Conduit.Find.Looped-import Data.Monoid-import Data.Text (Text, unpack, pack)-import Data.Time-import Data.Time.Clock.POSIX-import Filesystem.Path.CurrentOS (FilePath, encodeString, filename)-import Prelude hiding (FilePath)-import System.Posix.Files-import System.Posix.Types+import           Conduit+import           Control.Applicative+import           Control.Monad+import           Control.Monad.State.Class+import           Data.Attoparsec.Text+import           Data.Bits+import qualified Data.Cond as Cond+import           Data.Cond hiding (test)+import           Data.Maybe (fromMaybe)+import           Data.Monoid+import           Data.Text (Text, unpack, pack)+import           Data.Time+import           Data.Time.Clock.POSIX+import           Filesystem.Path.CurrentOS (FilePath, encodeString, filename)+import           Prelude hiding (FilePath)+import           System.Posix.Files+import           System.Posix.Types import qualified Text.Regex.Posix as R ((=~))  {- $intro@@ -100,7 +93,7 @@ Would in find-conduit be:  @-find "src" (glob "*.hs" \<\> regular) $$ mapM_C (liftIO . print)+find "src" (glob \"*.hs\" \<\> regular) $$ mapM_C (liftIO . print) @  The 'glob' predicate matches the file basename against the globbing pattern,@@ -142,7 +135,7 @@ This is the same as using '-maxdepth 2' in find.  @-find \".\" (prune (filename_ (== "dist")))+find \".\" (prune (filename_ (== \"dist\"))) @  This is the same as:@@ -171,94 +164,54 @@  {- $notes -Predicates form a Category and an Arrow, so you can use Arrow-style-composition rather than Monoids if you wish.  They also form an Applicative, a-Monad and a MonadPlus.--In the Monad, the value bound over is whatever the predicate chooses to return-(most Predicates return the same FilePath they examined, however, making the-Monad less value).  Here's an example Monad: If the find takes longer than 5-minutes, abort.  We could have used 'timeout', but this is for illustration.--@-start <- liftIO getCurrentTime-find \".\" $ do-    glob \"*.hs\"--    end <- liftIO getCurrentTime-    if diffUTCTIme end start > 300-        then ignoreAll-        else matchAll-@--The Predicate Monad is a short-circuiting monad, meaning we stop as soon as it-can be determined that the user is not interested in a given file.  To access-the current file, simply bind the result value from any Predicate.  To change-the file being matched against,for whatever reason, use 'consider'.+See 'Data.Cond' for more details on the Monad used to build predicates. -} -data FileInfo = FileInfo-    { infoPath  :: FilePath-    , infoDepth :: Int-    }--instance Show FileInfo where-    show info = "FileInfo " ++ show (infoPath info)-              ++ " " ++ show (infoDepth info)+type Predicate m a = CondT a m ()  data FileEntry = FileEntry-    { entryInfo   :: FileInfo-    , entryStatus :: FileStatus+    { entryPath   :: FilePath+    , entryDepth  :: Int+    , entryStatus :: Maybe FileStatus+      -- ^ This is Nothing until we determine stat should be called.     }  instance Show FileEntry where-    show entry = "FileEntry " ++ show (entryInfo entry)--class HasFileInfo a where-    getFileInfo :: a -> FileInfo--instance HasFileInfo FileInfo where-    getFileInfo = id-    {-# INLINE getFileInfo #-}--instance HasFileInfo FileEntry where-    getFileInfo = entryInfo-    {-# INLINE getFileInfo #-}+    show entry = "FileEntry "+              ++ show (entryPath entry)+              ++ " " ++ show (entryDepth entry) -entryPath :: HasFileInfo a => a -> FilePath-entryPath = infoPath . getFileInfo+newFileEntry :: FilePath -> Int -> FileEntry+newFileEntry p d = FileEntry p d Nothing  -- | Return all entries, except for those within version-control metadata --   directories (and not including the version control directory itself either).-ignoreVcs :: (MonadIO m, HasFileInfo e) => Predicate m e-ignoreVcs = Looped $ \entry ->-    return $ if filename (entryPath entry) `elem` vcsDirs-             then Ignore-             else KeepAndRecurse entry ignoreVcs+ignoreVcs :: Monad m => Predicate m FileEntry+ignoreVcs = prune (filename_ (`elem` vcsDirs))   where     vcsDirs = [ ".git", "CVS", "RCS", "SCCS", ".svn", ".hg", "_darcs" ] -regex :: (Monad m, HasFileInfo e) => Text -> Predicate m e+regex :: Monad m => Text -> Predicate m FileEntry regex pat = filename_ (=~ pat)  -- | 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: -- -- @---    filename_ (=~ "\\.hs$")+--    filename_ (=~ \"\\\\.hs$\") -- @ -- -- Which is the same thing as: -- -- @---    regex "\\.hs$"+--    regex \"\\\\.hs$\" -- @ (=~) :: FilePath -> Text -> Bool str =~ pat = encodeString str R.=~ unpack pat  -- | Find every entry whose filename part matching the given filename globbing --   expression.  For example: @glob "*.hs"@.-glob :: (Monad m, HasFileInfo e) => Text -> Predicate m e+glob :: Monad m => Text -> Predicate m FileEntry glob g = case parseOnly globParser g of     Left e  -> error $ "Failed to parse glob: " ++ e     Right x -> regex ("^" <> x <> "$")@@ -278,53 +231,62 @@                             then ['\\', x]                             else [x] -doStat :: MonadIO m-       => (String -> IO FileStatus) -> Looped m FileInfo FileEntry-doStat getstatus = Looped $ \(FileInfo p d) -> do-    s <- liftIO $ getstatus (encodeString p)-    let entry = FileEntry (FileInfo p d) s-    return $ if isDirectory s-             then KeepAndRecurse entry (doStat getstatus)-             else Keep entry+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 => Looped m FileInfo FileEntry+lstat :: MonadIO m => Predicate m FileEntry lstat = doStat getSymbolicLinkStatus -stat :: MonadIO m => Looped m FileInfo FileEntry+stat :: MonadIO m => Predicate m FileEntry stat = doStat getFileStatus -withStatus :: Monad m => (FileStatus -> m Bool) -> Predicate m FileEntry-withStatus f = ifM_ (f . entryStatus)+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 = withStatus (return . f)+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 :: HasFileInfo a => Monad m => (FilePath -> m Bool) -> Predicate m a+withPath :: Monad m+         => (FilePath -> m Bool)+         -> Predicate m FileEntry withPath f = ifM_ (f . entryPath) -filename_ :: (Monad m, HasFileInfo e) => (FilePath -> Bool) -> Predicate m e+filename_ :: Monad m => (FilePath -> Bool) -> Predicate m FileEntry filename_ f = withPath (return . f . filename) -filenameS_ :: (Monad m, HasFileInfo e) => (String -> Bool) -> Predicate m e+filenameS_ :: Monad m => (String -> Bool) -> Predicate m FileEntry filenameS_ f = withPath (return . f . encodeString . filename) -filepath_ :: (Monad m, HasFileInfo e) => (FilePath -> Bool) -> Predicate m e+filepath_ :: Monad m => (FilePath -> Bool) -> Predicate m FileEntry filepath_ f = withPath (return . f) -filepathS_ :: (Monad m, HasFileInfo e) => (String -> Bool) -> Predicate m e+filepathS_ :: Monad m => (String -> Bool) -> Predicate m FileEntry filepathS_ f = withPath (return . f . encodeString) -depth :: (Monad m, HasFileInfo e) => (Int -> Bool) -> Predicate m e-depth f = if_ (f . infoDepth . getFileInfo)+depth :: Monad m => (Int -> Bool) -> Predicate m FileEntry+depth f = if_ (f . entryDepth)  withStatusTime :: Monad m                => (UTCTime -> Bool) -> (FileStatus -> POSIXTime)@@ -337,102 +299,77 @@ lastModified :: Monad m => (UTCTime -> Bool) -> Predicate m FileEntry lastModified = flip withStatusTime modificationTimeHiRes --- Walk through the entries of a directory tree, allowing the user to specify--- a 'Predicate' which may decides not only which entries to yield from the--- conduit, but also which directories to follow, and how to recurse into that--- directory by permitting the use of a subsequent 'Predicate'.+-- | 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: ----- Note that the 'followSymlinks' parameter to this function has a different--- meaning than it does for 'sourceDirectoryDeep': if @True@, symlinks are--- never passed to the predicate, only what they point to; if @False@,--- symlinks are never read at all.  For 'sourceDirectoryDeep', if--- 'followSymlinks' is @False@ it only prevents directory symlinks from being--- read.-sourceFileEntries :: MonadResource m-                  => FileInfo-                  -> Looped m FileInfo FileEntry-                  -> Producer m FileEntry-sourceFileEntries (FileInfo p d) m = sourceDirectory p =$= awaitForever f+-- @+-- findRaw \<path\> $ do+--     \<apply predicates needing only pathname or depth\>+--     localM stat $ do+--         directory ||: norecurse+--         \<apply predicates needing stat info\>+-- @+--+-- To apply predicates only to a single directory, without recursing, simply+-- start (or end) the predicate with 'norecurse', and use @localM stat@ or+-- @localM lstat@ at the point where you need 'FileStatus' information.+findRaw :: (MonadIO m, MonadResource m)+        => FilePath -> Bool -> Predicate m FileEntry -> Source m FileEntry+findRaw path follow predicate =+    traverseRecursively+        (newFileEntry path 0)+        predicate+        (const . yield)+        lift+        readDirectory   where-    f fp = applyLooped m (FileInfo fp d) yield $-        sourceFileEntries (FileInfo fp (succ d))+    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) +basicFind :: (MonadIO m, MonadResource m)+          => Predicate m FileEntry+          -> Bool+          -> FilePath+          -> Predicate m FileEntry+          -> Source m FileEntry+basicFind f follow path pr = findRaw path follow $+    f >> (directory ||: norecurse) >> pr+ find' :: (MonadIO m, MonadResource m)-      => FilePath -> Predicate m FileEntry -> Producer m FileEntry-find' path pr = sourceFileEntries (FileInfo path 1) (stat >>> pr)+      => FilePath -> Predicate m FileEntry+      -> Source m FileEntry+find' = basicFind stat True  find :: (MonadIO m, MonadResource m)-     => FilePath -> Predicate m FileEntry -> Producer m FilePath+     => FilePath -> Predicate m FileEntry+     -> Source m FilePath find path pr = find' path pr =$= mapC entryPath  lfind' :: (MonadIO m, MonadResource m)-       => FilePath -> Predicate m FileEntry -> Producer m FileEntry-lfind' path pr = sourceFileEntries (FileInfo path 1) (lstat >>> pr)+       => FilePath -> Predicate m FileEntry+       -> Source m FileEntry+lfind' = basicFind lstat False  lfind :: (MonadIO m, MonadResource m)-      => FilePath -> Predicate m FileEntry -> Producer m FilePath+      => FilePath -> Predicate m FileEntry+      -> Source m FilePath lfind path pr = lfind' path pr =$= mapC entryPath -readPaths :: (MonadIO m, MonadResource m)-          => FilePath -> Predicate m FilePath -> Producer m FilePath-readPaths path pr = sourceDirectory path =$= awaitForever f-  where-    f fp = do-        r <- lift $ runLooped pr fp-        case r of-            Ignore -> return ()-            Keep a -> yield a-            RecurseOnly _ -> return ()-            KeepAndRecurse a _ -> yield a--data FindFilter = IgnoreFile-                | ConsiderFile-                | MaybeRecurse-    deriving (Show, Eq)---- | Run a find, but using a pre-pass filter on the FilePaths, to eliminates---   files from consideration early and avoid calling stat on them.-doFindPreFilter :: (MonadIO m, MonadResource m)-                => FileInfo-                -> Bool-                -> Predicate m FileInfo-                -> Predicate m FileEntry-                -> Producer m FileEntry-doFindPreFilter (FileInfo path dp) follow filt pr =-    sourceDirectory path =$= awaitForever (worker (succ dp) pr)-  where-    worker d m fp = do-        let info = FileInfo fp d-        r <- lift $ runLooped filt info-        let candidate = case r of-                Ignore -> IgnoreFile-                Keep _ -> ConsiderFile-                RecurseOnly _ -> MaybeRecurse-                KeepAndRecurse _ _ -> ConsiderFile-        unless (candidate == IgnoreFile) $ do-            st <- liftIO $-                (if follow-                 then getFileStatus-                 else getSymbolicLinkStatus) (encodeString fp)-            let next = when (isDirectory st) . doFindPreFilter info follow filt-            case candidate of-                IgnoreFile   -> return ()-                MaybeRecurse -> next pr-                ConsiderFile ->-                    applyLooped m (FileEntry (FileInfo fp d) st) yield next--findWithPreFilter :: (MonadIO m, MonadResource m)-                  => FilePath-                  -> Bool-                  -> Predicate m FileInfo-                  -> Predicate m FileEntry-                  -> Producer m FileEntry-findWithPreFilter path = doFindPreFilter (FileInfo path 1)- -- | 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 =-    getAny `liftM` testSingle (stat >>> matcher) (FileInfo path 0) alwaysTrue-  where-    alwaysTrue = const (return (Any True))+test matcher path = Cond.test (stat >> matcher) (newFileEntry path 0)

@@ -1,283 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}---- | Main entry point to the application.-module Data.Conduit.Find.Looped where--import Control.Applicative-import Control.Arrow-import Control.Category-import Control.Monad-import Control.Monad.Trans-import Data.Monoid hiding ((<>))-import Data.Profunctor-import Data.Semigroup-import Prelude hiding ((.), id)--data Result m a b-    = Ignore-    | Keep b-    | RecurseOnly (Looped m a b)-    | KeepAndRecurse b (Looped m a b)--instance Show a => Show (Result r m a) where-    show Ignore = "Ignore"-    show (Keep a) = "Keep " ++ show a-    show (RecurseOnly _) = "RecurseOnly"-    show (KeepAndRecurse a _) = "KeepAndRecurse " ++ show a--instance Functor m => Functor (Result m a) where-    fmap _ Ignore = Ignore-    fmap f (Keep a) = Keep (f a)-    fmap f (RecurseOnly l) = RecurseOnly (fmap f l)-    fmap f (KeepAndRecurse a l)  = KeepAndRecurse (f a) (fmap f l)--instance Functor m => Profunctor (Result m) where-    lmap _ Ignore = Ignore-    lmap _ (Keep a) = Keep a-    lmap f (RecurseOnly l) = RecurseOnly (lmap f l)-    lmap f (KeepAndRecurse a l)  = KeepAndRecurse a (lmap f l)-    rmap = fmap--instance (Functor m, Monad m) => Applicative (Result m a) where-    pure = return-    (<*>) = ap--instance Monad m => Monad (Result m a) where-    return = Keep-    Ignore >>= _ = Ignore-    Keep a >>= f = case f a of-        Ignore -> Ignore-        Keep b -> Keep b-        (RecurseOnly _) -> Ignore-        (KeepAndRecurse b _) -> Keep b-    RecurseOnly (Looped l) >>= f =-        RecurseOnly (Looped $ \r -> liftM (>>= f) (l r))-    KeepAndRecurse a _ >>= f = f a--instance Semigroup (Result m a a) where-    Ignore <> _ = Ignore-    _ <> Ignore = Ignore-    RecurseOnly m <> _ = RecurseOnly m-    _ <> RecurseOnly m = RecurseOnly m-    _ <> Keep b = Keep b-    Keep _ <> KeepAndRecurse b _ = Keep b-    KeepAndRecurse _ _ <> KeepAndRecurse b m = KeepAndRecurse b m--instance Monoid (Result m a a) where-    mempty = Ignore-    x `mappend` y = x <> y--instance Monad m => MonadPlus (Result m a) where-    mzero = Ignore-    Ignore `mplus` _ = Ignore-    _ `mplus` Ignore = Ignore-    RecurseOnly m `mplus` _ = RecurseOnly m-    _ `mplus` RecurseOnly m = RecurseOnly m-    _ `mplus` Keep b = Keep b-    Keep _ `mplus` KeepAndRecurse b _ = Keep b-    KeepAndRecurse _ _ `mplus` KeepAndRecurse b m = KeepAndRecurse b m--newtype Looped m a b = Looped { runLooped :: a -> m (Result m a b) }--instance Functor m => Functor (Looped m a) where-    fmap f (Looped g) = Looped (fmap (fmap (fmap f)) g)--instance Functor m => Profunctor (Looped m) where-    lmap f (Looped k) = Looped (fmap (fmap (lmap f)) (k . f))-    rmap = fmap--instance (Functor m, Monad m) => Applicative (Looped m a) where-    pure = return-    (<*>) = ap--instance Monad m => Monad (Looped m a) where-    return = Looped . const . return . return-    Looped f >>= k = Looped $ \a -> do-        r <- f a-        case r of-            Ignore -> return Ignore-            Keep b -> runLooped (k b) a-            RecurseOnly l -> runLooped (l >>= k) a-            KeepAndRecurse b _ -> runLooped (k b) a--instance Monad m => Category (Looped m) where-    id = matchAll-    Looped f . Looped g = Looped $ \a -> do-          r <- g a-          case r of-            Ignore -> return Ignore-            Keep b -> do-                r' <- f b-                return $ case r' of-                    Ignore -> Ignore-                    Keep c -> Keep c-                    RecurseOnly _ -> Ignore-                    KeepAndRecurse c _ -> Keep c-            RecurseOnly (Looped l) ->-                return $ RecurseOnly (Looped f . Looped l)-            KeepAndRecurse b (Looped l) -> do-                r' <- f b-                return $ case r' of-                    Ignore -> Ignore-                    Keep c -> Keep c-                    RecurseOnly (Looped m) ->-                        RecurseOnly (Looped m . Looped l)-                    KeepAndRecurse c (Looped m) ->-                        KeepAndRecurse c (Looped m . Looped l)--instance Monad m => Arrow (Looped m) where-    arr f = Looped $ return . Keep . f-    first (Looped f) = Looped $ \(a, c) -> do-        r <- f a-        return $ case r of-            Ignore -> Ignore-            Keep b -> Keep (b, c)-            RecurseOnly l -> RecurseOnly (first l)-            KeepAndRecurse b l -> KeepAndRecurse (b, c) (first l)---- | Within a predicate block, 'consider' a different item than what is---   currently being predicated upon.  This makes it possible to write custom---   logic within the Monad instance for a predicate, such as in this---   contrived example:------ @---   flip runLooped \"bar.hs\" $ do---       x <- filename_ (== \"foo.hs\")---       when (x /= \"\") $---           consider \"baz.hs\" $---               filename_ (== \"baz.hs\")--- @-consider :: a -> Looped m a b -> Looped m a b-consider x l = Looped $ const $ runLooped l x--applyLooped :: (MonadTrans t, (Monad (t m)), Monad m, Show b)-            => Looped m a b -> a -> (b -> t m ())-            -> (Looped m a b -> t m ()) -> t m ()-applyLooped l x f g = do-    r <- lift $ runLooped l x-    case r of-        Ignore -> return ()-        Keep a -> f a-        RecurseOnly m -> g m-        KeepAndRecurse a m -> f a >> g m--testSingle :: (Monad m, Monoid c) => Looped m a b -> a -> (b -> m c) -> m c-testSingle l x f = do-    r <- runLooped l x-    case r of-        Ignore -> return mempty-        Keep a -> f a-        RecurseOnly _ -> return mempty-        KeepAndRecurse a _ -> f a--if_ :: Monad m => (a -> Bool) -> Looped m a a-if_ f = Looped $ \a ->-    return $ if f a-             then KeepAndRecurse a (if_ f)-             else RecurseOnly (if_ f)--ifM_ :: Monad m => (a -> m Bool) -> Looped m a a-ifM_ f = Looped $ \a -> do-    r <- f a-    return $ if r-             then KeepAndRecurse a (ifM_ f)-             else RecurseOnly (ifM_ f)--or_ :: MonadIO m => Looped m a b -> Looped m a b -> Looped m a b-or_ (Looped f) (Looped g) = Looped $ \a -> do-    r <- f a-    case r of-        Keep b -> return $ Keep b-        KeepAndRecurse b l -> return $ KeepAndRecurse b l-        _ -> g a--and_ :: MonadIO m => Looped m a b -> Looped m a b -> Looped m a b-and_ (Looped f) (Looped g) = Looped $ \a -> do-    r <- f a-    case r of-        Ignore -> return Ignore-        Keep _ -> g a-        RecurseOnly l -> return $ RecurseOnly l-        KeepAndRecurse _ _ -> g a--liftArrow :: Monad m => (a -> b) -> Looped m a b-liftArrow f = Looped $ \a -> return $ KeepAndRecurse (f a) (liftArrow f)--liftKleisli :: Monad m => (a -> m b) -> Looped m a b-liftKleisli f = Looped $ \a -> do-    r <- f a-    return $ KeepAndRecurse r (liftKleisli f)--liftKleisliMaybe :: Monad m => (a -> m (Maybe b)) -> Looped m a b-liftKleisliMaybe f = Looped $ \a -> do-    r <- f a-    return $ case r of-        Nothing -> RecurseOnly (liftKleisliMaybe f)-        Just b -> KeepAndRecurse b (liftKleisliMaybe f)--lowerKleisliMaybe :: Monad m => Looped m a b -> a -> m (Maybe b)-lowerKleisliMaybe (Looped f) a = do-    r <- f a-    return $ case r of-        Ignore -> Nothing-        Keep b -> Just b-        RecurseOnly _ -> Nothing-        KeepAndRecurse b _ -> Just b--type Predicate m a = Looped m a a--instance (Functor m, Monad m) => Semigroup (Predicate m a) where-    Looped f <> Looped g = Looped $ \a -> do-        r <- f a-        case r of-            Ignore -> g a-            Keep b -> return $ Keep b-            RecurseOnly _ -> g a-            KeepAndRecurse b m -> return $ KeepAndRecurse b m--instance (Functor m, Monad m) => Monoid (Predicate m a) where-    mempty = let x = Looped (\a -> return $ KeepAndRecurse a x) in x-    f `mappend` g = f <> g--instance Monad m => MonadPlus (Looped m a) where-    mzero = ignoreAll-    Looped f `mplus` Looped g = Looped $ \a -> do-        r <- f a-        case r of-            Ignore -> g a-            Keep b -> return $ Keep b-            RecurseOnly _ -> g a-            KeepAndRecurse b m -> return $ KeepAndRecurse b m---- | 'matchAll' is id in the 'Predicate' Category.-matchAll :: Monad m => Predicate m a-matchAll = Looped $ \entry -> return $ KeepAndRecurse entry matchAll---- | 'ignore' rejects the current entry, but allows recursion.-ignore :: Monad m => Looped m a b-ignore = Looped $ const $ return $ RecurseOnly ignore---- | 'ignoreAll' rejects every entry, and does not recurse.  This is the same---   as 'mzero'.-ignoreAll :: Monad m => Looped m a b-ignoreAll = Looped $ const $ return Ignore---- | 'not_' reverse the meaning of the given predicate, preserving recursion.-not_ :: MonadIO m => Predicate m a -> Predicate m a-not_ (Looped f) = Looped (\a -> go a `liftM` f a)-  where-    go a Ignore = Keep a-    go _ (Keep _) = Ignore-    go a (RecurseOnly l) = KeepAndRecurse a (not_ l)-    go _ (KeepAndRecurse _ l) = RecurseOnly (not_ l)---- | 'prune' is much like 'not_', but does not preserve recursion.-prune :: MonadIO m => Predicate m a -> Predicate m a-prune (Looped f) = Looped (\a -> go a `liftM` f a)-  where-    go a Ignore = Keep a-    go _ (Keep _) = Ignore-    go a (RecurseOnly l) = KeepAndRecurse a (prune l)-    go _ (KeepAndRecurse _ _) = Ignore

@@ -1,5 +1,5 @@ Name:                find-conduit-Version:             0.2.3+Version:             0.3.0 Synopsis:            A file-finding conduit that allows user control over traversals. License-file:        LICENSE License:             MIT@@ -28,14 +28,17 @@       , unix                 >= 2.5.1.1       , text                 >= 0.11.3.1       , regex-posix-      , profunctors       , mtl       , semigroups+      , exceptions       , time+      , transformers+      , transformers-base+      , monad-control     exposed-modules:         Data.Conduit.Find     other-modules:-        Data.Conduit.Find.Looped+        Data.Cond  test-suite test     hs-source-dirs: test@@ -56,4 +59,8 @@       , mtl       , time       , semigroups+      , exceptions+      , transformers+      , transformers-base+      , monad-control       , hspec                >= 1.4

@@ -3,7 +3,6 @@ module Main where  import Conduit-import Control.Arrow import Data.Conduit.Find import Test.Hspec @@ -11,7 +10,7 @@ main = hspec $ do     describe "basic tests" $ do         it "file passes a test" $ do-            res <- test (regular >>> not_ executable) "README.md"+            res <- test (regular >> not_ executable) "README.md"             res `shouldBe` True          it "file fails a test" $ do@@ -19,18 +18,18 @@             res `shouldBe` False          it "file fails another test" $ do-            res <- test (regular >>> executable) "README.md"+            res <- test (regular >> executable) "README.md"             res `shouldBe` False          it "finds files" $ do             xs <- runResourceT $                 find "."                     (    ignoreVcs-                     >>> prune (filename_ (== "dist"))-                     >>> glob "*.hs"-                     >>> not_ (glob "Setup*")-                     >>> regular-                     >>> not_ executable+                     >> prune (filename_ (== "dist"))+                     >> glob "*.hs"+                     >> not_ (glob "Setup*")+                     >> regular+                     >> not_ executable                     )                     $$ sinkList @@ -43,13 +42,13 @@             xs <- runResourceT $                 find "."                     (    ignoreVcs-                     >>> glob "*.hs"-                     >>> not_ (glob "Setup*")+                     >> 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+                     >> prune (filename_ (== "dist"))+                     >> regular+                     >> not_ executable                     )                     $$ sinkList @@ -60,15 +59,14 @@          it "finds files using a pre-pass filter" $ do             xs <- runResourceT $-                findWithPreFilter "." True-                    (    ignoreVcs-                     >>> prune (filename_ (== "dist"))-                     >>> glob "*.hs"-                     >>> not_ (glob "Setup*")-                    )-                    (    regular-                     >>> not_ executable-                    )+                findRaw "." True+                    (do ignoreVcs+                        prune (filename_ (== "dist"))+                        glob "*.hs"+                        not_ (glob "Setup*")+                        stat+                        regular+                        not_ executable)                     =$ mapC entryPath $$ sinkList              "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True@@ -78,16 +76,15 @@          it "properly applies post-pass pruning" $ do             xs <- runResourceT $-                findWithPreFilter "." True-                    (    ignoreVcs-                     >>> prune (depth (>=1))-                     >>> prune (filename_ (== "dist"))-                     >>> glob "*.hs"-                     >>> not_ (glob "Setup*")-                    )-                    (    regular-                     >>> not_ executable-                    )+                findRaw "." True+                    (do ignoreVcs+                        prune (depth (>=1))+                        prune (filename_ (== "dist"))+                        glob "*.hs"+                        not_ (glob "Setup*")+                        stat+                        regular+                        not_ executable)                     =$ mapC entryPath $$ sinkList              "./Data/Conduit/Find.hs" `elem` xs `shouldBe` False