--------------------------------------------------------------------------------
module Patat.AutoAdvance
    ( maybeAutoAdvance
    , autoAdvance
    ) where


--------------------------------------------------------------------------------
import           Control.Concurrent      (threadDelay)
import qualified Control.Concurrent.Async as Async
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 (..))


--------------------------------------------------------------------------------
-- | Utility to make auto advancing optional.
maybeAutoAdvance
    :: Maybe Int
    -> Chan.Chan PresentationCommand
    -> (Chan.Chan PresentationCommand -> IO a)
    -> IO a
maybeAutoAdvance :: forall a.
Maybe Int
-> Chan PresentationCommand
-> (Chan PresentationCommand -> IO a)
-> IO a
maybeAutoAdvance Maybe Int
Nothing             Chan PresentationCommand
chan Chan PresentationCommand -> IO a
f = Chan PresentationCommand -> IO a
f Chan PresentationCommand
chan
maybeAutoAdvance (Just Int
delaySeconds) Chan PresentationCommand
chan Chan PresentationCommand -> IO a
f = Int
-> Chan PresentationCommand
-> (Chan PresentationCommand -> IO a)
-> IO a
forall a.
Int
-> Chan PresentationCommand
-> (Chan PresentationCommand -> IO a)
-> IO a
autoAdvance Int
delaySeconds Chan PresentationCommand
chan Chan PresentationCommand -> IO a
f


--------------------------------------------------------------------------------
-- | This function takes an existing channel for presentation commands
-- (presumably coming from human input) and creates a new one that /also/ sends
-- a 'Forward' command if nothing happens for N seconds.
autoAdvance
    :: Int
    -> Chan.Chan PresentationCommand
    -> (Chan.Chan PresentationCommand -> IO a)
    -> IO a
autoAdvance :: forall a.
Int
-> Chan PresentationCommand
-> (Chan PresentationCommand -> IO a)
-> IO a
autoAdvance Int
delaySeconds Chan PresentationCommand
existingChan Chan PresentationCommand -> IO a
f = do
    let delay :: Int
delay = Int
delaySeconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000  -- We are working with ms in this function

    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

    -- This is a thread that copies 'existingChan' to 'newChan', and writes
    -- whenever the latest command was to 'latestCommandAt'.
    (IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
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 a b. IO a -> (a -> IO b) -> IO b
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) IO Any -> (Async Any -> IO a) -> IO a
forall a b. IO a -> (Async a -> IO b) -> IO b
`Async.withAsync` \Async Any
_ ->

        -- This is a thread that waits around 'delay' seconds and then checks if
        -- there's been a more recent command.  If not, we write a 'Forward'.
        (IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
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 b. Integral b => NominalDiffTime -> b
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)) IO Any -> (Async Any -> IO a) -> IO a
forall a b. IO a -> (Async a -> IO b) -> IO b
`Async.withAsync` \Async Any
_ ->

        -- Continue main thread.
        Chan PresentationCommand -> IO a
f Chan PresentationCommand
newChan