swarm-game/swarm
1
1
Fork 0
mirror of https://github.com/swarm-game/swarm.git synced 2024-10-27 10:04:12 +03:00
Code Issues Projects Releases Wiki Activity

expose the last evaluated result as it in REPL (#734)

Browse Source 
Co-authored-by: Restyled.io <commits@restyled.io>
Co-authored-by: Brent Yorgey <byorgey@gmail.com>
This commit is contained in:
Valentin Golev 2022-10-16 22:21:36 +02:00 committed by GitHub
parent 683508f36e
commit 977e0edd68
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 119 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
src/Swarm/Game/Robot.hs
View File

@ -41,6 +41,7 @@ module Swarm.Game.Robot (
defReqs,
defVals,
defStore,
emptyRobotContext,
-- ** Lenses
robotEntity,
@ -102,6 +103,7 @@ import Swarm.Language.Capability (Capability)
import Swarm.Language.Context qualified as Ctx
import Swarm.Language.Requirement (ReqCtx)
import Swarm.Language.Syntax (toDirection)
import Swarm.Language.Typed (Typed (..))
import Swarm.Language.Types (TCtx)
import Swarm.Util ()
import Swarm.Util.Yaml
@ -127,6 +129,31 @@ data RobotContext = RobotContext
makeLenses ''RobotContext
emptyRobotContext :: RobotContext
emptyRobotContext = RobotContext Ctx.empty Ctx.empty Ctx.empty emptyStore
type instance Index RobotContext = Ctx.Var
type instance IxValue RobotContext = Typed Value
instance Ixed RobotContext
instance At RobotContext where
at name = lens getter setter
where
getter ctx =
do
typ <- Ctx.lookup name (ctx ^. defTypes)
val <- Ctx.lookup name (ctx ^. defVals)
req <- Ctx.lookup name (ctx ^. defReqs)
return $ Typed val typ req
setter ctx Nothing =
ctx & defTypes %~ Ctx.delete name
& defVals %~ Ctx.delete name
& defReqs %~ Ctx.delete name
setter ctx (Just (Typed val typ req)) =
ctx & defTypes %~ Ctx.addBinding name typ
& defVals %~ Ctx.addBinding name val
& defReqs %~ Ctx.addBinding name req
data LogSource = Said | Logged | ErrorTrace
deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
@ -472,7 +499,7 @@ mkRobot rid pid name descr loc dir disp m devs inv sys heavy ts =
, _robotLog = Seq.empty
, _robotLogUpdated = False
, _robotLocation = loc
, _robotContext = RobotContext Ctx.empty Ctx.empty Ctx.empty emptyStore
, _robotContext = emptyRobotContext
, _robotID = rid
, _robotParentID = pid
, _robotHeavy = heavy

25
src/Swarm/Game/State.hs
View File

@ -38,6 +38,7 @@ module Swarm.Game.State (
robotsByLocation,
robotsAtLocation,
robotsInArea,
baseRobot,
activeRobots,
waitingRobots,
availableRecipes,
@ -61,6 +62,7 @@ module Swarm.Game.State (
viewCenter,
needsRedraw,
replStatus,
replNextValueIndex,
replWorking,
replActiveType,
messageQueue,
@ -153,6 +155,7 @@ import Swarm.Language.Context qualified as Ctx
import Swarm.Language.Pipeline (ProcessedTerm)
import Swarm.Language.Pipeline.QQ (tmQ)
import Swarm.Language.Syntax (Const, Term (TText), allConst)
import Swarm.Language.Typed (Typed (Typed))
import Swarm.Language.Types
import Swarm.Util (getDataFileNameSafe, getElemsInArea, isRightOr, manhattan, uniq, (<+=), (<<.=), (?))
import System.Clock qualified as Clock
@ -178,12 +181,12 @@ makePrisms ''ViewCenterRule
data REPLStatus
= -- | The REPL is not doing anything actively at the moment.
-- We persist the last value and its type though.
REPLDone (Maybe (Polytype, Value))
REPLDone (Maybe (Typed Value))
| -- | A command entered at the REPL is currently being run. The
-- 'Polytype' represents the type of the expression that was
-- entered. The @Maybe Value@ starts out as @Nothing@ and gets
-- filled in with a result once the command completes.
REPLWorking Polytype (Maybe Value)
REPLWorking (Typed (Maybe Value))
deriving (Eq, Show, Generic, FromJSON, ToJSON)
data WinCondition
@ -285,6 +288,7 @@ data GameState = GameState
, _viewCenter :: V2 Int64
, _needsRedraw :: Bool
, _replStatus :: REPLStatus
, _replNextValueIndex :: Integer
, _messageQueue :: Seq LogEntry
, _lastSeenMessageTime :: Integer
, _focusedRobotID :: RID
@ -361,6 +365,10 @@ robotsInArea o d gs = map (rm IM.!) rids
rl = gs ^. robotsByLocation
rids = concatMap IS.elems $ getElemsInArea o d rl
-- | The base robot, if it exists.
baseRobot :: Traversal' GameState Robot
baseRobot = robotMap . ix 0
-- | The list of entities that have been discovered.
allDiscoveredEntities :: Lens' GameState Inventory
@ -442,6 +450,9 @@ needsRedraw :: Lens' GameState Bool
-- | The current status of the REPL.
replStatus :: Lens' GameState REPLStatus
-- | The index of the next it{index} value
replNextValueIndex :: Lens' GameState Integer
-- | A queue of global messages.
--
-- Note that we put the newest entry to the right.
@ -499,14 +510,14 @@ replWorking :: Getter GameState Bool
replWorking = to (\s -> matchesWorking $ s ^. replStatus)
where
matchesWorking (REPLDone _) = False
matchesWorking (REPLWorking _ _) = True
matchesWorking (REPLWorking _) = True
-- | Either the type of the command being executed, or of the last command
replActiveType :: Getter REPLStatus (Maybe Polytype)
replActiveType = to getter
where
getter (REPLDone (Just (typ, _))) = Just typ
getter (REPLWorking typ _) = Just typ
getter (REPLDone (Just (Typed _ typ _))) = Just typ
getter (REPLWorking (Typed _ typ _)) = Just typ
getter _ = Nothing
-- | Get the notification list of messages from the point of view of focused robot.
@ -714,6 +725,7 @@ initGameState = do
, _viewCenter = V2 0 0
, _needsRedraw = False
, _replStatus = REPLDone Nothing
, _replNextValueIndex = 0
, _messageQueue = Empty
, _lastSeenMessageTime = -1
, _focusedRobotID = 0
@ -764,7 +776,8 @@ scenarioToGameState scenario userSeed toRun g = do
-- otherwise the store of definition cells is not saved (see #333)
_replStatus = case toRun of
Nothing -> REPLDone Nothing
Just _ -> REPLWorking PolyUnit Nothing
Just _ -> REPLWorking (Typed Nothing PolyUnit mempty)
, _replNextValueIndex = 0
, _messageQueue = Empty
, _focusedRobotID = baseID
, _ticks = 0

7
src/Swarm/Game/Step.hs
View File

@ -65,6 +65,7 @@ import Swarm.Language.Pipeline
import Swarm.Language.Pipeline.QQ (tmQ)
import Swarm.Language.Requirement qualified as R
import Swarm.Language.Syntax
import Swarm.Language.Typed (Typed (..))
import Swarm.Util
import System.Clock (TimeSpec)
import System.Clock qualified
@ -110,10 +111,10 @@ gameTick = do
Just r -> do
res <- use replStatus
case res of
REPLWorking ty Nothing -> case getResult r of
REPLWorking (Typed Nothing ty req) -> case getResult r of
Just (v, s) -> do
replStatus .= REPLWorking ty (Just v)
robotMap . ix 0 . robotContext . defStore .= s
replStatus .= REPLWorking (Typed (Just v) ty req)
baseRobot . robotContext . defStore .= s
Nothing -> return ()
_otherREPLStatus -> return ()
Nothing -> return ()

20
src/Swarm/Language/Typed.hs Normal file
View File

@ -0,0 +1,20 @@
{-# LANGUAGE TemplateHaskell #-}
module Swarm.Language.Typed (Typed (..), value, polytype, requires) where
import Control.Lens (makeLenses)
import Data.Aeson (ToJSON)
import Data.Aeson.Types (FromJSON)
import GHC.Generics (Generic)
import Swarm.Language.Requirement (Requirements)
import Swarm.Language.Types (Polytype)
-- | A value, or a hole, or something else that has its type & requirements fixed
data Typed v = Typed
{ _value :: v
, _polytype :: Polytype
, _requires :: Requirements
}
deriving (Show, Eq, Generic, FromJSON, ToJSON)
makeLenses ''Typed

69
src/Swarm/TUI/Controller.hs
View File

@ -57,6 +57,7 @@ import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Data.String (fromString)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Time (getZonedTime)
@ -77,6 +78,7 @@ import Swarm.Language.Pipeline
import Swarm.Language.Pretty
import Swarm.Language.Requirement qualified as R
import Swarm.Language.Syntax
import Swarm.Language.Typed (Typed (..))
import Swarm.Language.Types
import Swarm.TUI.List
import Swarm.TUI.Model
@ -582,16 +584,22 @@ updateUI = do
-- Now check if the base finished running a program entered at the REPL.
replUpdated <- case g ^. replStatus of
-- It did, and the result was the unit value. Just reset replStatus.
REPLWorking _ (Just VUnit) -> do
gameState . replStatus .= REPLDone (Just (PolyUnit, VUnit))
REPLWorking (Typed (Just VUnit) typ reqs) -> do
gameState . replStatus .= REPLDone (Just $ Typed VUnit typ reqs)
pure True
-- It did, and returned some other value. Pretty-print the
-- result as a REPL output, with its type, and reset the replStatus.
REPLWorking pty (Just v) -> do
let out = T.intercalate " " [into (prettyValue v), ":", prettyText (stripCmd pty)]
REPLWorking (Typed (Just v) pty reqs) -> do
let finalType = stripCmd pty
let val = Typed v finalType reqs
itIx <- use (gameState . replNextValueIndex)
let itName = fromString $ "it" ++ show itIx
let out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)]
uiState . uiReplHistory %= addREPLItem (REPLOutput out)
gameState . replStatus .= REPLDone (Just (pty, v))
gameState . replStatus .= REPLDone (Just val)
gameState . baseRobot . robotContext . at itName .= Just val
gameState . replNextValueIndex %= (+ 1)
pure True
-- Otherwise, do nothing.
@ -677,6 +685,8 @@ loadVisibleRegion = do
gs <- use gameState
gameState . world %= W.loadRegion (viewingRegion gs (over both fromIntegral size))
-- | Strips top-level `cmd` from type (in case of REPL evaluation),
-- and returns a boolean to indicate if it happened
stripCmd :: Polytype -> Polytype
stripCmd (Forall xs (TyCmd ty)) = Forall xs ty
stripCmd pty = pty
@ -685,30 +695,39 @@ stripCmd pty = pty
-- REPL events
------------------------------------------------------------
-- | Context for the REPL commands to execute in. Contains the base
-- robot context plus the `it` variable that refer to the previously
-- computed values. (Note that `it{n}` variables are set in the
-- base robot context; we only set `it` here because it's so transient)
topContext :: AppState -> RobotContext
topContext s = ctxPossiblyWithIt
where
ctx = fromMaybe emptyRobotContext $ s ^? gameState . baseRobot . robotContext
ctxPossiblyWithIt = case s ^. gameState . replStatus of
REPLDone (Just p) -> ctx & at "it" ?~ p
_ -> ctx
-- | Handle a user input event for the REPL.
handleREPLEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()
handleREPLEvent = \case
ControlKey 'c' -> do
gameState . robotMap . ix 0 . machine %= cancel
gameState . baseRobot . machine %= cancel
uiState %= resetWithREPLForm (mkReplForm $ mkCmdPrompt "")
Key V.KEnter -> do
s <- get
let entry = formState (s ^. uiState . uiReplForm)
topTypeCtx = s ^. gameState . robotMap . ix 0 . robotContext . defTypes
topReqCtx = s ^. gameState . robotMap . ix 0 . robotContext . defReqs
topValCtx = s ^. gameState . robotMap . ix 0 . robotContext . defVals
topStore =
fromMaybe emptyStore $
s ^? gameState . robotMap . at 0 . _Just . robotContext . defStore
startBaseProgram t@(ProcessedTerm _ (Module ty _) _ _) =
(gameState . replStatus .~ REPLWorking ty Nothing)
. (gameState . robotMap . ix 0 . machine .~ initMachine t topValCtx topStore)
topCtx = topContext s
startBaseProgram t@(ProcessedTerm _ (Module ty _) reqs _) =
(gameState . replStatus .~ REPLWorking (Typed Nothing ty reqs))
. (gameState . baseRobot . machine .~ initMachine t (topCtx ^. defVals) (topCtx ^. defStore))
. (gameState %~ execState (activateRobot 0))
if not $ s ^. gameState . replWorking
then case entry of
CmdPrompt uinput _ ->
case processTerm' topTypeCtx topReqCtx uinput of
case processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput of
Right mt -> do
uiState %= resetWithREPLForm (set promptUpdateL "" (s ^. uiState))
uiState . uiReplHistory %= addREPLItem (REPLEntry uinput)
@ -778,7 +797,7 @@ tabComplete s (CmdPrompt t mms)
where
completeWith m = T.append t (T.drop (T.length lastWord) m)
lastWord = T.takeWhileEnd isIdentChar t
names = s ^.. gameState . robotMap . ix 0 . robotContext . defTypes . to assocs . traverse . _1
names = s ^.. gameState . baseRobot . robotContext . defTypes . to assocs . traverse . _1
possibleWords = reservedWords ++ names
matches = filter (lastWord `T.isPrefixOf`) possibleWords
@ -791,7 +810,7 @@ validateREPLForm s =
let theType = s ^. gameState . replStatus . replActiveType
in s & uiState . uiReplType .~ theType
CmdPrompt uinput _ ->
let result = processTerm' topTypeCtx topReqCtx uinput
let result = processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput
theType = case result of
Right (Just (ProcessedTerm _ (Module ty _) _ _)) -> Just ty
_ -> Nothing
@ -801,8 +820,7 @@ validateREPLForm s =
SearchPrompt _ _ -> s
where
replPrompt = s ^. uiState . uiReplForm . to formState
topTypeCtx = s ^. gameState . robotMap . ix 0 . robotContext . defTypes
topReqCtx = s ^. gameState . robotMap . ix 0 . robotContext . defReqs
topCtx = topContext s
validate result = setFieldValid (isRight result) REPLInput
-- | Update our current position in the REPL history.
@ -918,16 +936,17 @@ makeEntity :: Entity -> EventM Name AppState ()
makeEntity e = do
s <- get
let mkTy = PolyUnit
mkReq = R.singletonCap CMake
mkProg = TApp (TConst Make) (TText (e ^. entityName))
mkPT = ProcessedTerm mkProg (Module mkTy empty) (R.singletonCap CMake) empty
mkPT = ProcessedTerm mkProg (Module mkTy empty) mkReq empty
topStore =
fromMaybe emptyStore $
s ^? gameState . robotMap . at 0 . _Just . robotContext . defStore
s ^? gameState . baseRobot . robotContext . defStore
case isActive <$> (s ^. gameState . robotMap . at 0) of
case isActive <$> (s ^? gameState . baseRobot) of
Just False -> do
gameState . replStatus .= REPLWorking mkTy Nothing
gameState . robotMap . ix 0 . machine .= initMachine mkPT empty topStore
gameState . replStatus .= REPLWorking (Typed Nothing mkTy mkReq)
gameState . baseRobot . machine .= initMachine mkPT empty topStore
gameState %= execState (activateRobot 0)
_ -> continueWithoutRedraw

2
src/Swarm/TUI/View.hs
View File

@ -554,7 +554,7 @@ robotsListWidget s = hCenter table
| otherwise -> withAttr greenAttr $ txt "idle"
basePos :: V2 Double
basePos = realToFrac <$> fromMaybe (V2 0 0) (g ^? robotMap . ix 0 . robotLocation)
basePos = realToFrac <$> fromMaybe (V2 0 0) (g ^? baseRobot . robotLocation)
-- Keep the base and non sytem robot (e.g. no seed)
isRelevant robot = robot ^. robotID == 0 || not (robot ^. systemRobot)
-- Keep the robot that are less than 32 unit away from the base

1
swarm.cabal
View File

@ -90,6 +90,7 @@ library
Swarm.Language.Parse.QQ
Swarm.Language.Pretty
Swarm.Language.Typecheck
Swarm.Language.Typed
Swarm.Language.Elaborate
Swarm.Language.LSP
Swarm.Language.Pipeline

3
test/integration/Main.hs
View File

@ -29,6 +29,7 @@ import Swarm.Game.State (
GameState,
WinCondition (Won),
activeRobots,
baseRobot,
initGameStateForScenario,
messageQueue,
robotMap,
@ -221,7 +222,7 @@ testScenarioSolution _ci _em =
case gs ^. winSolution of
Nothing -> assertFailure "No solution to test!"
Just sol -> do
let gs' = gs & robotMap . ix 0 . machine .~ initMachine sol Ctx.empty emptyStore
let gs' = gs & baseRobot . machine .~ initMachine sol Ctx.empty emptyStore
m <- timeout (time s) (snd <$> runStateT playUntilWin gs')
case m of
Nothing -> assertFailure "Timed out - this likely means that the solution did not work."