{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
module Reflex.Time.UTCTime (
    TimeBits, utc2TimeBits, afterTime, atTime, time
  ) where

import Control.Concurrent
import Control.Concurrent.EQueue
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Trans
import qualified Control.Time as T
import Data.Bits
import Data.Dependent.Sum (DSum ((:=>)))
import Data.Functor.Identity
import Data.Semigroup
import Data.Time
import Data.Time.Clock.POSIX
import qualified GHC.Event as GHC
import Reflex
import Reflex.Host.Class

-- | TimeBits is a list, each step containing the value of the time since the POSIX epoc,
--   shifted right one more then the last.
--   By using this, one can wait on the time changing more then a desired picosecond*2^Nat amount.
--   To get a precise wait, one may then have to wait again on a finer time counter.
--   The head of the list stores the full time as picoseconds since the unix epoch.
type TimeBits t = (Dynamic t UTCTime, [Dynamic t Integer])

-- | Create a (lazy) list of Dynamics, each holding a the value of the UTCTime right-shifted as many bits
--   as there are elements before it in the list.
utc2TimeBits :: forall t. (Functor (Dynamic t)) => Dynamic t UTCTime -> TimeBits t
utc2TimeBits dt = (dt, [timeSlice b <$> dt | b <- [0..]])

-- | Get the value of the UTCTime right-shifted the specified number of bits.
--   The conversion to Integer could be shared but would prevent code reuse.
timeSlice :: Int -> UTCTime -> Integer
timeSlice b = (`shiftR` b) . floor . (* 10^(12::Int)) . utcTimeToPOSIXSeconds

-- | Efficiently compare a target time with a timebits, becoming True at the chosen time.
--   O(log2 (then - now)) tests against the time while waiting to become true.
--
--   We find a list of the postfixs of the time that show the target time isn't already past.
--   The list should be the length of the log of the difference of the times, making this efficient.
--
--   This should be leap second resilient.
afterTime :: forall t m. (Reflex t, MonadHold t m, MonadFix m) => TimeBits t -> UTCTime -> m (Dynamic t Bool)
afterTime (curTime, tbs) tgt = do
    n <- sample . current $ curTime
    case tgt <= n of
      True -> return . constDyn $ True
      False -> do
        prefix <- dissimilarPrefix 0 [] tbs
        -- onceE to avoid reprocessing once True.
        holdDyn False =<< headE =<< (allGreater $ prefix)
  where
    -- Check that each step of the time is now greater then or equal to the time,
    -- switching promptly to the next step in the chain each time,
    -- and firing  when the time is >=.
    -- All finer events fire when a corser event fires, so if we not are >= a more precise event, we'll
    -- pass thought it on this step, and go directly to the next we're not >= to.
    allGreater :: [Event t Integer] -> m (Event t Bool)
    allGreater [] =
      -- Since TimeBits changed, the curTime component had to fire.
      -- Thus we can generatea firing event off it.
      -- Since we got here, we know nothing in the list differs so we're definately True.
      return . fmap (const True) . updated $ curTime
    -- Process each potential difference one step at a time, moving to the next step when it has become True.
    allGreater (cstep:t) = do
      -- We need what the event for the next step would be.
      nstep <- allGreater t
      -- whenever this step fires, we want to become that next step.
      switchHoldPromptly never . fmap (const nstep) $ cstep

    -- Find the prefix of time bits to a time >=
    dissimilarPrefix :: (Reflex t, MonadSample t m1)
                     => Int -> [Event t Integer] -> [Dynamic t Integer] -> m1 [Event t Integer]
    dissimilarPrefix _ _ [] = error "Unpossible, its an infinite list!"
    dissimilarPrefix step pre (cur:rest) = do
      thisStep <- sample . current $ cur
      let whatThisStepShouldBe = timeSlice step tgt
      if thisStep >= whatThisStepShouldBe
        then return pre
        else 
        let fireWhenTargetOrGreater = ffilter (\tStep -> tStep >= whatThisStepShouldBe) . updated $ cur
        in dissimilarPrefix (step+1) (fireWhenTargetOrGreater:pre) rest

-- | Efficiently fires an event at the target time, or immediately after.
--   Fires instantly if the time is already past.
--   
--   Does not take into account leap seconds.
atTime :: (Reflex t, EQueue eq, MonadReflexCreateTrigger t m)
        => eq (DSum (EventTrigger t) Identity) -> UTCTime -> m (Event t ())
atTime eq theTime = do
  e <- newEventWithTrigger $ \et -> do
    tm <- GHC.getSystemTimerManager
    now <- getCurrentTime
    (enqueue, dereg) <- registerQueued eq
    tk <- GHC.registerTimeout tm (max 0 . ceiling $ (theTime `diffUTCTime` now)*(10^(6::Int))) (enqueue (et :=> Identity ()))
    return $ dereg >> GHC.unregisterTimeout tm tk
  return e

-- | Provides a Dynamic UTCTime signal at the desired resolution.
--   
--   Slight drift in the form of more time then the request difference between timesteps is expected.
time :: (Reflex t, EQueue eq, MonadFix m, MonadIO m, MonadHold t m, MonadReflexCreateTrigger t m)
     => eq (DSum (EventTrigger t) Identity) -> DiffTime -> m (Dynamic t UTCTime)
time eq dt = do
  e <- newEventWithTrigger $ \et -> do
    (enqueue, dereg) <- registerSemi eq ((:=>) et . Identity . getMax)
    t <- forkIO . forever $ do
           getCurrentTime >>= enqueue . Max
           -- This drifts. Not considered a problem for its intended use.
           T.delay dt
    return $ dereg >> killThread t
  now <- liftIO getCurrentTime
  holdDyn now e