module Patat.AutoAdvance
( autoAdvance
) where
import Control.Concurrent (forkIO, threadDelay)
import qualified Control.Concurrent.Chan as Chan
import Control.Monad (forever)
import qualified Data.IORef as IORef
import Data.Time (diffUTCTime, getCurrentTime)
import Patat.Presentation (PresentationCommand (..))
autoAdvance
:: Int
-> Chan.Chan PresentationCommand
-> IO (Chan.Chan PresentationCommand)
autoAdvance :: Int -> Chan PresentationCommand -> IO (Chan PresentationCommand)
autoAdvance Int
delaySeconds Chan PresentationCommand
existingChan = do
let delay :: Int
delay = Int
delaySeconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
Chan PresentationCommand
newChan <- IO (Chan PresentationCommand)
forall a. IO (Chan a)
Chan.newChan
IORef UTCTime
latestCommandAt <- UTCTime -> IO (IORef UTCTime)
forall a. a -> IO (IORef a)
IORef.newIORef (UTCTime -> IO (IORef UTCTime)) -> IO UTCTime -> IO (IORef UTCTime)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
ThreadId
_ <- 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
PresentationCommand
cmd <- Chan PresentationCommand -> IO PresentationCommand
forall a. Chan a -> IO a
Chan.readChan Chan PresentationCommand
existingChan
IO UTCTime
getCurrentTime IO UTCTime -> (UTCTime -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef UTCTime -> UTCTime -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef UTCTime
latestCommandAt
Chan PresentationCommand -> PresentationCommand -> IO ()
forall a. Chan a -> a -> IO ()
Chan.writeChan Chan PresentationCommand
newChan PresentationCommand
cmd
ThreadId
_ <- 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
UTCTime
current <- IO UTCTime
getCurrentTime
UTCTime
latest <- IORef UTCTime -> IO UTCTime
forall a. IORef a -> IO a
IORef.readIORef IORef UTCTime
latestCommandAt
let elapsed :: Int
elapsed = NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
1000 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* (UTCTime
current UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
latest) :: Int
if Int
elapsed Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
delay
then do
Chan PresentationCommand -> PresentationCommand -> IO ()
forall a. Chan a -> a -> IO ()
Chan.writeChan Chan PresentationCommand
newChan PresentationCommand
Forward
IORef UTCTime -> UTCTime -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef UTCTime
latestCommandAt UTCTime
current
Int -> IO ()
threadDelay (Int
delay Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
else do
let wait :: Int
wait = Int
delay Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
elapsed
Int -> IO ()
threadDelay (Int
wait Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
Chan PresentationCommand -> IO (Chan PresentationCommand)
forall (m :: * -> *) a. Monad m => a -> m a
return Chan PresentationCommand
newChan