From 7246d871bfbf7c76f9787d056d4faf2bc2f85ac7 Mon Sep 17 00:00:00 2001
From: Kari Pahula <kaol@iki.fi>
Date: Mon, 4 Nov 2024 15:58:53 +0200
Subject: [PATCH] Call abortServer on test timeout.

---
 futhark.cabal           |  1 +
 src/Futhark/CLI/Test.hs | 10 +++++++++-
 2 files changed, 10 insertions(+), 1 deletion(-)

diff --git a/futhark.cabal b/futhark.cabal
index 3a6651e440..48e579c4f4 100644
--- a/futhark.cabal
+++ b/futhark.cabal
@@ -443,6 +443,7 @@ library
       aeson >=2.0.0.0
     , ansi-terminal >=0.6.3.1
     , array >=0.4
+    , async >=2.0
     , base >=4.15 && <5
     , base16-bytestring
     , binary >=0.8.3
diff --git a/src/Futhark/CLI/Test.hs b/src/Futhark/CLI/Test.hs
index 2dd9227df0..c14ab2a5f0 100644
--- a/src/Futhark/CLI/Test.hs
+++ b/src/Futhark/CLI/Test.hs
@@ -5,6 +5,7 @@ module Futhark.CLI.Test (main) where
 
 import Control.Applicative.Lift (Errors, Lift (..), failure, runErrors)
 import Control.Concurrent
+import Control.Concurrent.Async
 import Control.Exception
 import Control.Monad
 import Control.Monad.Except (ExceptT (..), MonadError, runExceptT, withExceptT)
@@ -105,7 +106,14 @@ withProgramServer program runner extra_options f = do
   context prog_ctx $
     pureTestResults $
       liftIO $
-        withServer (futharkServerCfg to_run to_run_args) f
+        withServer (futharkServerCfg to_run to_run_args) $ \server ->
+          race (threadDelay $ 5 * 60 * 1000000) (f server) >>= \case
+            Left _ -> do
+              abortServer server
+              -- This value won't be used since abortServer will
+              -- already cause a non-zero status for wait.
+              pure undefined
+            Right r -> pure r
 
 data TestMode
   = -- | Only type check.