From d3b7c6705c87a06d133b10dfff63d8b772695866 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 16 Mar 2022 12:37:09 -0400
Subject: [PATCH] clean up concurrent output of tests

Using concurrent-output this is easy. Just have to check if tasty has
color enabled, and propagate it into the worker processes, some of which
will be run without a controlling console.

Also added a call to installSignalHandlers; I noticed that interrupting
the test suite could leave the console in a bad state and this fixes
that.

The ansi-terminal dependency is free, since tasty also depends on it.

Sponsored-by: Dartmouth College's Datalad project
---
 Test/Framework.hs | 18 +++++++++++++-----
 debian/control    |  1 +
 git-annex.cabal   |  1 +
 3 files changed, 15 insertions(+), 5 deletions(-)

diff --git a/Test/Framework.hs b/Test/Framework.hs
index 30c15537ec..7f16f1833c 100644
--- a/Test/Framework.hs
+++ b/Test/Framework.hs
@@ -15,10 +15,13 @@ import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
 import Test.Tasty.Options
 import Test.Tasty.Ingredients.Rerun
+import Test.Tasty.Ingredients.ConsoleReporter
 import Options.Applicative.Types
 import Control.Concurrent
 import Control.Concurrent.Async
 import System.Environment (getArgs)
+import System.Console.Concurrent
+import System.Console.ANSI
 
 import Common
 import Types.Test
@@ -495,7 +498,7 @@ setTestMode testmode = do
 		, ("GIT_ANNEX_USE_GIT_SSH", "1")
 		, ("TESTMODE", show testmode)
 		]
-
+				
 runFakeSsh :: [String] -> IO ()
 runFakeSsh ("-n":ps) = runFakeSsh ps
 runFakeSsh (_host:cmd:[]) =
@@ -698,17 +701,21 @@ parallelTestRunner opts mkts
 			hPutStrLn stderr "warnings from tasty:"
 			mapM_ (hPutStrLn stderr) warnings
 		environ <- Utility.Env.getEnvironment
-		ps <- getArgs
+		args <- getArgs
 		pp <- Annex.Path.programPath
-		exitcodes <- forConcurrently [1..length ts] $ \n -> do
+		termcolor <- hSupportsANSIColor stdout
+		let ps = if useColor (lookupOption (tastyOptionSet opts)) termcolor
+			then "--color=always":args
+			else "--color=never":args
+		exitcodes <- withConcurrentOutput $ forConcurrently [1..length ts] $ \n -> do
 			let subdir = tmpdir </> show n
 			ensuredir subdir
 			let p = (proc pp ps)
 				{ env = Just ((subenv, show (n, crippledfilesystem, adjustedbranchok)):environ)
 				, cwd = Just subdir
 				}
-			withCreateProcess p $
-				\_ _ _ pid -> waitForProcess pid
+			(_, _, _, pid) <- createProcessConcurrent p
+			waitForProcess pid
 		unless (keepFailuresOption opts) finalCleanup
 		if all (== ExitSuccess) exitcodes
 			then exitSuccess
@@ -732,6 +739,7 @@ parallelTestRunner opts mkts
 					]
 				, ts !! (n - 1)
 				]
+			installSignalHandlers
 			case tryIngredients ingredients (tastyOptionSet opts) t of
 				Nothing -> error "No tests found!?"
 				Just act -> ifM act
diff --git a/debian/control b/debian/control
index f999940249..34c0f16e4a 100644
--- a/debian/control
+++ b/debian/control
@@ -70,6 +70,7 @@ Build-Depends:
 	libghc-tasty-hunit-dev,
 	libghc-tasty-quickcheck-dev,
 	libghc-tasty-rerun-dev,
+	libghc-ansi-terminal-dev,
 	libghc-optparse-applicative-dev (>= 0.11.0),
 	libghc-torrent-dev,
 	libghc-concurrent-output-dev,
diff --git a/git-annex.cabal b/git-annex.cabal
index 85a85175fa..f18af00ba1 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -378,6 +378,7 @@ Executable git-annex
    tasty-hunit,
    tasty-quickcheck,
    tasty-rerun,
+   ansi-terminal >= 0.9,
    aws (>= 0.20),
    DAV (>= 1.0)
   CC-Options: -Wall
-- 
2.30.2