aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Ghci.hs26
1 files changed, 19 insertions, 7 deletions
diff --git a/src/Ghci.hs b/src/Ghci.hs
index 7567133..97943db 100644
--- a/src/Ghci.hs
+++ b/src/Ghci.hs
@@ -26,7 +26,7 @@ import Foreign (allocaBytes)
import System.IO (hFlush, hIsClosed, hGetBufSome, hPutStrLn, stdout, stderr, Handle)
import System.Process
import System.Random (getStdRandom, uniformR)
-import System.Timeout (timeout)
+import System.Timeout (timeout, Timeout)
import ExitEarly
@@ -87,7 +87,7 @@ runStmtClever ghci line =
long `startsWith` short = take (length short) long == short
runStmt :: Ghci -> String -> IO (Ghci, Result String)
-runStmt ghci line = timeouting 2_000_000 (restarting 1 (\g -> runStmt' g line)) ghci
+runStmt ghci line = timeouting 2_000_000 (restarting (\g -> runStmt' g line)) ghci
timeouting :: Int -> (Ghci -> IO (Ghci, Result a)) -> Ghci -> IO (Ghci, Result a)
timeouting microseconds f ghci =
@@ -102,8 +102,8 @@ timeouting microseconds f ghci =
return (ghci', Error "<timeout>")
Just pair -> return pair
-restarting :: Int -> (Ghci -> IO a) -> Ghci -> IO (Ghci, Result a)
-restarting numExcRestarts f ghci = do
+restarting :: (Ghci -> IO a) -> Ghci -> IO (Ghci, Result a)
+restarting f ghci = do
closed <- hIsClosed (ghciStdin ghci)
ghci' <- if closed
then do
@@ -114,14 +114,26 @@ restarting numExcRestarts f ghci = do
else return ghci
fmap (\x -> (ghci', Return x)) (f ghci')
+ `catch` (\e -> do let _ = e :: Timeout
+ putStrLn "ghci: restarting due to timeout (caught in restarting)"
+ hFlush stdout
+ terminateGhci ghci
+ -- putStrLn $ "ghci: terminated"
+ -- hFlush stdout
+ ghci'' <- makeGhci
+ -- putStrLn $ "ghci: new made"
+ -- hFlush stdout
+ return (ghci'', Error "<timeout>"))
`catch` (\e -> do let _ = e :: SomeException
putStrLn $ "ghci: restarting due to exception: " ++ show e
hFlush stdout
terminateGhci ghci'
+ -- putStrLn $ "ghci: terminated"
+ -- hFlush stdout
ghci'' <- makeGhci
- if numExcRestarts >= 1
- then restarting (numExcRestarts - 1) f ghci''
- else return (ghci'', Error "Oops, something went wrong"))
+ -- putStrLn $ "ghci: new made"
+ -- hFlush stdout
+ return (ghci'', Error "Oops, something went wrong"))
terminateGhci :: Ghci -> IO ()
terminateGhci ghci = terminateProcess (ghciProc ghci)