mirror of
https://github.com/urbit/shrub.git
synced 2024-12-21 01:41:37 +03:00
49 lines
1.2 KiB
Haskell
49 lines
1.2 KiB
Haskell
{-|
|
|
Behn: Timer Driver
|
|
-}
|
|
|
|
module Urbit.Vere.Behn (behn) where
|
|
|
|
import Urbit.Arvo hiding (Behn)
|
|
import Urbit.Prelude
|
|
import Urbit.Vere.Pier.Types
|
|
|
|
import Urbit.Time (Wen)
|
|
import Urbit.Timer (Timer)
|
|
|
|
import qualified Urbit.Time as Time
|
|
import qualified Urbit.Timer as Timer
|
|
|
|
|
|
-- Behn Stuff ------------------------------------------------------------------
|
|
|
|
bornEv :: KingId -> Ev
|
|
bornEv king = EvBlip $ BlipEvBehn $ BehnEvBorn (king, ()) ()
|
|
|
|
wakeEv :: Ev
|
|
wakeEv = EvBlip $ BlipEvBehn $ BehnEvWake () ()
|
|
|
|
sysTime = view Time.systemTime
|
|
|
|
behn :: KingId -> QueueEv -> ([Ev], Acquire (EffCb e BehnEf))
|
|
behn king enqueueEv =
|
|
(initialEvents, runBehn)
|
|
where
|
|
initialEvents = [bornEv king]
|
|
|
|
runBehn :: Acquire (EffCb e BehnEf)
|
|
runBehn = do
|
|
tim <- mkAcquire Timer.init Timer.stop
|
|
pure (handleEf tim)
|
|
|
|
handleEf :: Timer -> BehnEf -> RIO e ()
|
|
handleEf b = io . \case
|
|
BehnEfVoid v -> absurd v
|
|
BehnEfDoze (i, ()) mWen -> do
|
|
when (i == king) (doze b mWen)
|
|
|
|
doze :: Timer -> Maybe Wen -> IO ()
|
|
doze tim = \case
|
|
Nothing -> Timer.stop tim
|
|
Just t -> Timer.start tim (sysTime t) $ atomically (enqueueEv wakeEv)
|