{-# 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    TVar Bool
tvRunning     <- forall a. a -> IO (TVar a)
newTVarIO Bool
False
    TVar Int
tvInterval    <- forall a. a -> IO (TVar a)
newTVarIO Int
1000
    (Event ()
tTick, Handler ()
fire) <- forall a. IO (Event a, Handler a)
newEvent
    
    IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            Bool
b <- forall a. TVar a -> STM a
readTVar TVar Bool
tvRunning
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b) forall a. STM a
retry
        Int
wait <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
readTVar TVar Int
tvInterval
        Handler ()
fire ()
        Int -> IO ()
threadDelay (Int
wait forall a. Num a => a -> a -> a
* Int
1000)
    
    let tRunning :: GetSet Bool Bool
tRunning  = forall a. TVar a -> GetSet a a
fromTVar TVar Bool
tvRunning
        tInterval :: GetSet Int Int
tInterval = forall a. TVar a -> GetSet a a
fromTVar TVar Int
tvInterval 
    
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = 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 = 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 = 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 = 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 :: forall a. TVar a -> GetSet a a
fromTVar TVar a
var = (forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
readTVar TVar a
var, forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall x i o. (x -> GetSet i o) -> ReadWriteAttr x i o
fromGetSet x -> GetSet i o
f = forall x o i.
(x -> UI o) -> (i -> x -> UI ()) -> ReadWriteAttr x i o
mkReadWriteAttr (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> GetSet i o
f) (\i
i x
x -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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
-}