work around getDirectoryContents not streaming lazily

1 files changed, 44 insertions, 0 deletions

diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index d92327c09..e3706e785 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -18,6 +18,12 @@ import System.FilePath
 import Control.Applicative
 import System.IO.Unsafe (unsafeInterleaveIO)
 
+#ifdef mingw32_HOST_OS
+import qualified System.Win32 as Win32
+#else
+import qualified System.Posix as Posix
+#endif
+
 import Utility.PosixFiles
 import Utility.SafeCommand
 import Utility.Tmp
@@ -25,6 +31,44 @@ import Utility.Exception
 import Utility.Monad
 import Utility.Applicative
 
+{- Unlike getDirectoryContents, this can be used in arbitrarily
+ - large directories without using much memory; the list steams lazily.
+ -
+ - However, any errors that may be encountered while reading the directory
+ - contents are *ignored*, rather than throw them in the context of
+ - whatever code consumes the lazy list.
+ -
+ - See https://ghc.haskell.org/trac/ghc/ticket/9266
+ -}
+getDirectoryContents' :: FilePath -> IO [FilePath]
+getDirectoryContents' path = loop =<< opendir
+  where
+#ifndef mingw32_HOST_OS
+	opendir = Posix.openDirStream path
+	loop dirp = do
+		v <- tryNonAsync $ Posix.readDirStream dirp
+		case v of
+			(Right ent) | not (null ent) -> do
+				rest <- unsafeInterleaveIO (loop dirp)
+				return (ent:rest)
+			_ -> do
+				void $ tryNonAsync $ Posix.closeDirStream dirp
+				return []
+#else
+	opendir = Win32.findFirstFile (path </> "*")
+	loop (h, fdat) = do
+		-- there is always at least 1 file ("." and "..")
+		ent <- Win32.getFindDataFileName fdat
+		v <- tryNonAsync $ Win32.findNextFile h fdat
+		case v of
+			Right True -> 
+				rest <- unsafeInterleaveIO loop (h, fdat)
+				return (ent:rest)
+			_ -> 
+				void $ tryNonAsync $ Win32.findClose h
+				return [ent]
+#endif
+
 dirCruft :: FilePath -> Bool
 dirCruft "." = True
 dirCruft ".." = True