[Git][ghc/ghc][wip/T24040-ghci-timeout-squashed] Adds timeout command to ghci. Resolves #24040

Hassan Al-Awwadi (@hassan.awwadi) gitlab at gitlab.haskell.org
Mon Feb 5 17:44:55 UTC 2024



Hassan Al-Awwadi pushed to branch wip/T24040-ghci-timeout-squashed at Glasgow Haskell Compiler / GHC


Commits:
cb16c8d0 by Hassan Al-Awwadi at 2024-02-05T18:42:20+01:00
Adds timeout command to ghci. Resolves #24040

- - - - -


9 changed files:

- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- + testsuite/tests/ghci/scripts/T24040.hs
- + testsuite/tests/ghci/scripts/T24040.script
- + testsuite/tests/ghci/scripts/T24040.stderr
- + testsuite/tests/ghci/scripts/T24040.stdout
- testsuite/tests/ghci/scripts/T8305.script
- testsuite/tests/ghci/scripts/T8305.stdout
- testsuite/tests/ghci/scripts/all.T


Changes:

=====================================
ghc/GHCi/UI.hs
=====================================
@@ -111,13 +111,13 @@ import GHC.Types.Error
 import System.Console.Haskeline as Haskeline
 
 import Control.Applicative hiding (empty)
+import Control.Concurrent(myThreadId, killThread, forkIO, threadDelay)
 import Control.DeepSeq (deepseq)
 import Control.Monad as Monad
 import Control.Monad.Catch as MC
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
-
 import Data.Array
 import qualified Data.ByteString.Char8 as BS
 import Data.Char
@@ -246,6 +246,7 @@ ghciCommands = map mkCmd [
   ("steplocal", keepGoing stepLocalCmd,         completeIdentifier),
   ("stepmodule",keepGoing stepModuleCmd,        completeIdentifier),
   ("type",      keepGoingMulti' typeOfExpr,          completeExpression),
+  ("timeout",   keepGoing timeoutCmd,           noCompletion),
   ("trace",     keepGoing traceCmd,             completeExpression),
   ("unadd",     keepGoingPaths unAddModule,     completeFilename),
   ("undef",     keepGoing undefineMacro,        completeMacro),
@@ -377,6 +378,7 @@ defFullHelpText =
   "                               (!: defer type errors)\n" ++
   "   :run function [<arguments> ...] run the function with the given arguments\n" ++
   "   :script <file>              run the script <file>\n" ++
+  "   :timeout <int>              set a maximum allowed time input lines are allowed to take before failing\n" ++
   "   :type <expr>                show the type of <expr>\n" ++
   "   :type +d <expr>             show the type of <expr>, defaulting type variables\n" ++
   "   :unadd <module> ...         remove module(s) from the current target set\n" ++
@@ -568,6 +570,7 @@ interactiveUI config srcs maybe_exprs = do
                    editor             = default_editor,
                    options            = [],
                    multiMode          = in_multi,
+                   time_limit         = Nothing,
                    localConfig        = SourceLocalConfig,
                    -- We initialize line number as 0, not 1, because we use
                    -- current line number while reporting errors which is
@@ -1086,6 +1089,64 @@ runCommands' eh sourceErrorHandler gCmd = mask $ \unmask -> do
         unless success $ maybe (return ()) lift sourceErrorHandler
         unmask $ runCommands' eh sourceErrorHandler gCmd
 
+
+{-
+Note [Where to Time]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Annoyingly, its not immediately clear what actions within ghci
+should be wrapped with the withTimeLimit function. For a while
+I thought wrapping `runOneCommand`, called from `runCommands`
+and `scriptLoop` made the most sense. And indeed, wrapping
+that function does properly cause things to timeout. But
+it also caused ghci to timeout while idling...
+
+In the end it was `doCommand`, nested within `runOneCommand`
+that needed wrapping for the timeout to work as expected.
+Maybe that'll be enough for now and ever more, but if
+anything else ends up needing to be wrapped, be sure
+to add it to the Note!
+
+The current state does mean that if you call a script
+with ghci :script cmd, the timeout will apply to *individual*
+statements within that script, and not the script as a
+whole. Is that correct? Its a decision, anyway.
+-}
+
+data GhciTimedOut = GhciTimedOut deriving Show
+instance Exception GhciTimedOut
+
+-- | Wraps a single run input action into a timout action, if the timelimit field has been set.
+-- | Otherwise it just runs the action without doing anything.
+-- | See Note [Where to Time]
+withTimeLimit :: (MonadIO m, MonadCatch m, GhciMonad m) => a -> m a -> m a
+withTimeLimit time_out_value cmd = do
+  maybe_limit <- time_limit <$> getGHCiState
+  case maybe_limit of
+    Nothing -> cmd
+    Just limit  -> do
+      result_or_timeout <- timeout limit cmd -- puts the IO action inside GhciMonad
+      let r = fromMaybe time_out_value result_or_timeout
+      pure r where
+
+      -- | transitively duping System.Timeout(timeout), because we need a lifted version
+      -- | transitively, because really this is a dupe of time-out's Control.Timeout(timeout)
+      -- | Luckily time-out is in Public Domain 😌
+      timeout :: (MonadIO m, MonadCatch m) => Int -> m a -> m (Maybe a)
+      timeout time action = do
+        tidMain <- liftIO myThreadId
+        -- | We might want to keep a single thread alive to reuse?
+        tidTemp <- liftIO $ forkIO $ delay time >> throwTo tidMain GhciTimedOut
+        result  <- catchTimeout action `MC.onException` liftIO (killThread tidTemp)
+        when (isJust result) $ liftIO $ killThread tidTemp
+        return result
+      ms = maxBound `div` 1000000
+      catchTimeout :: (MonadIO m, MonadCatch m) => m a -> m (Maybe a)
+      catchTimeout action = catch (Just <$> action) $ \ GhciTimedOut -> return Nothing
+      delay t = if t <= 0
+        then pure ()
+        else threadDelay (1000000 * min t ms) >> delay (t - min t ms) -- ^ there has to be a better way.
+
+
 -- | Evaluate a single line of user input (either :<command> or Haskell code).
 -- A result of Nothing means there was no more input to process.
 -- Otherwise the result is Just b where b is True if the command succeeded;
@@ -1105,7 +1166,7 @@ runOneCommand eh gCmd = do
       st <- getGHCiState
       ghciHandle (\e -> lift $ eh e >>= return . Just) $
         handleSourceError printErrorAndFail $
-          cmd_wrapper st $ doCommand c
+          withTimeLimit (Just False) $ cmd_wrapper st $ doCommand c -- ^ See Note [Where to Time]
                -- source error's are handled by runStmt
                -- is the handler necessary here?
   where
@@ -2322,8 +2383,19 @@ exceptT :: Applicative m => Either e a -> ExceptT e m a
 exceptT = ExceptT . pure
 
 -----------------------------------------------------------------------------
--- | @:type@ command. See also Note [TcRnExprMode] in GHC.Tc.Module.
+-- | @:timeout@ command.
+timeoutCmd :: GhciMonad m => String -> m ()
+timeoutCmd str = handleSourceError printErrAndMaybeExit $ set_time (readMaybe str) where
+  set_time (Just l)
+    | l == 1 = printForUser (text "setting timeout length to" <+> text (show l) <+> text "second")
+                *> modifyGHCiState (\st -> st{ time_limit = Just l })
+    | l > 0  = printForUser (text "setting timeout length to" <+> text (show l) <+> text "seconds")
+                *> modifyGHCiState (\st -> st{ time_limit = Just l })
+  set_time _ = printForUser (text "setting timeout to unbounded execution time")
+                *> modifyGHCiState (\st -> st{ time_limit = Nothing })
 
+-----------------------------------------------------------------------------
+-- | @:type@ command. See also Note [TcRnExprMode] in GHC.Tc.Module.
 typeOfExpr :: GhciMonad m => String -> m ()
 typeOfExpr str = handleSourceError printErrAndMaybeExit $
     case break isSpace str of
@@ -4702,4 +4774,4 @@ combineModIdent :: String -> String -> String
 combineModIdent mod ident
           | null mod   = ident
           | null ident = mod
-          | otherwise  = mod ++ "." ++ ident
+          | otherwise  = mod ++ "." ++ ident
\ No newline at end of file


=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -95,6 +95,7 @@ data GHCiState = GHCiState
         editor         :: String,
         stop           :: String,
         multiMode      :: Bool,
+        time_limit     :: Maybe Int,    -- ^ terminate cmds that exceed some assigned number of seconds
         localConfig    :: LocalConfigBehaviour,
         options        :: [GHCiOption],
         line_number    :: !Int,         -- ^ input line
@@ -572,4 +573,4 @@ runInternal =
       )
 
 compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue
-compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr
+compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr
\ No newline at end of file


=====================================
testsuite/tests/ghci/scripts/T24040.hs
=====================================
@@ -0,0 +1,5 @@
+module T24040 where
+import Control.Concurrent(threadDelay)
+
+delayNSeconds :: Int -> IO ()
+delayNSeconds n =  threadDelay (n * 1000000) >> putStrLn ("Finished in: " ++ show n ++ " seconds")
\ No newline at end of file


=====================================
testsuite/tests/ghci/scripts/T24040.script
=====================================
@@ -0,0 +1,11 @@
+:load T24040
+:timeout 5
+delayNSeconds 10
+delayNSeconds 2
+:timeout
+delayNSeconds 10
+:timeout 1
+delayNSeconds 5
+delayNSeconds 2
+:timeout 
+delayNSeconds 5
\ No newline at end of file


=====================================
testsuite/tests/ghci/scripts/T24040.stderr
=====================================
@@ -0,0 +1,3 @@
+*** Exception: GhciTimedOut
+*** Exception: GhciTimedOut
+*** Exception: GhciTimedOut
\ No newline at end of file


=====================================
testsuite/tests/ghci/scripts/T24040.stdout
=====================================
@@ -0,0 +1,7 @@
+setting timeout length to 5 seconds
+Finished in: 2 seconds
+setting timeout to unbounded execution time
+Finished in: 10 seconds
+setting timeout length to 1 second
+setting timeout to unbounded execution time
+Finished in: 5 seconds
\ No newline at end of file


=====================================
testsuite/tests/ghci/scripts/T8305.script
=====================================
@@ -16,7 +16,7 @@
 :def! ty    (\e -> putStrLn "called :ty macro" >> return "")
 :def! type  (\e -> putStrLn "called :type macro" >> return "")
 :def  type2 (\e -> putStrLn "called :type2 macro" >> return "")
-:def  time  (\e -> putStrLn "called :time macro" >> return "")
+:def  toys  (\e -> putStrLn "called :toys macro" >> return "")
 
 :def! ki    (\e -> putStrLn "called :ki macro" >> return "")
 :def  kind2 (\e -> putStrLn "called :kind2 macro" >> return "")
@@ -36,4 +36,4 @@
 :k ()
 
 -- 5.
-:ti ()
+:to ()


=====================================
testsuite/tests/ghci/scripts/T8305.stdout
=====================================
@@ -2,4 +2,4 @@ called :type macro
 () :: *
 called :type macro
 () :: *
-called :time macro
+called :toys macro


=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -380,4 +380,5 @@ test('T22817', normal, ghci_script, ['T22817.script'])
 test('T22908', normal, ghci_script, ['T22908.script'])
 test('T23062', normal, ghci_script, ['T23062.script'])
 test('T16468', normal, ghci_script, ['T16468.script'])
-test('T23686', normal, ghci_script, ['T23686.script'])
\ No newline at end of file
+test('T23686', normal, ghci_script, ['T23686.script'])
+test('T24040', normal, ghci_script, ['T24040.script'])
\ No newline at end of file



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb16c8d0ca90b7ecce4e0a36761c247d2eea1b67

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb16c8d0ca90b7ecce4e0a36761c247d2eea1b67
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240205/ba8cd7aa/attachment-0001.html>


More information about the ghc-commits mailing list