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

{-|
    Behn: Timer Driver
-}

module Urbit.Vere.Behn (behn, DriverApi(..), behn') where

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

import Urbit.King.App  (HasKingId(..), HasPierEnv(..))
import Urbit.Noun.Time (Wen)
import Urbit.Timer     (Timer)

import qualified Urbit.Noun.Time as Time
import qualified Urbit.Timer     as Timer


-- Behn Stuff ------------------------------------------------------------------

behn' :: HasPierEnv e => RIO e ([Ev], RAcquire e (DriverApi BehnEf))
behn' = do
  env <- ask
  pure ([bornEv (fromIntegral (env ^. kingIdL))], runDriver env)
 where
  runDriver env = do
    ventQ :: TQueue EvErr <- newTQueueIO
    diOnEffect <- liftAcquire (behn env (writeTQueue ventQ))
    let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
    pure (DriverApi {..})

bornEv :: KingId -> Ev
bornEv king = EvBlip $ BlipEvBehn $ BehnEvBorn (king, ()) ()

wakeEv :: Ev
wakeEv = EvBlip $ BlipEvBehn $ BehnEvWake () ()

sysTime = view Time.systemTime

wakeErr :: WorkError -> IO ()
wakeErr _ = pure ()

behn
  :: HasKingId e
  => e
  -> (EvErr -> STM ())
  -> Acquire (BehnEf -> IO ())
behn env enqueueEv = runBehn
  where
    king = fromIntegral (env ^. kingIdL)

    runBehn :: Acquire (BehnEf -> IO ())
    runBehn = do
        tim <- mkAcquire Timer.init Timer.stop
        pure (runRIO env . 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 (EvErr wakeEv wakeErr))