From fe2fe0d7af3569411420ba875757b71784a1e6d1 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Tue, 14 Jun 2022 19:33:08 +0200
Subject: Timeout

---
 src/Ghci.hs | 22 ++++++++++++++++++----
 1 file changed, 18 insertions(+), 4 deletions(-)

(limited to 'src')

diff --git a/src/Ghci.hs b/src/Ghci.hs
index 649403f..47777f2 100644
--- a/src/Ghci.hs
+++ b/src/Ghci.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE ViewPatterns #-}
 module Ghci (
   Ghci,
@@ -21,10 +22,11 @@ import Data.ByteString.Short (ShortByteString)
 import qualified Data.ByteString.Short as BSS
 import Data.Char (isSpace, toLower)
 import Data.List (nub)
-import Foreign
-import System.IO
+import Foreign (allocaBytes)
+import System.IO (hFlush, hIsClosed, hGetBufSome, hPutStrLn, Handle)
 import System.Process
-import System.Random hiding (next)
+import System.Random (getStdRandom, uniformR)
+import System.Timeout (timeout)
 
 import ExitEarly
 
@@ -75,7 +77,19 @@ runStmtClever ghci line =
     long `startsWith` short = take (length short) long == short
 
 runStmt :: Ghci -> String -> IO (Ghci, Result String)
-runStmt ghci line = restarting 1 (\g -> runStmt' g line) ghci
+runStmt ghci line = timeouting 2_000_000 (restarting 1 (\g -> runStmt' g line)) ghci
+
+timeouting :: Int -> (Ghci -> IO (Ghci, Result a)) -> Ghci -> IO (Ghci, Result a)
+timeouting microseconds f ghci =
+  -- TODO: The timeout handling code never actually runs, because the timeout
+  -- exception is already handled by the catch-all exception handler in
+  -- 'restarting'.
+  timeout microseconds (f ghci) >>= \case
+    Nothing -> do putStrLn "ghci: restarting due to timeout"
+                  terminateGhci ghci
+                  ghci' <- makeGhci
+                  return (ghci', Error "<timeout>")
+    Just pair -> return pair
 
 restarting :: Int -> (Ghci -> IO a) -> Ghci -> IO (Ghci, Result a)
 restarting numExcRestarts f ghci = do
-- 
cgit v1.2.3-70-g09d2