aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Ghci.hs22
1 files changed, 18 insertions, 4 deletions
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