find-conduit 0.0.1 → 0.1.0

raw patch · 4 files changed

+461/−51 lines, 4 filesdep +find-conduitdep +hspecdep +mtldep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: find-conduit, hspec, mtl, profunctors

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Data/Conduit/Find.hs +171/−50
• Data/Conduit/Find/Looped.hs +191/−0
• find-conduit.cabal +24/−1
• test/main.hs +75/−0

@@ -1,30 +1,48 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-}  module Data.Conduit.Find     ( FileEntry(..)-    , Predicate(..)+    , Predicate+    , HasFilePath(..)     , sourceFileEntries     , matchAll     , ignoreVcs     , regexMatcher     , regex     , glob+    , stat+    , lstat+    , getPath+    , regular+    , executable+    , prune+    , test+    , find+    , find'+    , lfind+    , lfind'+    , findWithPreFilter+    , readPaths+    , or_+    , and_+    , not_     ) where  import Conduit import Control.Applicative-import Control.Monad (when)+import Control.Arrow+import Control.Monad import Data.Attoparsec.Text+import Data.Bits+import Data.Conduit.Find.Looped import Data.Foldable (for_)-import Data.Monoid ((<>), mconcat)+import Data.Monoid import Data.Text (Text, unpack, pack) import Filesystem.Path.CurrentOS (FilePath, encodeString, filename) import Prelude hiding (FilePath)-import System.Posix.Files (FileStatus, getFileStatus, getSymbolicLinkStatus,-                           isDirectory)+import System.Posix.Files import Text.Regex.Posix ((=~))  data FileEntry = FileEntry@@ -32,9 +50,20 @@     , entryStatus :: FileStatus     } -newtype Predicate m =-    Predicate (FileEntry -> m (Maybe FileEntry, Maybe (Predicate m)))+instance Show FileEntry where+    show entry = "FileEntry " ++ show (entryPath entry) +class HasFilePath a where+    getFilePath :: a -> FilePath++instance HasFilePath FilePath where+    getFilePath = id++instance HasFilePath FileEntry where+    getFilePath = entryPath++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@@ -48,74 +77,60 @@ --   'followSymlinks' is @False@ it only prevents directory symlinks from --   being read. sourceFileEntries :: MonadResource m-                  => Bool -> Predicate m -> FilePath -> Producer m FileEntry-sourceFileEntries followSymlinks (Predicate matcher) dir =-    sourceDirectory dir =$= go+                  => Looped m FilePath FileEntry+                  -> FilePath+                  -> Producer m FileEntry+sourceFileEntries matcher dir = sourceDirectory dir =$= go matcher   where-    go = do+    go m = do         mfp <- await         for_ mfp $ \fp -> do-            stat <- liftIO $-                (if followSymlinks-                 then getFileStatus-                 else getSymbolicLinkStatus)-                (encodeString fp)-            let entry = FileEntry fp stat-            res <- lift $ matcher entry-            for_ (fst res) yield-            when (isDirectory stat) $-                for_ (snd res) $-                    flip (sourceFileEntries followSymlinks) fp-            go+            applyPredicate m fp yield (`sourceFileEntries` fp)+            go m  -- | 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-matchAll = Predicate $ \entry -> return (Just entry, Just matchAll)+matchAll :: Monad m => Predicate m a+matchAll = Looped $ \entry -> return $ KeepAndRecurse entry matchAll  -- | Return all entries, except for those within version-control metadata --   directories (and not including the version control directory itself either).-ignoreVcs :: MonadIO m => Predicate m-ignoreVcs = Predicate $ \entry ->-    return $ if filename (entryPath entry) `elem` vcsDirs-             then (Nothing, Nothing)-             else (Just entry, Just ignoreVcs)+ignoreVcs :: (MonadIO m, HasFilePath e) => Predicate m e+ignoreVcs = Looped $ \entry ->+    return $ if filename (getFilePath entry) `elem` vcsDirs+             then Ignore+             else KeepAndRecurse entry ignoreVcs   where-    vcsDirs = [ ".git", "CVS", "RCS", "SCCS", ".svn", ".hg" ]+    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+regexMatcher :: (Monad m, HasFilePath 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.-             -> Bool-                -- ^ If True, prune directories from the search that do not-                --   match.              -> Text                 -- ^ The regular expression search pattern.-             -> Predicate m-regexMatcher accessor pruneNonMatching (unpack -> pat) = go+             -> Predicate m e+regexMatcher accessor (unpack -> pat) = go   where-    go = Predicate $ \entry ->-        return $ if encodeString (accessor (entryPath entry)) =~ pat-                 then (Just entry, Just go)-                 else (Nothing, if pruneNonMatching-                                then Nothing-                                else Just go)+    go = Looped $ \entry ->+        return $ if encodeString (accessor (getFilePath entry)) =~ pat+                 then KeepAndRecurse entry go+                 else Recurse go  -- | Find every entry whose filename part matching the given regular expression.-regex :: Monad m => Text -> Predicate m-regex = regexMatcher filename False+regex :: (Monad m, HasFilePath e) => Text -> Predicate m e+regex = regexMatcher filename  -- | Find every entry whose filename part matching the given filename globbing --   expression.  For example: @glob "*.hs"@.-glob :: Monad m => Text -> Predicate m+glob :: (Monad m, HasFilePath e) => Text -> Predicate m e glob g = case parseOnly globParser g of     Left e  -> error $ "Failed to parse glob: " ++ e     Right x -> regex ("^" <> x <> "$")@@ -124,14 +139,120 @@     globParser = fmap mconcat $ many $             char '*' *> return ".*"         <|> char '?' *> return "."+        <|> string "[]]" *> return "[]]"         <|> (\x y z -> pack ((x:y) ++ [z]))                 <$> char '['-                -- jww (2014-04-23): This does not yet handle the pattern []],-                -- which is legal.                 <*> manyTill anyChar (try (char ']'))                 <*> char ']'         <|> do             x <- anyChar-            return . pack $ if x `elem` ['.', '(', ')', '^', '$']+            return . pack $ if x `elem` ".()^$"                             then ['\\', x]                             else [x]++doStat :: MonadIO m+       => (String -> IO FileStatus) -> Looped m FilePath FileEntry+doStat getstatus = Looped $ \path -> do+    s <- liftIO $ getstatus (encodeString path)+    let entry = FileEntry path s+    return $ if isDirectory s+             then KeepAndRecurse entry (doStat getstatus)+             else Keep entry++lstat :: MonadIO m => Looped m FilePath FileEntry+lstat = doStat getSymbolicLinkStatus++stat :: MonadIO m => Looped m FilePath FileEntry+stat = doStat getFileStatus++getPath :: MonadIO m => Looped m FileEntry FilePath+getPath = liftLooped (return . entryPath)++status :: Monad m => (FileStatus -> Bool) -> Predicate m FileEntry+status f = if_ (f . entryStatus)++regular :: Monad m => Predicate m FileEntry+regular = status isRegularFile++executable :: Monad m => Predicate m FileEntry+executable = status (\s -> fileMode s .&. ownerExecuteMode /= 0)++prune :: (Monad m, HasFilePath e) => FilePath -> Predicate m e+prune path = Looped $ \entry ->+    return $ if getFilePath entry == path+             then Ignore+             else KeepAndRecurse entry (prune path)++test :: MonadIO m => Predicate m FileEntry -> FilePath -> m Bool+test matcher path =+    getAny `liftM` testSingle (stat >>> matcher) path alwaysTrue+  where+    alwaysTrue = const (return (Any True))++find :: (MonadIO m, MonadResource m)+     => FilePath -> Predicate m FileEntry -> Producer m FilePath+find path pr = sourceFileEntries (stat >>> pr) path =$= mapC entryPath++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.+findWithPreFilter :: (MonadIO m, MonadResource m)+                  => FilePath+                  -> Bool+                  -> Predicate m FilePath+                  -> Predicate m FileEntry+                  -> Producer m FileEntry+findWithPreFilter path follow filt pr =+    sourceDirectory path =$= go pr+  where+    go m = do+        mfp <- await+        for_ mfp $ \fp -> do+            r <- lift $ runLooped filt fp+            let candidate = case r of+                    Ignore -> IgnoreFile+                    Keep _ -> ConsiderFile+                    Recurse _ -> MaybeRecurse+                    KeepAndRecurse _ _ -> ConsiderFile+            unless (candidate == IgnoreFile) $ do+                st <- liftIO $+                    (if follow+                     then getFileStatus+                     else getSymbolicLinkStatus) (encodeString fp)+                let next = when (isDirectory st) .+                               findWithPreFilter fp follow filt+                case candidate of+                    IgnoreFile -> return ()+                    MaybeRecurse -> next pr+                    ConsiderFile ->+                        applyPredicate m (FileEntry fp st) yield next+            go m++find' :: (MonadIO m, MonadResource m)+      => FilePath -> Predicate m FileEntry -> Producer m FileEntry+find' path pr = sourceFileEntries (stat >>> pr) path++lfind :: (MonadIO m, MonadResource m)+      => FilePath -> Predicate m FileEntry -> Producer m FilePath+lfind path pr = sourceFileEntries (lstat >>> pr) path =$= mapC entryPath++lfind' :: (MonadIO m, MonadResource m)+       => FilePath -> Predicate m FileEntry -> Producer m FileEntry+lfind' path pr = sourceFileEntries (lstat >>> pr) path++readPaths :: (MonadIO m, MonadResource m)+          => FilePath -> Predicate m FilePath -> Producer m FilePath+readPaths path pr = sourceDirectory path =$= do+    mfp <- await+    for_ mfp $ \fp -> do+        r <- lift $ runLooped pr fp+        case r of+            Ignore -> return ()+            Keep a -> yield a+            Recurse _ -> return ()+            KeepAndRecurse a _ -> yield a

@@ -0,0 +1,191 @@+{-# LANGUAGE TupleSections #-}++-- | 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+import Data.Profunctor+import Prelude hiding ((.), id)++data Result m a b+    = Ignore+    | Keep b+    | Recurse (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 (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 (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 (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+        (Recurse _) -> Ignore+        (KeepAndRecurse b _) -> Keep b+    Recurse (Looped l) >>= f =+        Recurse (Looped $ \r -> liftM (>>= f) (l r))+    KeepAndRecurse a _ >>= f = f a++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+            Recurse l -> runLooped (l >>= k) a+            KeepAndRecurse b _ -> runLooped (k b) a++instance Monad m => Category (Looped m) where+    id = let x = Looped $ \a -> return $ KeepAndRecurse a x in x+    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+                    Recurse _ -> Ignore+                    KeepAndRecurse c _ -> Keep c+            Recurse (Looped l) ->+                return $ Recurse (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)+                    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)+            Recurse l -> Recurse (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++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+    r <- lift $ runLooped l x+    case r of+        Ignore -> return ()+        Keep a -> f a+        Recurse 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+        Recurse _ -> 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)++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+        Recurse l -> return $ Recurse 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)++pruneIgnored :: MonadIO m => Looped m a a -> Looped m a a+pruneIgnored (Looped f) = Looped (\a -> go a `liftM` f a)+  where+    go _ Ignore = Ignore+    go _ x@(Keep _) = x+    go _ (Recurse _) = Ignore+    go _ (KeepAndRecurse b m) = KeepAndRecurse b (pruneIgnored m)

@@ -1,5 +1,5 @@ Name:                find-conduit-Version:             0.0.1+Version:             0.1.0 Synopsis:            A file-finding conduit that allows user control over traversals. License-file:        LICENSE License:             MIT@@ -27,5 +27,28 @@       , unix                 >= 2.5.1.1       , text                 >= 0.11.3.1       , regex-posix+      , profunctors+      , mtl     exposed-modules:         Data.Conduit.Find+    other-modules:+        Data.Conduit.Find.Looped++test-suite test+    hs-source-dirs: test+    default-language: Haskell2010+    main-is: main.hs+    type: exitcode-stdio-1.0+    ghc-options: -Wall -threaded+    build-depends:+        base+      , find-conduit+      , conduit+      , conduit-combinators+      , attoparsec+      , system-filepath+      , unix                 >= 2.5.1.1+      , text                 >= 0.11.3.1+      , regex-posix+      , mtl+      , hspec                >= 1.4

@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Conduit+import Control.Arrow+import Data.Conduit.Find+import Test.Hspec++main :: IO ()+main = hspec $ do+    describe "basic tests" $ do+        it "file passes a test" $ do+            res <- test (regular >>> not_ executable) "README.md"+            res `shouldBe` True++        it "file fails a test" $ do+            res <- test (not_ regular) "README.md"+            res `shouldBe` False++        it "file fails another test" $ do+            res <- test (regular >>> executable) "README.md"+            res `shouldBe` False++        it "finds files" $ do+            xs <- runResourceT $+                find "."+                    (    ignoreVcs+                     >>> prune "./dist"+                     >>> glob "*.hs"+                     >>> not_ (glob "Setup*")+                     >>> regular+                     >>> not_ executable+                    )+                    $$ sinkList++            "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True+            "./dist/setup-config" `elem` xs `shouldBe` False+            "./Setup.hs" `elem` xs `shouldBe` False+            "./.git/config" `elem` xs `shouldBe` False++        it "finds files with a different ordering" $ do+            xs <- runResourceT $+                find "."+                    (    ignoreVcs+                     >>> glob "*.hs"+                     >>> not_ (glob "Setup*")+                     >>> prune "./dist"+                     >>> regular+                     >>> not_ executable+                    )+                    $$ sinkList++            "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True+            "./dist/setup-config" `elem` xs `shouldBe` False+            "./Setup.hs" `elem` xs `shouldBe` False+            "./.git/config" `elem` xs `shouldBe` False++        it "finds files using a pre-pass filter" $ do+            xs <- runResourceT $+                findWithPreFilter "." True+                    (    ignoreVcs+                     >>> glob "*.hs"+                     >>> not_ (glob "Setup*")+                     >>> prune "./dist"+                    )+                    (    regular+                     >>> not_ executable+                    )+                    =$ mapC getFilePath $$ sinkList++            "./Data/Conduit/Find.hs" `elem` xs `shouldBe` True+            "./dist/setup-config" `elem` xs `shouldBe` False+            "./Setup.hs" `elem` xs `shouldBe` False+            "./.git/config" `elem` xs `shouldBe` False