mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-25 07:52:59 +03:00
49 lines
1.4 KiB
Haskell
49 lines
1.4 KiB
Haskell
|
module Urbit.Timer ( Timer, init, stop, start
|
||
|
, Sys.getSystemTime, sysTimeGapMicroSecs
|
||
|
) where
|
||
|
|
||
|
import Prelude hiding (init)
|
||
|
import Control.Lens
|
||
|
import Data.IORef
|
||
|
|
||
|
import Control.Concurrent.MVar (MVar, takeMVar, newEmptyMVar, putMVar)
|
||
|
import Control.Monad (void, when)
|
||
|
|
||
|
import qualified GHC.Event as Ev
|
||
|
import qualified Data.Time.Clock.System as Sys
|
||
|
|
||
|
|
||
|
-- Timer Stuff -----------------------------------------------------------------
|
||
|
|
||
|
data Timer = Timer
|
||
|
{ bState :: IORef (Maybe Ev.TimeoutKey)
|
||
|
, bManager :: Ev.TimerManager
|
||
|
}
|
||
|
|
||
|
init :: IO Timer
|
||
|
init = do
|
||
|
st <- newIORef Nothing
|
||
|
man <- Ev.getSystemTimerManager
|
||
|
pure (Timer st man)
|
||
|
|
||
|
sysTimeGapMicroSecs :: Sys.SystemTime -> Sys.SystemTime -> Int
|
||
|
sysTimeGapMicroSecs (Sys.MkSystemTime xSec xNs) (Sys.MkSystemTime ySec yNs) =
|
||
|
(+) (1_000_000 * fromIntegral (ySec - xSec))
|
||
|
((fromIntegral yNs - fromIntegral xNs) `quot` 1000)
|
||
|
|
||
|
start :: Timer -> Sys.SystemTime -> IO () -> IO ()
|
||
|
start timer@(Timer vSt man) time cb = do
|
||
|
let fire = cb >> stop timer
|
||
|
stop timer
|
||
|
now <- Sys.getSystemTime
|
||
|
let sleep = sysTimeGapMicroSecs now time
|
||
|
if (sleep <= 0) then fire else do
|
||
|
key <- Ev.registerTimeout man sleep fire
|
||
|
atomicWriteIORef vSt $! Just key
|
||
|
|
||
|
stop :: Timer -> IO ()
|
||
|
stop (Timer vSt man) =
|
||
|
atomicModifyIORef' vSt (Nothing,) >>= \case
|
||
|
Just key -> Ev.unregisterTimeout man key
|
||
|
Nothing -> pure ()
|