vimus-0.1.0: src/Timer.hs

module Timer (
  Timer
, startTimer
, stopTimer
, getPOSIXTime
) where

import           Control.Concurrent
import           Control.Monad (when)
import           Data.Time.Clock.POSIX

newtype Timer = Timer (MVar Bool)

-- | Start a timer.
--
-- Call given action repeatedly with the passed time since the timer has been
-- started, adjusted by a given offset.  The action is called every second;
-- whenever (passed + offset) is close to (truncate $ passed + offset).
startTimer :: POSIXTime -- ^ start time
           -> Double    -- ^ offset in seconds
           -> (Double -> IO ())
           -> IO Timer
startTimer t0 s0 action = do
  m <- newMVar True
  _ <- forkIO $ run t0 (realToFrac s0) (action . realToFrac) m
  return (Timer m)


-- | Run until False is put into the MVar.
run :: POSIXTime -> POSIXTime -> (POSIXTime -> IO ()) -> MVar Bool -> IO ()
run t0 s0 action m = go
  where
    go = do
      t1 <- getPOSIXTime
      let s_current = s0 + (t1 - t0)
          -- Increase s_next to the next full second.
          s_next = fromIntegral (ceiling (s_current + 0.001) :: Int)

      sleep (s_next - s_current)
      isRunning <- takeMVar m
      when (isRunning) $ do
        -- add 0.001 as a tiebreaker to make sure that `truncate` will work as
        -- expected
        action (s_next + 0.001)
        putMVar m isRunning
        go

    -- | Like `threadDelay`, but takes the delay in seconds.
    sleep :: POSIXTime -> IO ()
    sleep s = threadDelay $ round (s * 1000000)

-- | Stop timer; block until the timer is stopped.
stopTimer :: Timer -> IO ()
stopTimer (Timer m) = takeMVar m >> putMVar m False