diff --git a/Data/Conduit/Find.hs b/Data/Conduit/Find.hs --- a/Data/Conduit/Find.hs +++ b/Data/Conduit/Find.hs @@ -6,19 +6,25 @@ ( FileEntry(..) , Predicate , HasFileInfo(..) + , consider , entryPath , matchAll + , ignoreAll , ignoreVcs - , regexMatcher , regex , glob , stat , lstat - , getPath , regular + , hasMode , executable , filename_ + , filenameS_ + , filepath_ + , filepathS_ , depth + , lastAccessed + , lastModified , withPath , withStatus , prune @@ -43,9 +49,12 @@ 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 Text.Regex.Posix ((=~)) data FileInfo = FileInfo @@ -76,45 +85,9 @@ getFileInfo = entryInfo {-# INLINE getFileInfo #-} -type Predicate m a = Looped m a a - --- | 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'. --- --- 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 - where - f fp = applyPredicate m (FileInfo fp d) yield $ - sourceFileEntries (FileInfo fp (succ d)) - --- | Return all entries. This is the same as 'sourceDirectoryDeep', except --- that the 'FileStatus' structure for each entry is also provided. As a --- result, only one stat call is ever made per entry, compared to two per --- directory in the current version of 'sourceDirectoryDeep'. -matchAll :: Monad m => Predicate m a -matchAll = Looped $ \entry -> return $ KeepAndRecurse entry matchAll - entryPath :: HasFileInfo a => a -> FilePath entryPath = infoPath . getFileInfo -withPath :: HasFileInfo a => Monad m => (FilePath -> m Bool) -> Predicate m a -withPath f = ifM_ (f . entryPath) - -withStatus :: Monad m => (FileStatus -> m Bool) -> Predicate m FileEntry -withStatus f = ifM_ (f . entryStatus) - -- | 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 @@ -125,30 +98,9 @@ where vcsDirs = [ ".git", "CVS", "RCS", "SCCS", ".svn", ".hg", "_darcs" ] --- | The 'regexMatcher' predicate builder matches some part of every path --- against a given regex. Use the simpler 'regex' if you just want to apply --- a regex to every file name. -regexMatcher :: (Monad m, HasFileInfo e) - => (FilePath -> FilePath) - -- ^ Function that specifies which part of the pathname to - -- match against. Use this to match against only filenames, - -- or to relativize the path against the search root before - -- comparing. - -> Text - -- ^ The regular expression search pattern. - -> Predicate m e -regexMatcher accessor (unpack -> pat) = go - where - go = Looped $ \entry -> - return $ if pathStr entry =~ pat - then KeepAndRecurse entry go - else Recurse go - - pathStr = encodeString . accessor . entryPath - -- | Find every entry whose filename part matching the given regular expression. regex :: (Monad m, HasFileInfo e) => Text -> Predicate m e -regex = regexMatcher filename +regex pat = filenameS_ (=~ unpack pat) -- | Find every entry whose filename part matching the given filename globbing -- expression. For example: @glob "*.hs"@. @@ -187,30 +139,98 @@ stat :: MonadIO m => Looped m FileInfo FileEntry stat = doStat getFileStatus -getPath :: MonadIO m => Looped m FileEntry FilePath -getPath = liftLooped (return . entryPath) +withStatus :: Monad m => (FileStatus -> m Bool) -> Predicate m FileEntry +withStatus f = ifM_ (f . entryStatus) status :: Monad m => (FileStatus -> Bool) -> Predicate m FileEntry -status f = if_ (f . entryStatus) +status f = withStatus (return . f) regular :: Monad m => Predicate m FileEntry regular = status isRegularFile +hasMode :: Monad m => FileMode -> Predicate m FileEntry +hasMode m = status (\s -> fileMode s .&. m /= 0) + executable :: Monad m => Predicate m FileEntry -executable = status (\s -> fileMode s .&. ownerExecuteMode /= 0) +executable = hasMode ownerExecuteMode -filename_ :: (Monad m, HasFileInfo e) => FilePath -> Predicate m e -filename_ path = if_ ((== path) . filename . entryPath) +withPath :: HasFileInfo a => Monad m => (FilePath -> m Bool) -> Predicate m a +withPath f = ifM_ (f . entryPath) +filename_ :: (Monad m, HasFileInfo e) => (FilePath -> Bool) -> Predicate m e +filename_ f = withPath (return . f . filename) + +filenameS_ :: (Monad m, HasFileInfo e) => (String -> Bool) -> Predicate m e +filenameS_ f = withPath (return . f . encodeString . filename) + +filepath_ :: (Monad m, HasFileInfo e) => (FilePath -> Bool) -> Predicate m e +filepath_ f = withPath (return . f) + +filepathS_ :: (Monad m, HasFileInfo e) => (String -> Bool) -> Predicate m e +filepathS_ f = withPath (return . f . encodeString) + depth :: (Monad m, HasFileInfo e) => (Int -> Bool) -> Predicate m e depth f = if_ (f . infoDepth . getFileInfo) -test :: MonadIO m => Predicate m FileEntry -> FilePath -> m Bool -test matcher path = - getAny `liftM` testSingle (stat >>> matcher) (FileInfo path 0) alwaysTrue +withStatusTime :: Monad m + => (UTCTime -> Bool) -> (FileStatus -> POSIXTime) + -> Predicate m FileEntry +withStatusTime f g = status (f . posixSecondsToUTCTime . g) + +lastAccessed :: Monad m => (UTCTime -> Bool) -> Predicate m FileEntry +lastAccessed = flip withStatusTime accessTimeHiRes + +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'. +-- +-- 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 where - alwaysTrue = const (return (Any True)) + f fp = applyLooped m (FileInfo fp d) yield $ + sourceFileEntries (FileInfo fp (succ d)) +find' :: (MonadIO m, MonadResource m) + => FilePath -> Predicate m FileEntry -> Producer m FileEntry +find' path pr = sourceFileEntries (FileInfo path 1) (stat >>> pr) + +find :: (MonadIO m, MonadResource m) + => FilePath -> Predicate m FileEntry -> Producer 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) + +lfind :: (MonadIO m, MonadResource m) + => FilePath -> Predicate m FileEntry -> Producer 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 @@ -233,7 +253,7 @@ let candidate = case r of Ignore -> IgnoreFile Keep _ -> ConsiderFile - Recurse _ -> MaybeRecurse + RecurseOnly _ -> MaybeRecurse KeepAndRecurse _ _ -> ConsiderFile unless (candidate == IgnoreFile) $ do st <- liftIO $ @@ -245,7 +265,7 @@ IgnoreFile -> return () MaybeRecurse -> next pr ConsiderFile -> - applyPredicate m (FileEntry (FileInfo fp d) st) yield next + applyLooped m (FileEntry (FileInfo fp d) st) yield next findWithPreFilter :: (MonadIO m, MonadResource m) => FilePath @@ -255,30 +275,10 @@ -> Producer m FileEntry findWithPreFilter path = doFindPreFilter (FileInfo path 1) -find' :: (MonadIO m, MonadResource m) - => FilePath -> Predicate m FileEntry -> Producer m FileEntry -find' path pr = sourceFileEntries (FileInfo path 1) (stat >>> pr) - -find :: (MonadIO m, MonadResource m) - => FilePath -> Predicate m FileEntry -> Producer 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) - -lfind :: (MonadIO m, MonadResource m) - => FilePath -> Predicate m FileEntry -> Producer 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 +-- | 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 - f fp = do - r <- lift $ runLooped pr fp - case r of - Ignore -> return () - Keep a -> yield a - Recurse _ -> return () - KeepAndRecurse a _ -> yield a + alwaysTrue = const (return (Any True)) diff --git a/Data/Conduit/Find/Looped.hs b/Data/Conduit/Find/Looped.hs --- a/Data/Conduit/Find/Looped.hs +++ b/Data/Conduit/Find/Looped.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} -- | Main entry point to the application. module Data.Conduit.Find.Looped where @@ -8,32 +10,33 @@ import Control.Category import Control.Monad import Control.Monad.Trans -import Data.Monoid +import Data.Monoid hiding ((<>)) import Data.Profunctor +import Data.Semigroup import Prelude hiding ((.), id) data Result m a b = Ignore | Keep b - | Recurse (Looped m a 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 (Recurse _) = "Recurse" + 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 (Recurse l) = Recurse (fmap f l) + 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 (Recurse l) = Recurse (lmap f l) + lmap f (RecurseOnly l) = RecurseOnly (lmap f l) lmap f (KeepAndRecurse a l) = KeepAndRecurse a (lmap f l) rmap = fmap @@ -47,12 +50,35 @@ Keep a >>= f = case f a of Ignore -> Ignore Keep b -> Keep b - (Recurse _) -> Ignore + (RecurseOnly _) -> Ignore (KeepAndRecurse b _) -> Keep b - Recurse (Looped l) >>= f = - Recurse (Looped $ \r -> liftM (>>= f) (l r)) + 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 @@ -73,7 +99,7 @@ case r of Ignore -> return Ignore Keep b -> runLooped (k b) a - Recurse l -> runLooped (l >>= k) a + RecurseOnly l -> runLooped (l >>= k) a KeepAndRecurse b _ -> runLooped (k b) a instance Monad m => Category (Looped m) where @@ -87,17 +113,17 @@ return $ case r' of Ignore -> Ignore Keep c -> Keep c - Recurse _ -> Ignore + RecurseOnly _ -> Ignore KeepAndRecurse c _ -> Keep c - Recurse (Looped l) -> - return $ Recurse (Looped f . Looped l) + 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 - Recurse (Looped m) -> - Recurse (Looped m . Looped l) + RecurseOnly (Looped m) -> + RecurseOnly (Looped m . Looped l) KeepAndRecurse c (Looped m) -> KeepAndRecurse c (Looped m . Looped l) @@ -108,33 +134,33 @@ return $ case r of Ignore -> Ignore Keep b -> Keep (b, c) - Recurse l -> Recurse (first l) + RecurseOnly l -> RecurseOnly (first l) KeepAndRecurse b l -> KeepAndRecurse (b, c) (first l) -evens :: Monad m => Looped m Int Int -evens = Looped $ \x -> - return $ if even x - then KeepAndRecurse x evens - else Recurse evens - -tens :: Monad m => Looped m Int Int -tens = Looped $ \x -> - return $ if x `mod` 10 == 0 - then KeepAndRecurse x tens - else Ignore - -apply :: Looped m a b -> a -> Looped m a b -apply l x = Looped $ const $ runLooped l x +-- | 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 Looped, such as in this contrived +-- example: +-- +-- @ +-- flip runLooped "bar.hs" $ do +-- x <- filename_ (== "foo.hs") +-- when (x /= "") $ +-- consider "baz.hs" $ +-- filename_ (== "baz.hs") -- passes +-- @ +consider :: a -> Looped m a b -> Looped m a b +consider x l = Looped $ const $ runLooped l x -applyPredicate :: (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 () -applyPredicate l x f g = do +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 - Recurse m -> g m + 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 @@ -143,26 +169,21 @@ case r of Ignore -> return mempty Keep a -> f a - Recurse _ -> return mempty + RecurseOnly _ -> return mempty KeepAndRecurse a _ -> f a -liftLooped :: Monad m => (a -> m b) -> Looped m a b -liftLooped f = Looped $ \a -> do - r <- f a - return $ KeepAndRecurse r (liftLooped f) - if_ :: Monad m => (a -> Bool) -> Looped m a a if_ f = Looped $ \a -> return $ if f a then KeepAndRecurse a (if_ f) - else Recurse (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 Recurse (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 @@ -178,37 +199,78 @@ case r of Ignore -> return Ignore Keep _ -> g a - Recurse l -> return $ Recurse l + RecurseOnly l -> return $ RecurseOnly l KeepAndRecurse _ _ -> g a -not_ :: MonadIO m => Looped m a a -> Looped m a a -not_ (Looped f) = Looped (\a -> go a `liftM` f a) - where - go a Ignore = Keep a - go _ (Keep _) = Ignore - go a (Recurse l) = KeepAndRecurse a (not_ l) - go _ (KeepAndRecurse _ l) = Recurse (not_ l) +liftArrow :: Monad m => (a -> b) -> Looped m a b +liftArrow f = Looped $ \a -> return $ KeepAndRecurse (f a) (liftArrow f) -prune :: MonadIO m => Looped m a a -> Looped m a a -prune (Looped f) = Looped (\a -> go a `liftM` f a) - where - go a Ignore = Keep a - go _ (Keep _) = Ignore - go a (Recurse l) = KeepAndRecurse a (prune l) - go _ (KeepAndRecurse _ _) = Ignore +liftKleisli :: Monad m => (a -> m b) -> Looped m a b +liftKleisli f = Looped $ \a -> do + r <- f a + return $ KeepAndRecurse r (liftKleisli f) -promote :: Monad m => (a -> m (Maybe b)) -> Looped m a b -promote f = Looped $ \a -> do +liftKleisliMaybe :: Monad m => (a -> m (Maybe b)) -> Looped m a b +liftKleisliMaybe f = Looped $ \a -> do r <- f a return $ case r of - Nothing -> Recurse (promote f) - Just b -> KeepAndRecurse b (promote f) + Nothing -> RecurseOnly (liftKleisliMaybe f) + Just b -> KeepAndRecurse b (liftKleisliMaybe f) -demote :: Monad m => Looped m a b -> a -> m (Maybe b) -demote (Looped f) a = do +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 - Recurse _ -> Nothing + 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 = Looped $ const $ return Ignore + 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 :: Monad m => Predicate m a +matchAll = Looped $ \entry -> return $ KeepAndRecurse entry matchAll + +ignoreAll :: Monad m => Looped m a b +ignoreAll = Looped $ const $ return $ RecurseOnly ignoreAll + +-- | '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 diff --git a/find-conduit.cabal b/find-conduit.cabal --- a/find-conduit.cabal +++ b/find-conduit.cabal @@ -1,5 +1,5 @@ Name: find-conduit -Version: 0.2.1 +Version: 0.2.2 Synopsis: A file-finding conduit that allows user control over traversals. License-file: LICENSE License: MIT @@ -29,6 +29,8 @@ , regex-posix , profunctors , mtl + , semigroups + , time exposed-modules: Data.Conduit.Find other-modules: @@ -51,4 +53,6 @@ , text >= 0.11.3.1 , regex-posix , mtl + , time + , semigroups , hspec >= 1.4 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -26,7 +26,7 @@ xs <- runResourceT $ find "." ( ignoreVcs - >>> prune (filename_ "dist") + >>> prune (filename_ (== "dist")) >>> glob "*.hs" >>> not_ (glob "Setup*") >>> regular @@ -47,7 +47,7 @@ >>> 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") + >>> prune (filename_ (== "dist")) >>> regular >>> not_ executable ) @@ -62,7 +62,7 @@ xs <- runResourceT $ findWithPreFilter "." True ( ignoreVcs - >>> prune (filename_ "dist") + >>> prune (filename_ (== "dist")) >>> glob "*.hs" >>> not_ (glob "Setup*") ) @@ -81,7 +81,7 @@ findWithPreFilter "." True ( ignoreVcs >>> prune (depth (>=1)) - >>> prune (filename_ "dist") + >>> prune (filename_ (== "dist")) >>> glob "*.hs" >>> not_ (glob "Setup*") )