diff options
| -rw-r--r-- | src/Ghci.hs | 22 |
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 |