mirror of
https://github.com/urbit/shrub.git
synced 2024-12-21 09:51:36 +03:00
60 lines
1.5 KiB
Haskell
60 lines
1.5 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.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
|
|
|
|
bornFailed :: e -> WorkError -> IO ()
|
|
bornFailed env _ = runRIO env $ do
|
|
pure () -- TODO Ship is fucked. Kill it?
|
|
|
|
wakeErr :: WorkError -> IO ()
|
|
wakeErr _ = pure ()
|
|
|
|
behn
|
|
:: HasKingId e => e -> (EvErr -> STM ()) -> ([EvErr], Acquire (BehnEf -> IO ()))
|
|
behn env enqueueEv =
|
|
(initialEvents, runBehn)
|
|
where
|
|
king = fromIntegral (env ^. kingIdL)
|
|
|
|
initialEvents = [EvErr (bornEv king) (bornFailed env)]
|
|
|
|
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))
|