Add TimeEffect effect for getting current time (#1620)

fixes #1502

Add TimeEffect effect for getting current time.

src/Swarm/Effect.hs

@@ -0,0 +1,6 @@
+module Swarm.Effect (
+  module X,
+)
+where
+
+import Swarm.Effect.Time as X

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)

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

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.

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

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
 

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)

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

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

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

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!"