From a306d05f61727d8a5525f7275f89d33f65e41669 Mon Sep 17 00:00:00 2001 From: persik Date: Wed, 15 Nov 2023 06:17:09 +0000 Subject: [PATCH] Add TimeEffect effect for getting current time (#1620) fixes #1502 Add TimeEffect effect for getting current time. --- src/Swarm/Effect.hs | 6 +++++ src/Swarm/Effect/Time.hs | 27 ++++++++++++++++++++ src/Swarm/Game/Step.hs | 42 +++++++++++++++++++------------ src/Swarm/Game/Step/Combustion.hs | 4 +-- src/Swarm/Game/Step/Util.hs | 6 ----- src/Swarm/TUI/Controller.hs | 5 ++-- src/Swarm/Util/Effect.hs | 1 + swarm.cabal | 2 ++ test/bench/Benchmark.hs | 3 ++- test/integration/Main.hs | 3 ++- test/unit/TestUtil.hs | 5 ++-- 11 files changed, 74 insertions(+), 30 deletions(-) create mode 100644 src/Swarm/Effect.hs create mode 100644 src/Swarm/Effect/Time.hs diff --git a/src/Swarm/Effect.hs b/src/Swarm/Effect.hs new file mode 100644 index 00000000..af7c4563 --- /dev/null +++ b/src/Swarm/Effect.hs @@ -0,0 +1,6 @@ +module Swarm.Effect ( + module X, +) +where + +import Swarm.Effect.Time as X diff --git a/src/Swarm/Effect/Time.hs b/src/Swarm/Effect/Time.hs new file mode 100644 index 00000000..2d72b4d3 --- /dev/null +++ b/src/Swarm/Effect/Time.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +module Swarm.Effect.Time where + +import Control.Algebra +import Control.Monad.Trans (MonadIO (liftIO)) +import Data.Kind (Type) +import System.Clock (Clock (Monotonic), TimeSpec, getTime) + +-- | Effect for things related to time +data Time (m :: Type -> Type) k where + GetNow :: Time m TimeSpec + +getNow :: Has Time sig m => m TimeSpec +getNow = send GetNow + +newtype TimeIOC m a = TimeIOC {runTimeIO :: m a} + deriving newtype (Applicative, Functor, Monad, MonadIO) + +instance (MonadIO m, Algebra sig m) => Algebra (Time :+: sig) (TimeIOC m) where + alg hdl sig ctx = case sig of + L GetNow -> (<$ ctx) <$> liftIO (System.Clock.getTime System.Clock.Monotonic) + R other -> TimeIOC (alg (runTimeIO . hdl) other ctx) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index a4974ddc..e408c90c 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -59,6 +59,7 @@ import Data.Time (getZonedTime) import Data.Tuple (swap) import Linear (V2 (..), perp, zero) import Prettyprinter (pretty) +import Swarm.Effect as Effect (Time, getNow) import Swarm.Game.Achievement.Attainment import Swarm.Game.Achievement.Definitions import Swarm.Game.CESK @@ -116,7 +117,7 @@ import Prelude hiding (Applicative (..), lookup) -- -- Note that the game may be in 'RobotStep' mode and not finish -- the tick. Use the return value to check whether a full tick happened. -gameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m) => m Bool +gameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => m Bool gameTick = do wakeUpRobotsDoneSleeping active <- use activeRobots @@ -164,7 +165,7 @@ gameTick = do -- | Finish a game tick in progress and set the game to 'WorldTick' mode afterwards. -- -- Use this function if you need to unpause the game. -finishGameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m) => m () +finishGameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => m () finishGameTick = use (temporal . gameStep) >>= \case WorldTick -> pure () @@ -189,7 +190,7 @@ insertBackRobot rn rob = do unless (isActive rob) (sleepForever rn) -- Run a set of robots - this is used to run robots before/after the focused one. -runRobotIDs :: (Has (State GameState) sig m, Has (Lift IO) sig m) => IS.IntSet -> m () +runRobotIDs :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => IS.IntSet -> m () runRobotIDs robotNames = forM_ (IS.toList robotNames) $ \rn -> do mr <- uses robotMap (IM.lookup rn) forM_ mr (stepOneRobot rn) @@ -197,7 +198,7 @@ runRobotIDs robotNames = forM_ (IS.toList robotNames) $ \rn -> do stepOneRobot rn rob = tickRobot rob >>= insertBackRobot rn -- This is a helper function to do one robot step or run robots before/after. -singleStep :: (Has (State GameState) sig m, Has (Lift IO) sig m) => SingleStep -> RID -> IS.IntSet -> m Bool +singleStep :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => SingleStep -> RID -> IS.IntSet -> m Bool singleStep ss focRID robotSet = do let (preFoc, focusedActive, postFoc) = IS.splitMember focRID robotSet case ss of @@ -291,7 +292,7 @@ data CompletionsWithExceptions = CompletionsWithExceptions -- 3) The iteration needs to be a "fold", so that state is updated -- after each element. hypotheticalWinCheck :: - (Has (State GameState) sig m, Has (Lift IO) sig m) => + (Has (State GameState) sig m, Has Effect.Time sig m, Has (Lift IO) sig m) => EntityMap -> GameState -> WinStatus -> @@ -381,7 +382,11 @@ hypotheticalWinCheck em g ws oc = do h = hypotheticalRobot (Out VUnit emptyStore []) 0 evalPT :: - (Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) => + ( Has Effect.Time sig m + , Has (Throw Exn) sig m + , Has (State GameState) sig m + , Has (Lift IO) sig m + ) => ProcessedTerm -> m Value evalPT t = evaluateCESK (initMachine t empty emptyStore) @@ -407,7 +412,11 @@ hypotheticalRobot c = mempty evaluateCESK :: - (Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) => + ( Has Effect.Time sig m + , Has (Throw Exn) sig m + , Has (State GameState) sig m + , Has (Lift IO) sig m + ) => CESK -> m Value evaluateCESK cesk = do @@ -417,7 +426,8 @@ evaluateCESK cesk = do evalState r . runCESK $ cesk runCESK :: - ( Has (Lift IO) sig m + ( Has Effect.Time sig m + , Has (Lift IO) sig m , Has (Throw Exn) sig m , Has (State GameState) sig m , Has (State Robot) sig m @@ -520,7 +530,7 @@ withExceptions s k m = do -- | Run a robot for one tick, which may consist of up to -- 'robotStepsPerTick' CESK machine steps and at most one tangible -- command execution, whichever comes first. -tickRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot +tickRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => Robot -> m Robot tickRobot r = do steps <- use $ temporal . robotStepsPerTick tickRobotRec (r & activityCounts . tickStepBudget .~ steps) @@ -529,7 +539,7 @@ tickRobot r = do -- robot is actively running and still has steps left, and if so -- runs it for one step, then calls itself recursively to continue -- stepping the robot. -tickRobotRec :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot +tickRobotRec :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => Robot -> m Robot tickRobotRec r = do time <- use $ temporal . ticks case wantsToStep time r && (r ^. runningAtomic || r ^. activityCounts . tickStepBudget > 0) of @@ -538,7 +548,7 @@ tickRobotRec r = do -- | Single-step a robot by decrementing its 'tickStepBudget' counter and -- running its CESK machine for one step. -stepRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot +stepRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => Robot -> m Robot stepRobot r = do (r', cesk') <- runState (r & activityCounts . tickStepBudget -~ 1) (stepCESK (r ^. machine)) -- sendIO $ appendFile "out.txt" (prettyString cesk' ++ "\n") @@ -589,7 +599,7 @@ data SKpair = SKpair Store Cont -- -- Compare to "withExceptions". processImmediateFrame :: - (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => + (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => Value -> SKpair -> -- | the unreliable computation @@ -614,7 +624,7 @@ updateWorldAndRobots cmd wf rf = do -- | The main CESK machine workhorse. Given a robot, look at its CESK -- machine state and figure out a single next step. -stepCESK :: (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => CESK -> m CESK +stepCESK :: (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => CESK -> m CESK stepCESK cesk = case cesk of ------------------------------------------------------------ -- Evaluation @@ -963,7 +973,7 @@ stepCESK cesk = case cesk of -- | Eexecute a constant, catching any exception thrown and returning -- it via a CESK machine state. evalConst :: - (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => Const -> [Value] -> Store -> Cont -> m CESK + (Has (State GameState) sig m, Has (State Robot) sig m, Has Effect.Time sig m, Has (Lift IO) sig m) => Const -> [Value] -> Store -> Cont -> m CESK evalConst c vs s k = do res <- runError $ execConst c vs s k case res of @@ -1021,7 +1031,7 @@ addSeedBot e (minT, maxT) loc ts = -- | Interpret the execution (or evaluation) of a constant application -- to some values. execConst :: - (HasRobotStepState sig m, Has (Lift IO) sig m) => + (HasRobotStepState sig m, Has Effect.Time sig m, Has (Lift IO) sig m) => Const -> [Value] -> Store -> @@ -2550,7 +2560,7 @@ execConst c vs s k = do -- The code for grab and harvest is almost identical, hence factored -- out here. - doGrab :: (HasRobotStepState sig m, Has (Lift IO) sig m) => GrabbingCmd -> m Entity + doGrab :: (HasRobotStepState sig m, Has Effect.Time sig m) => GrabbingCmd -> m Entity doGrab cmd = do let verb = verbGrabbingCmd cmd verbed = verbedGrabbingCmd cmd diff --git a/src/Swarm/Game/Step/Combustion.hs b/src/Swarm/Game/Step/Combustion.hs index e1706fdf..c96fadbc 100644 --- a/src/Swarm/Game/Step/Combustion.hs +++ b/src/Swarm/Game/Step/Combustion.hs @@ -19,11 +19,11 @@ module Swarm.Game.Step.Combustion where import Control.Applicative (Applicative (..)) import Control.Carrier.State.Lazy import Control.Effect.Lens -import Control.Effect.Lift import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) import Control.Monad (forM_, void, when) import Data.Text qualified as T import Linear (zero) +import Swarm.Effect as Effect (Time, getNow) import Swarm.Game.CESK (emptyStore, initMachine) import Swarm.Game.Display import Swarm.Game.Entity hiding (empty, lookup, singleton, union) @@ -44,7 +44,7 @@ import Swarm.Util hiding (both) import System.Clock (TimeSpec) import Prelude hiding (Applicative (..), lookup) -igniteCommand :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Const -> Direction -> m () +igniteCommand :: (HasRobotStepState sig m, Has Effect.Time sig m) => Const -> Direction -> m () igniteCommand c d = do (loc, me) <- lookInDirection d -- Ensure there is an entity here. diff --git a/src/Swarm/Game/Step/Util.hs b/src/Swarm/Game/Step/Util.hs index dd34020f..fd9ced56 100644 --- a/src/Swarm/Game/Step/Util.hs +++ b/src/Swarm/Game/Step/Util.hs @@ -13,7 +13,6 @@ import Control.Applicative (Applicative (..)) import Control.Carrier.State.Lazy import Control.Effect.Error import Control.Effect.Lens -import Control.Effect.Lift import Control.Monad (forM_, guard, when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) @@ -41,8 +40,6 @@ import Swarm.Language.Capability import Swarm.Language.Requirement qualified as R import Swarm.Language.Syntax import Swarm.Util hiding (both) -import System.Clock (TimeSpec) -import System.Clock qualified import System.Random (UniformRange, uniformR) import Prelude hiding (Applicative (..), lookup) @@ -115,9 +112,6 @@ cmdExn c parts = CmdFailed c (T.unwords parts) Nothing -- * Some utility functions -getNow :: Has (Lift IO) sig m => m TimeSpec -getNow = sendIO $ System.Clock.getTime System.Clock.Monotonic - -- | Set a flag telling the UI that the world needs to be redrawn. flagRedraw :: (Has (State GameState) sig m) => m () flagRedraw = needsRedraw .= True diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs index 89a4fe38..28946339 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -70,6 +70,7 @@ import Data.Time (getZonedTime) import Data.Vector qualified as V import Graphics.Vty qualified as V import Linear +import Swarm.Effect (TimeIOC (..)) import Swarm.Game.Achievement.Definitions import Swarm.Game.Achievement.Persistence import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec), cancel, emptyStore, initMachine) @@ -751,10 +752,10 @@ runGameTickUI :: EventM Name AppState () runGameTickUI = runGameTick >> void updateUI -- | Modifies the game state using a fused-effect state action. -zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (Fused.LiftC IO) a -> m a +zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (TimeIOC (Fused.LiftC IO)) a -> m a zoomGameState f = do gs <- use gameState - (gs', a) <- liftIO (Fused.runM (Fused.runState gs f)) + (gs', a) <- liftIO (Fused.runM (runTimeIO (Fused.runState gs f))) gameState .= gs' return a diff --git a/src/Swarm/Util/Effect.hs b/src/Swarm/Util/Effect.hs index 5ba51ceb..12970956 100644 --- a/src/Swarm/Util/Effect.hs +++ b/src/Swarm/Util/Effect.hs @@ -4,6 +4,7 @@ -- fused-effect utilities for Swarm. module Swarm.Util.Effect where +import Control.Algebra import Control.Carrier.Accum.FixedStrict import Control.Carrier.Error.Either (ErrorC (..)) import Control.Carrier.Throw.Either (ThrowC (..), runThrow) diff --git a/swarm.cabal b/swarm.cabal index 12d558b9..0b863548 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -125,6 +125,8 @@ library Swarm.Game.Scenario Swarm.Game.Scenario.Topography.Cell Swarm.Game.Universe + Swarm.Effect + Swarm.Effect.Time Swarm.Log Swarm.TUI.Launch.Controller Swarm.TUI.Launch.Model diff --git a/test/bench/Benchmark.hs b/test/bench/Benchmark.hs index 0e1613ac..b5425718 100644 --- a/test/bench/Benchmark.hs +++ b/test/bench/Benchmark.hs @@ -10,6 +10,7 @@ import Control.Monad (replicateM_) import Control.Monad.Except (runExceptT) import Control.Monad.State (evalStateT, execStateT) import Data.Map qualified as M +import Swarm.Effect (runTimeIO) import Swarm.Game.CESK (emptyStore, initMachine) import Swarm.Game.Display (defaultRobotDisplay) import Swarm.Game.Location @@ -127,7 +128,7 @@ mkGameState robotMaker numRobots = do -- | Runs numGameTicks ticks of the game. runGame :: Int -> GameState -> IO () -runGame numGameTicks = evalStateT (replicateM_ numGameTicks gameTick) +runGame numGameTicks = evalStateT (replicateM_ numGameTicks $ runTimeIO gameTick) main :: IO () main = do diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 0336912d..fb13773c 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -28,6 +28,7 @@ import Data.Text.IO qualified as T import Data.Yaml (ParseException, prettyPrintParseException) import Swarm.Doc.Gen (EditorType (..)) import Swarm.Doc.Gen qualified as DocGen +import Swarm.Effect (runTimeIO) import Swarm.Game.Achievement.Definitions (GameplayAchievement (..)) import Swarm.Game.CESK (emptyStore, getTickNumber, initMachine) import Swarm.Game.Entity (EntityMap, lookupByName) @@ -484,7 +485,7 @@ testScenarioSolutions rs ui = b <- gets badErrorsInLogs when (null b) $ case w of WinConditions (Won _) _ -> return () - _ -> gameTick >> playUntilWin + _ -> runTimeIO gameTick >> playUntilWin noBadErrors :: GameState -> Assertion noBadErrors g = do diff --git a/test/unit/TestUtil.hs b/test/unit/TestUtil.hs index 6b6dca02..23f9ab26 100644 --- a/test/unit/TestUtil.hs +++ b/test/unit/TestUtil.hs @@ -13,6 +13,7 @@ import Control.Monad.State (StateT (..), execState) import Control.Monad.Trans (lift) import Data.Text (Text) import Data.Text qualified as T +import Swarm.Effect import Swarm.Game.CESK import Swarm.Game.Exception import Swarm.Game.Robot @@ -47,7 +48,7 @@ runCESK :: Int -> CESK -> StateT Robot (StateT GameState IO) (Either Text (Value runCESK _ (Up exn _ []) = Left . flip formatExn exn <$> lift (use $ landscape . entityMap) runCESK !steps cesk = case finalValue cesk of Just (v, _) -> return (Right (v, steps)) - Nothing -> stepCESK cesk >>= runCESK (steps + 1) + Nothing -> runTimeIO (stepCESK cesk) >>= runCESK (steps + 1) play :: GameState -> Text -> IO (Either Text (), GameState) play g = either (return . (,g) . Left) playPT . processTerm1 @@ -68,7 +69,7 @@ playUntilDone rid = do w <- use robotMap case w ^? ix rid . to isActive of Just True -> do - void gameTick + void $ runTimeIO gameTick playUntilDone rid Just False -> return $ Right () Nothing -> return $ Left . T.pack $ "The robot with ID " <> show rid <> " is nowhere to be found!"