From dc3d9d1e982f7342dd3e2b3fc14fbbe85e7acd3e Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Mon, 18 Jun 2012 12:53:57 -0400
Subject: added dirTree

---
 Utility/Directory.hs | 29 ++++++++++++++++++++++++++++-
 1 file changed, 28 insertions(+), 1 deletion(-)

(limited to 'Utility/Directory.hs')

diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index 78bb6e701..b8ed63a36 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -34,7 +34,7 @@ dirCruft _ = False
 dirContents :: FilePath -> IO [FilePath]
 dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
 
-{- Gets contents of directory, and then its subdirectories, recursively,
+{- Gets files in a directory, and then its subdirectories, recursively,
  - and lazily. -}
 dirContentsRecursive :: FilePath -> IO [FilePath]
 dirContentsRecursive topdir = dirContentsRecursive' topdir [""]
@@ -56,6 +56,33 @@ dirContentsRecursive' topdir (dir:dirs) = unsafeInterleaveIO $ do
 					, collect (dirEntry:files) dirs' entries
 					)			
 
+{- Gets the subdirectories in a directory, and their subdirectories,
+ - recursively, and lazily. Prunes sections of the tree matching a
+ - condition. -}
+dirTree :: FilePath -> (FilePath -> Bool) -> IO [FilePath]
+dirTree topdir prune
+	| prune topdir = return []
+	| otherwise = (:) topdir <$> dirTree' topdir prune [""]
+
+dirTree' :: FilePath -> (FilePath -> Bool) -> [FilePath] -> IO [FilePath]
+dirTree' _ _ [] = return []
+dirTree' topdir prune (dir:dirs)
+	| prune dir = dirTree' topdir prune dirs
+	| otherwise = unsafeInterleaveIO $ do
+		subdirs <- collect [] =<< dirContents (topdir </> dir)
+		subdirs' <- dirTree' topdir prune (subdirs ++ dirs)
+		return $ subdirs ++ subdirs'
+	where
+		collect dirs' [] = return dirs'
+		collect dirs' (entry:entries)
+			| dirCruft entry || prune entry = collect dirs' entries
+			| otherwise = do
+				let dirEntry = dir </> entry
+				ifM (doesDirectoryExist $ topdir </> dirEntry)
+					( collect (dirEntry:dirs') entries
+					, collect dirs' entries
+					)			
+
 {- Moves one filename to another.
  - First tries a rename, but falls back to moving across devices if needed. -}
 moveFile :: FilePath -> FilePath -> IO ()
-- 
cgit v1.2.3