From 6a445dc086b1680fe36ea35d6e5a8f9dc550c9d4 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 16 Aug 2018 14:28:05 -0400
Subject: [PATCH] support conditionally excluding queued files

Switched code to use a for loop to avoid a filterM that would have
doubled the memory used.

This commit was supported by the NSF-funded DataLad project.
---
 Git/Queue.hs           | 31 +++++++++++++++++++++++--------
 Utility/SafeCommand.hs | 20 +++++++++++---------
 2 files changed, 34 insertions(+), 17 deletions(-)

diff --git a/Git/Queue.hs b/Git/Queue.hs
index 232b4a7c4a..86793bbcc7 100644
--- a/Git/Queue.hs
+++ b/Git/Queue.hs
@@ -11,6 +11,7 @@ module Git.Queue (
 	Queue,
 	new,
 	addCommand,
+	addCommandCond,
 	addUpdateIndex,
 	size,
 	full,
@@ -36,8 +37,11 @@ data Action
 	| CommandAction 
 		{ getSubcommand :: String
 		, getParams :: [CommandParam]
-		, getFiles :: [CommandParam]
-		} 
+		{- The IO action is run when constructing the action, and 
+		 - can return False if the file should not be included
+		 - after all. -}
+		, getFiles :: [(FilePath, IO Bool)]
+		}
 
 {- A key that can uniquely represent an action in a Map. -}
 data ActionKey = UpdateIndexActionKey | CommandActionKey String
@@ -79,13 +83,19 @@ new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty
  - result.
  -}
 addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue
-addCommand subcommand params files q repo =
+addCommand subcommand params files q repo = 
+	addCommandCond subcommand params files' q repo
+  where
+	files' = map (\f -> (f, return True)) files
+
+addCommandCond :: String -> [CommandParam] -> [(FilePath, IO Bool)] -> Queue -> Repo -> IO Queue
+addCommandCond subcommand params files q repo =
 	updateQueue action different (length files) q repo
   where
 	action = CommandAction
 		{ getSubcommand = subcommand
 		, getParams = params
-		, getFiles = map File files
+		, getFiles = files
 		}
 	
 	different (CommandAction { getSubcommand = s }) = s /= subcommand
@@ -157,17 +167,22 @@ runAction repo (UpdateIndexAction streamers) =
 	Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
 runAction repo action@(CommandAction {}) = do
 #ifndef mingw32_HOST_OS
-	let p = (proc "xargs" $ "-0":"git":toCommand gitparams) { env = gitEnv repo }
+	let p = (proc "xargs" $ "-0":"git":toCommand gitparams)
+		{ env = gitEnv repo }
 	withHandle StdinHandle createProcessSuccess p $ \h -> do
-		hPutStr h $ intercalate "\0" $ toCommand $ getFiles action
+		forM_ (getFiles action) $ \(f, check) ->
+			whenM check $ do
+				hPutStr h (toCommand' (File f))
+				hPutStr h "\0"
 		hClose h
 #else
 	-- Using xargs on Windows is problematic, so just run the command
 	-- once per file (not as efficient.)
 	if null (getFiles action)
 		then void $ boolSystemEnv "git" gitparams (gitEnv repo)
-		else forM_ (getFiles action) $ \f ->
-			void $ boolSystemEnv "git" (gitparams ++ [f]) (gitEnv repo)
+		else forM_ (getFiles action) $ \(f, check) ->
+			whenM check $
+				void $ boolSystemEnv "git" (gitparams ++ [File f]) (gitEnv repo)
 #endif
   where
 	gitparams = gitCommandLine
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index eb34d3de7a..f820e69f19 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -27,19 +27,21 @@ data CommandParam
 -- | Used to pass a list of CommandParams to a function that runs
 -- a command and expects Strings. -}
 toCommand :: [CommandParam] -> [String]
-toCommand = map unwrap
+toCommand = map toCommand'
+
+toCommand' :: CommandParam -> String
+toCommand' (Param s) = s
+-- Files that start with a non-alphanumeric that is not a path
+-- separator are modified to avoid the command interpreting them as
+-- options or other special constructs.
+toCommand' (File s@(h:_))
+	| isAlphaNum h || h `elem` pathseps = s
+	| otherwise = "./" ++ s
   where
-	unwrap (Param s) = s
-	-- Files that start with a non-alphanumeric that is not a path
-	-- separator are modified to avoid the command interpreting them as
-	-- options or other special constructs.
-	unwrap (File s@(h:_))
-		| isAlphaNum h || h `elem` pathseps = s
-		| otherwise = "./" ++ s
-	unwrap (File s) = s
 	-- '/' is explicitly included because it's an alternative
 	-- path separator on Windows.
 	pathseps = pathSeparator:"./"
+toCommand' (File s) = s
 
 -- | Run a system command, and returns True or False if it succeeded or failed.
 --