{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}

module Graphics.UI.Threepenny.Timer (
    -- * Synopsis
    -- | Implementation of a simple timer which runs on the server-side.
    --
    -- NOTE: The timer may be rather wobbly unless you compile
    -- with the @-threaded@ option.
    
    -- * Documentation
    Timer, timer,
    interval, running, tick, start, stop,
    ) where

import Data.Typeable
import Control.Monad (when, forever, void)
import Control.Concurrent
import Control.Concurrent.STM
import Reactive.Threepenny

import Graphics.UI.Threepenny.Core


data Timer = Timer
    { Timer -> GetSet Bool Bool
tRunning  :: GetSet Bool Bool
    , Timer -> GetSet Int Int
tInterval :: GetSet Int Int   -- in ms
    , Timer -> Event ()
tTick     :: Event ()
    } deriving (Typeable)

-- | Create a new timer
timer :: UI Timer
timer :: UI Timer
timer = IO Timer -> UI Timer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Timer -> UI Timer) -> IO Timer -> UI Timer
forall a b. (a -> b) -> a -> b
$ do
    TVar Bool
tvRunning     <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
    TVar Int
tvInterval    <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
1000
    (Event ()
tTick, Handler ()
fire) <- IO (Event (), Handler ())
forall a. IO (Event a, Handler a)
newEvent
    
    IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
tvRunning
            Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b) STM ()
forall a. STM a
retry
        Int
wait <- STM Int -> IO Int
forall a. STM a -> IO a
atomically (STM Int -> IO Int) -> STM Int -> IO Int
forall a b. (a -> b) -> a -> b
$ TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
tvInterval
        Handler ()
fire ()
        Int -> IO ()
threadDelay (Int
wait Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
    
    let tRunning :: GetSet Bool Bool
tRunning  = TVar Bool -> GetSet Bool Bool
forall a. TVar a -> GetSet a a
fromTVar TVar Bool
tvRunning
        tInterval :: GetSet Int Int
tInterval = TVar Int -> GetSet Int Int
forall a. TVar a -> GetSet a a
fromTVar TVar Int
tvInterval 
    
    Timer -> IO Timer
forall (m :: * -> *) a. Monad m => a -> m a
return (Timer -> IO Timer) -> Timer -> IO Timer
forall a b. (a -> b) -> a -> b
$ Timer :: GetSet Bool Bool -> GetSet Int Int -> Event () -> Timer
Timer {GetSet Bool Bool
GetSet Int Int
Event ()
tInterval :: GetSet Int Int
tRunning :: GetSet Bool Bool
tTick :: Event ()
tTick :: Event ()
tInterval :: GetSet Int Int
tRunning :: GetSet Bool Bool
..}

-- | Timer event.
tick :: Timer -> Event ()
tick :: Timer -> Event ()
tick = Timer -> Event ()
tTick

-- | Timer interval in milliseconds.
interval :: Attr Timer Int
interval :: Attr Timer Int
interval = (Timer -> GetSet Int Int) -> Attr Timer Int
forall x i o. (x -> GetSet i o) -> ReadWriteAttr x i o
fromGetSet Timer -> GetSet Int Int
tInterval

-- | Whether the timer is running or not.
running :: Attr Timer Bool
running :: Attr Timer Bool
running = (Timer -> GetSet Bool Bool) -> Attr Timer Bool
forall x i o. (x -> GetSet i o) -> ReadWriteAttr x i o
fromGetSet Timer -> GetSet Bool Bool
tRunning

-- | Start the timer.
start :: Timer -> UI ()
start :: Timer -> UI ()
start = Attr Timer Bool -> Bool -> Timer -> UI ()
forall x i o. ReadWriteAttr x i o -> i -> x -> UI ()
set' Attr Timer Bool
running Bool
True

-- | Stop the timer.
stop :: Timer -> UI ()
stop :: Timer -> UI ()
stop = Attr Timer Bool -> Bool -> Timer -> UI ()
forall x i o. ReadWriteAttr x i o -> i -> x -> UI ()
set' Attr Timer Bool
running Bool
False

fromTVar :: TVar a -> GetSet a a
fromTVar :: TVar a -> GetSet a a
fromTVar TVar a
var = (STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> IO a) -> STM a -> IO a
forall a b. (a -> b) -> a -> b
$ TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
var, STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (a -> STM ()) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
var)

type GetSet i o = (IO o, i -> IO ())

fromGetSet :: (x -> GetSet i o) -> ReadWriteAttr x i o
fromGetSet :: (x -> GetSet i o) -> ReadWriteAttr x i o
fromGetSet x -> GetSet i o
f = (x -> UI o) -> (i -> x -> UI ()) -> ReadWriteAttr x i o
forall x o i.
(x -> UI o) -> (i -> x -> UI ()) -> ReadWriteAttr x i o
mkReadWriteAttr (IO o -> UI o
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO o -> UI o) -> (x -> IO o) -> x -> UI o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetSet i o -> IO o
forall a b. (a, b) -> a
fst (GetSet i o -> IO o) -> (x -> GetSet i o) -> x -> IO o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> GetSet i o
f) (\i
i x
x -> IO () -> UI ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> UI ()) -> IO () -> UI ()
forall a b. (a -> b) -> a -> b
$ GetSet i o -> i -> IO ()
forall a b. (a, b) -> b
snd (x -> GetSet i o
f x
x) i
i)


{-----------------------------------------------------------------------------
    Small test
------------------------------------------------------------------------------}
{-

testTimer = do
    t <- timer
    void $ register (tick t) $ const $ putStr "Hello"
    return t
        # set interval 1000
        # set running True
-}