From 660d8d3a871ef1a9d7568069e35a4f70756250c7 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 5 Jun 2020 14:16:37 -0400
Subject: [PATCH] simpler way to do this

Remove old code that can be trivially implemented using async in a much
nicer way (that is async exception safe).

I've audited all forkOS calls (except for ones in the assistant),
and this was the last remaining one that is not async exception safe.
The rest look ok to me.
---
 Assistant/Sync.hs   |  7 ++++++-
 Utility/Parallel.hs | 34 ----------------------------------
 git-annex.cabal     |  3 +--
 3 files changed, 7 insertions(+), 37 deletions(-)
 delete mode 100644 Utility/Parallel.hs

diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 2b0fae5c97..11f537d567 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -17,7 +17,6 @@ import Assistant.DaemonStatus
 import Assistant.ScanRemotes
 import Assistant.RemoteControl
 import qualified Command.Sync
-import Utility.Parallel
 import qualified Git
 import qualified Git.Command
 import qualified Remote
@@ -43,6 +42,7 @@ import Database.Export
 import Data.Time.Clock
 import qualified Data.Map as M
 import Control.Concurrent
+import Control.Concurrent.Async
 
 {- Syncs with remotes that may have been disconnected for a while.
  - 
@@ -177,6 +177,11 @@ parallelPush g rs a = do
 		<*> (Remote.getRepo r >>= \repo ->
 			sshOptionsTo repo (Remote.gitconfig r) g)
 
+inParallel :: (v -> IO Bool) -> [v] -> IO ([v], [v])
+inParallel a l = (\(t,f) -> (map fst t, map fst f)) 
+	. partition snd 
+	. zip l <$> mapConcurrently a l
+
 {- Displays an alert while running an action that syncs with some remotes,
  - and returns any remotes that it failed to sync with.
  -
diff --git a/Utility/Parallel.hs b/Utility/Parallel.hs
deleted file mode 100644
index 2a778b9958..0000000000
--- a/Utility/Parallel.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{- parallel processing via threads
- -
- - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- - License: BSD-2-clause
- -}
-
-module Utility.Parallel (inParallel) where
-
-import Common
-
-import Control.Concurrent
-
-{- Runs an action in parallel with a set of values, in a set of threads.
- - In order for the actions to truely run in parallel, requires GHC's
- - threaded runtime, 
- -
- - Returns the values partitioned into ones with which the action succeeded,
- - and ones with which it failed. -}
-inParallel :: (v -> IO Bool) -> [v] -> IO ([v], [v])
-inParallel a l = do
-	mvars <- mapM thread l
-	statuses <- mapM takeMVar mvars
-	return $ reduce $ partition snd $ zip l statuses
-  where
-	reduce (x,y) = (map fst x, map fst y)
-	thread v = do
-		mvar <- newEmptyMVar
-		_ <- forkIO $ do
-			r <- try (a v) :: IO (Either SomeException Bool)
-			case r of
-				Left _ -> putMVar mvar False
-				Right b -> putMVar mvar b
-		return mvar
diff --git a/git-annex.cabal b/git-annex.cabal
index 5e6cc74d5f..c056e2a55a 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -298,7 +298,7 @@ custom-setup
     filepath, exceptions, bytestring, directory, IfElse, data-default,
     filepath-bytestring (>= 1.4.2.1.1),
     process (>= 1.6.3),
-    utf8-string, transformers, Cabal
+    async, utf8-string, transformers, Cabal
 
 Executable git-annex
   Main-Is: git-annex.hs
@@ -1085,7 +1085,6 @@ Executable git-annex
     Utility.NotificationBroadcaster
     Utility.OptParse
     Utility.PID
-    Utility.Parallel
     Utility.PartialPrelude
     Utility.Path
     Utility.Path.Max