src/RMCA/IOClockworks.hs

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2
   3 module RMCA.IOClockworks ( IOMetronome
   4                          , mkClockGeneric
   5                          , mkClock
   6                          , mkClockDebug
   7                          , stopIOMetronome
   8                          , IOTick
   9                          , newIOTick
  10                          , tickIOTick
  11                          ) where
  12
  13 import Control.Concurrent
  14 import Control.Monad
  15 import Data.ReactiveValue
  16 import FRP.Yampa          (DTime)
  17
  18 -- A reactive value carrying unit that ticks at a regular pace. On a
  19 -- tick, it executes IO actions attached to it with
  20 -- reactiveValueOnCanRead.
  21 newtype IOMetronome = IOMetronome (MVar [IO ()], ThreadId)
  22
  23 instance ReactiveValueRead IOMetronome () IO where
  24   reactiveValueRead _ = return ()
  25   reactiveValueOnCanRead (IOMetronome (mvar,_)) io =
  26     modifyMVar_ mvar (\cbs -> return (cbs ++ [io]))
  27
  28 -- Make a clock that will execute any IO when it updates.
  29 mkClockGeneric :: IO () -> DTime -> IO IOMetronome
  30 mkClockGeneric io d = do
  31   n <- newMVar []
  32   tid <- forkIO $ forever $  do
  33     threadDelay dInt
  34     readMVar n >>= sequence_
  35     io
  36   return $ IOMetronome (n, tid)
  37   where dInt = floor $ d * 1000
  38
  39 -- Ticking clock in the IO monad, sending callbacks every t milliseconds.
  40 mkClock :: DTime -> IO IOMetronome
  41 mkClock = mkClockGeneric (return ())
  42
  43 -- For debugging purposes.
  44 mkClockDebug :: DTime -> IO IOMetronome
  45 mkClockDebug = mkClockGeneric (putStrLn "Ping!")
  46
  47 stopIOMetronome :: IOMetronome -> IO ()
  48 stopIOMetronome (IOMetronome (_,tid)) = killThread tid
  49
  50 newtype IOTick = IOTick (MVar [IO ()])
  51
  52 newIOTick :: IO IOTick
  53 newIOTick = fmap IOTick (newMVar [])
  54
  55 tickIOTick :: IOTick -> IO ()
  56 tickIOTick (IOTick mvar) = readMVar mvar >>= sequence_
  57
  58 instance ReactiveValueRead IOTick () IO where
  59   reactiveValueRead _ = return ()
  60   reactiveValueOnCanRead (IOTick mvar) io =
  61     modifyMVar_ mvar (\cbs -> return (cbs ++ [io]))