mirror of
https://github.com/swarm-game/swarm.git
synced 2024-10-27 10:04:12 +03:00
expose the last evaluated result as it
in REPL (#734)
Co-authored-by: Restyled.io <commits@restyled.io> Co-authored-by: Brent Yorgey <byorgey@gmail.com>
This commit is contained in:
parent
683508f36e
commit
977e0edd68
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
20
src/Swarm/Language/Typed.hs
Normal 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
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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."
|
||||
|
Loading…
Reference in New Issue
Block a user