added dirTree

1 files changed, 28 insertions, 1 deletions

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 ()