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