feat: add TimeEffect effect for getting current time

src/Swarm/Game/Step.hs

@@ -102,7 +102,7 @@ import Swarm.Language.Typed (Typed (..))
 import Swarm.Language.Value
 import Swarm.Log
 import Swarm.Util hiding (both)
-import Swarm.Util.Effect (throwToMaybe)
+import Swarm.Util.Effect (TimeEffect, getNow, throwToMaybe)
 import Swarm.Util.WindowedCounter qualified as WC
 import System.Clock (TimeSpec)
 import Witch (From (from), into)
@@ -112,7 +112,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 TimeEffect sig m) => m Bool
 gameTick = do
   wakeUpRobotsDoneSleeping
   active <- use activeRobots
@@ -160,7 +160,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 TimeEffect sig m) => m ()
 finishGameTick =
   use (temporal . gameStep) >>= \case
     WorldTick -> pure ()
@@ -185,15 +185,15 @@ 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 TimeEffect sig m) => IS.IntSet -> m ()
 runRobotIDs robotNames = forM_ (IS.toList robotNames) $ \rn -> do
   mr <- uses robotMap (IM.lookup rn)
   forM_ mr (stepOneRobot rn)
  where
   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 TimeEffect sig m) => SingleStep -> RID -> IS.IntSet -> m Bool
 singleStep ss focRID robotSet = do
   let (preFoc, focusedActive, postFoc) = IS.splitMember focRID robotSet
   case ss of
@@ -287,7 +287,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 TimeEffect sig m, Has (Lift IO) sig m) =>
   EntityMap ->
   GameState ->
   WinStatus ->
@@ -377,7 +377,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 TimeEffect 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)
@@ -403,7 +407,11 @@ hypotheticalRobot c =
     mempty
 
 evaluateCESK ::
-  (Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) =>
+  ( Has TimeEffect sig m
+  , Has (Throw Exn) sig m
+  , Has (State GameState) sig m
+  , Has (Lift IO) sig m
+  ) =>
   CESK ->
   m Value
 evaluateCESK cesk = do
@@ -413,7 +421,8 @@ evaluateCESK cesk = do
   evalState r . runCESK $ cesk
 
 runCESK ::
-  ( Has (Lift IO) sig m
+  ( Has TimeEffect sig m
+  , Has (Lift IO) sig m
   , Has (Throw Exn) sig m
   , Has (State GameState) sig m
   , Has (State Robot) sig m
@@ -516,7 +525,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 TimeEffect sig m) => Robot -> m Robot
 tickRobot r = do
   steps <- use $ temporal . robotStepsPerTick
   tickRobotRec (r & activityCounts . tickStepBudget .~ steps)
@@ -525,7 +534,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 TimeEffect sig m) => Robot -> m Robot
 tickRobotRec r = do
   time <- use $ temporal . ticks
   case wantsToStep time r && (r ^. runningAtomic || r ^. activityCounts . tickStepBudget > 0) of
@@ -534,7 +543,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 TimeEffect 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")
@@ -585,7 +594,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 TimeEffect sig m) =>
   Value ->
   SKpair ->
   -- | the unreliable computation
@@ -610,7 +619,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 TimeEffect sig m) => CESK -> m CESK
 stepCESK cesk = case cesk of
   ------------------------------------------------------------
   -- Evaluation
@@ -959,7 +968,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 TimeEffect 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
@@ -1017,7 +1026,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 TimeEffect sig m, Has (Lift IO) sig m) =>
   Const ->
   [Value] ->
   Store ->
@@ -2532,7 +2541,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 TimeEffect sig m) => GrabbingCmd -> m Entity
   doGrab cmd = do
     let verb = verbGrabbingCmd cmd
         verbed = verbedGrabbingCmd cmd

src/Swarm/Game/Step/Combustion.hs

@@ -19,7 +19,6 @@ 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
@@ -40,10 +39,11 @@ import Swarm.Language.Pipeline.QQ (tmQ)
 import Swarm.Language.Syntax
 import Swarm.Language.Text.Markdown qualified as Markdown
 import Swarm.Util hiding (both)
+import Swarm.Util.Effect (TimeEffect, getNow)
 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 TimeEffect 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

@@ -112,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

@@ -114,6 +114,7 @@ import Swarm.TUI.Model.UI
 import Swarm.TUI.View.Objective qualified as GR
 import Swarm.TUI.View.Util (generateModal)
 import Swarm.Util hiding (both, (<<.=))
+import Swarm.Util.Effect (TimeEffectIO (..))
 import Swarm.Version (NewReleaseFailure (..))
 import System.Clock
 import System.FilePath (splitDirectories)
@@ -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 (TimeEffectIO (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 (runTimeEffectIO (Fused.runState gs f)))
   gameState .= gs'
   return a
 

src/Swarm/Util/Effect.hs

@@ -1,20 +1,30 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE UndecidableInstances #-}
+
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
 --
 -- 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)
 import Control.Effect.Throw
 import Control.Monad ((<=<), (>=>))
+import Control.Monad.Trans (MonadIO (liftIO))
 import Control.Monad.Trans.Except (ExceptT)
 import Data.Either.Extra (eitherToMaybe)
+import Data.Kind (Type)
 import Data.Sequence (Seq)
 import Data.Sequence qualified as Seq
 import Swarm.Game.Failure (SystemFailure)
 import Swarm.Language.Pretty (prettyString)
+import System.Clock (Clock (Monotonic), TimeSpec, getTime)
 import Witherable
 
 -- | Transform a @Throw e1@ constraint into a @Throw e2@ constraint,
@@ -78,3 +88,18 @@ forMW = flip traverseW
 
 simpleErrorHandle :: ThrowC SystemFailure IO a -> IO a
 simpleErrorHandle = either (fail . prettyString) pure <=< runThrow
+
+-- | Effect for things related to time
+data TimeEffect (m :: Type -> Type) k where
+  GetNow :: TimeEffect m TimeSpec
+
+getNow :: Has TimeEffect sig m => m TimeSpec
+getNow = send GetNow
+
+newtype TimeEffectIO m a = TimeEffectIO {runTimeEffectIO :: m a}
+  deriving newtype (Applicative, Functor, Monad, MonadIO)
+
+instance (MonadIO m, Algebra sig m) => Algebra (TimeEffect :+: sig) (TimeEffectIO m) where
+  alg hdl sig ctx = case sig of
+    L GetNow -> (<$ ctx) <$> liftIO (System.Clock.getTime System.Clock.Monotonic)
+    R other -> TimeEffectIO (alg (runTimeEffectIO . hdl) other ctx)