mirror of
https://github.com/swarm-game/swarm.git
synced 2024-10-05 20:19:09 +03:00
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:
parent
1eabd556b9
commit
08730162bd
@ -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
|
||||||
|
@ -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 []
|
||||||
|
@ -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.
|
||||||
|
@ -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
|
||||||
|
@ -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,26 +829,28 @@ 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
|
||||||
pure True
|
gameState . gameControls . replStatus .= REPLDone (Just $ Typed v pty reqs)
|
||||||
|
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 finalType = stripCmd pty
|
||||||
let itName = fromString $ "it" ++ show itIx
|
val = Typed (stripVResult v) finalType reqs
|
||||||
let out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)]
|
itName = fromString $ "it" ++ show itIx
|
||||||
uiState . uiGameplay . uiREPL . replHistory %= addREPLItem (REPLOutput out)
|
out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)]
|
||||||
invalidateCacheEntry REPLHistoryCache
|
uiState . uiGameplay . uiREPL . replHistory %= addREPLItem (REPLOutput out)
|
||||||
vScrollToEnd replScroll
|
invalidateCacheEntry REPLHistoryCache
|
||||||
gameState . gameControls . replStatus .= REPLDone (Just val)
|
vScrollToEnd replScroll
|
||||||
gameState . baseRobot . robotContext . at itName .= Just val
|
gameState . gameControls . replStatus .= REPLDone (Just val)
|
||||||
gameState . gameControls . replNextValueIndex %= (+ 1)
|
gameState . baseRobot . robotContext . at itName .= Just val
|
||||||
pure True
|
gameState . gameControls . replNextValueIndex %= (+ 1)
|
||||||
|
pure True
|
||||||
|
|
||||||
-- Otherwise, do nothing.
|
-- Otherwise, do nothing.
|
||||||
_ -> pure False
|
_ -> pure False
|
||||||
|
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user