{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module Control.Clock.IO
( newClock
, newClockPico
, newClockMilli
, newClock1ms
, newClock1s
, convClock
, clockWithIO
, clockTimerIO
, voidInput
, module Control.Clock
)
where
import qualified System.Time.Monotonic as T
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async, cancel, link, link2,
race)
import Control.Concurrent.STM (STM, atomically, orElse)
import Control.Concurrent.STM.TBQueue (TBQueue, isEmptyTBQueue,
newTBQueueIO, readTBQueue,
tryPeekTBQueue, tryReadTBQueue,
writeTBQueue)
import Control.Monad (forever, unless, when)
import Data.Time.Clock (DiffTime,
diffTimeToPicoseconds,
picosecondsToDiffTime)
import Data.Void (Void)
import GHC.Stack (HasCallStack)
import Control.Clock
newClock :: DiffTime -> IO (Clock IO)
newClock intv = convClock intv <$> T.newClock
newClockPico :: Integer -> IO (Clock IO)
newClockPico = newClock . picosecondsToDiffTime
newClockMilli :: Integer -> IO (Clock IO)
newClockMilli ms = newClockPico (1000000000 * ms)
newClock1ms :: IO (Clock IO)
newClock1ms = newClockMilli 1
newClock1s :: IO (Clock IO)
newClock1s = newClockMilli 1000
checkNonNeg :: (HasCallStack, Num a, Ord a, Show a) => a -> a
checkNonNeg n =
if n >= 0 then n else error $ "must be non-negative: " ++ show n
checkPos :: (HasCallStack, Num a, Ord a, Show a) => a -> a
checkPos n = if n > 0 then n else error $ "must be positive: " ++ show n
convClock :: DiffTime -> T.Clock -> Clock IO
convClock intv c =
let r = diffTimeToPicoseconds $ checkPos intv
c' = Clock
{ clockNow = (`div` r) <$> clockNowPico c
, clockDelay = \d -> when (d > 0) $ do
remain <- (`rem` r) <$> clockNowPico c
let t = r * fromIntegral d * 16 `div` 15 - remain
clockDelayPico t
, clockWith = clockWithIO c'
, clockTimer = clockTimerIO c'
}
in c'
clockNowPico :: T.Clock -> IO Integer
clockNowPico c = diffTimeToPicoseconds <$> T.clockGetTime c
clockDelayPico :: Integer -> IO ()
clockDelayPico d = T.delay $ picosecondsToDiffTime $ checkNonNeg d
writeTBQueue' :: HasCallStack => TBQueue a -> a -> STM ()
writeTBQueue' q r = do
e <- isEmptyTBQueue q
unless e $ error "failed to assert non-blocking write on TBQueue"
writeTBQueue q r
clockWithIO :: Clock IO -> IO a -> IO (Clocked IO a)
clockWithIO clock action = do
qi <- newTBQueueIO 1
qo <- newTBQueueIO 1
qt <- newTBQueueIO 1
actionThread <- async $ forever $ do
atomically $ do
readTBQueue qi
writeTBQueue' qi ()
r <- action
atomically $ do
writeTBQueue' qo r
readTBQueue qi
link actionThread
tickThread <- async $ forever $ do
t <- clockTick clock 1
atomically $ do
_ <- tryReadTBQueue qt
writeTBQueue' qt t
link tickThread
link2 actionThread tickThread
let fin = cancel actionThread >> cancel tickThread
action' = do
atomically $ tryPeekTBQueue qi >>= \case
Nothing -> writeTBQueue qi ()
Just () -> pure ()
atomically $ do
(Right <$> readTBQueue qo) `orElse` (Left <$> readTBQueue qt)
pure (Clocked action' fin)
clockTimerIO :: Clock IO -> TickDelta -> IO a -> IO (Either Tick a)
clockTimerIO c d = race (clockTick c d)
voidInput :: IO Void
voidInput = forever $ threadDelay maxBound