urbit/pkg/hs/urbit-king/lib/Urbit/Vere/Behn.hs

{-|
    Behn: Timer Driver
-}

module Urbit.Vere.Behn (behn) where

import Urbit.Arvo            hiding (Behn)
import Urbit.Prelude
import Urbit.Vere.Pier.Types

import Urbit.King.App (HasKingId(..))
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 :: HasKingId e => e -> QueueEv -> ([Ev], Acquire (EffCb e BehnEf))
behn env enqueueEv =
    (initialEvents, runBehn)
  where
    king = fromIntegral (env ^. kingIdL)

    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)