Don't set it variable when an exception was raised (#1922)

Fixes #1899.  It turned out the problem was not specifically with infinite loop detection but simply any time an exception was thrown and bubbled up to the top level.  After logging the exception the CESK machine returned `VUnit` and there was no way for the UI to tell the difference between a computation that ended successfully with value `VUnit` and one with an uncaught exception.  This PR adds a new special value `VExc` to denote the result of a computation that threw an exception.  The UI can then check for this and not set the `it` variable in that case.
This commit is contained in:
Brent Yorgey 2024-06-10 14:14:45 -05:00 committed by GitHub
parent 1eabd556b9
commit 08730162bd
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
6 changed files with 34 additions and 27 deletions

View File

@ -1,4 +1,4 @@
loops: loops:
build: cabal build -j -O0 all build: cabal build -j -O0 --ghc-options='-Wall -Werror' all
test: cabal test -j -O0 --test-show-details=direct swarm:swarm-integration swarm:swarm-unit test: cabal test -j -O0 --test-show-details=direct swarm:swarm-integration swarm:swarm-unit
unit: cabal test -j -O0 --test-show-details=direct swarm:swarm-unit unit: cabal test -j -O0 --test-show-details=direct swarm:swarm-unit

View File

@ -847,11 +847,9 @@ stepCESK cesk = case cesk of
let s' = resetBlackholes s let s' = resetBlackholes s
h <- hasCapability CLog h <- hasCapability CLog
em <- use $ landscape . terrainAndEntities . entityMap em <- use $ landscape . terrainAndEntities . entityMap
if h when h $ void $ traceLog RobotError Error (formatExn em exn)
then do return $ Out VExc s' []
void $ traceLog RobotError Error (formatExn em exn)
return $ Out VUnit s []
else return $ Out VUnit s' []
-- Fatal errors, capability errors, and infinite loop errors can't -- Fatal errors, capability errors, and infinite loop errors can't
-- be caught; just throw away the continuation stack. -- be caught; just throw away the continuation stack.
Up exn@Fatal {} s _ -> return $ Up exn s [] Up exn@Fatal {} s _ -> return $ Up exn s []

View File

@ -75,6 +75,7 @@ compareValues v1 = case v1 of
VDelay {} -> incomparable v1 VDelay {} -> incomparable v1
VRef {} -> incomparable v1 VRef {} -> incomparable v1
VRequirements {} -> incomparable v1 VRequirements {} -> incomparable v1
VExc {} -> incomparable v1
-- | Values with different types were compared; this should not be -- | Values with different types were compared; this should not be
-- possible since the type system should catch it. -- possible since the type system should catch it.

View File

@ -92,6 +92,9 @@ data Value where
VKey :: KeyCombo -> Value VKey :: KeyCombo -> Value
-- | A 'requirements' command awaiting execution. -- | A 'requirements' command awaiting execution.
VRequirements :: Text -> Term -> Env -> Value VRequirements :: Text -> Term -> Env -> Value
-- | A special value representing a program that terminated with
-- an exception.
VExc :: Value
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)
instance ToJSON Value where instance ToJSON Value where
@ -133,6 +136,7 @@ valueToTerm (VRef n) = TRef n
valueToTerm (VRcd m) = TRcd (Just . valueToTerm <$> m) valueToTerm (VRcd m) = TRcd (Just . valueToTerm <$> m)
valueToTerm (VKey kc) = TApp (TConst Key) (TText (prettyKeyCombo kc)) valueToTerm (VKey kc) = TApp (TConst Key) (TText (prettyKeyCombo kc))
valueToTerm (VRequirements x t _) = TRequirements x t valueToTerm (VRequirements x t _) = TRequirements x t
valueToTerm VExc = TConst Undefined
-- | An environment is a mapping from variable names to values. -- | An environment is a mapping from variable names to values.
type Env = Ctx Value type Env = Ctx Value

View File

@ -104,7 +104,7 @@ import Swarm.Language.Requirement qualified as R
import Swarm.Language.Syntax hiding (Key) import Swarm.Language.Syntax hiding (Key)
import Swarm.Language.Typed (Typed (..)) import Swarm.Language.Typed (Typed (..))
import Swarm.Language.Types import Swarm.Language.Types
import Swarm.Language.Value (Value (VKey, VUnit), prettyValue, stripVResult) import Swarm.Language.Value (Value (VExc, VKey, VUnit), prettyValue, stripVResult)
import Swarm.Log import Swarm.Log
import Swarm.TUI.Controller.Util import Swarm.TUI.Controller.Util
import Swarm.TUI.Editor.Controller qualified as EC import Swarm.TUI.Editor.Controller qualified as EC
@ -829,19 +829,21 @@ updateUI = do
-- Now check if the base finished running a program entered at the REPL. -- Now check if the base finished running a program entered at the REPL.
replUpdated <- case g ^. gameControls . replStatus of replUpdated <- case g ^. gameControls . replStatus of
-- It did, and the result was the unit value. Just reset replStatus. REPLWorking (Typed (Just v) pty reqs)
REPLWorking (Typed (Just VUnit) typ reqs) -> do -- It did, and the result was the unit value or an exception. Just reset replStatus.
gameState . gameControls . replStatus .= REPLDone (Just $ Typed VUnit typ reqs) | v `elem` [VUnit, VExc] -> do
gameState . gameControls . replStatus .= REPLDone (Just $ Typed v pty reqs)
pure True pure True
-- It did, and returned some other value. Pretty-print the -- It did, and returned some other value. Create a new 'it'
-- result as a REPL output, with its type, and reset the replStatus. -- variable, pretty-print the result as a REPL output, with its
REPLWorking (Typed (Just v) pty reqs) -> do -- type, and reset the replStatus.
let finalType = stripCmd pty | otherwise -> do
let val = Typed (stripVResult v) finalType reqs
itIx <- use (gameState . gameControls . replNextValueIndex) itIx <- use (gameState . gameControls . replNextValueIndex)
let itName = fromString $ "it" ++ show itIx let finalType = stripCmd pty
let out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)] val = Typed (stripVResult v) finalType reqs
itName = fromString $ "it" ++ show itIx
out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)]
uiState . uiGameplay . uiREPL . replHistory %= addREPLItem (REPLOutput out) uiState . uiGameplay . uiREPL . replHistory %= addREPLItem (REPLOutput out)
invalidateCacheEntry REPLHistoryCache invalidateCacheEntry REPLHistoryCache
vScrollToEnd replScroll vScrollToEnd replScroll

View File

@ -93,6 +93,8 @@ import Swarm.Game.State.Runtime
import Swarm.Game.State.Substate import Swarm.Game.State.Substate
import Swarm.Game.Tick (TickNumber (..)) import Swarm.Game.Tick (TickNumber (..))
import Swarm.Game.World.Gen (Seed) import Swarm.Game.World.Gen (Seed)
import Swarm.Language.Typed (Typed (..))
import Swarm.Language.Value (Value (VExc))
import Swarm.Log import Swarm.Log
import Swarm.TUI.Inventory.Sorting import Swarm.TUI.Inventory.Sorting
import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Menu
@ -317,5 +319,5 @@ topContext s = ctxPossiblyWithIt
ctx = fromMaybe emptyRobotContext $ s ^? gameState . baseRobot . robotContext ctx = fromMaybe emptyRobotContext $ s ^? gameState . baseRobot . robotContext
ctxPossiblyWithIt = case s ^. gameState . gameControls . replStatus of ctxPossiblyWithIt = case s ^. gameState . gameControls . replStatus of
REPLDone (Just p) -> ctx & at "it" ?~ p REPLDone (Just p@(Typed v _ _)) | v /= VExc -> ctx & at "it" ?~ p
_ -> ctx _ -> ctx