{-# LANGUAGE TupleSections, RecursiveDo, RankNTypes #-}
module SimpleH.Reactive.Time (
  -- * Unambiguous times
  Time,
  timeVal,

  -- * Time utilities
  Seconds,
  timeIO,waitTill,currentTime
  ) where

import SimpleH
import Control.Concurrent
import SimpleH.Reactive.TimeVal
import System.IO.Unsafe
import Data.IORef
import System.Clock

-- |A type wrappers for timestamps that can be compared unambiguously
data Time t = Time (TimeVal t -> TimeVal t) (TimeVal t -> TimeVal t)
instance (Eq t,Show t) => Show (Time t) where show = show . timeVal
instance Ord t => Eq (Time t) where
  a == b = compare a b == EQ
instance Ord t => Ord (Time t) where
  compare ~(Time fa fa') ~(Time fb fb') =
    cmp fa fb' `unamb` invertOrd (cmp fb fa')
    where cmp f f' = compare a (f'$!a)
            where a = f maxBound
-- |The Time semigroup where @ta + tb == max ta tb@
instance Ord t => Semigroup (Time t) where
  ~(Time fa fa') + ~(Time fb fb') = Time (mapT max fa fb) (mapT max fa' fb')
-- |The Time monoid where @zero == minBound@
instance Ord t => Monoid (Time t) where
  zero = minBound
-- |The Time ring where @(*) == min@ and @one == maxBound@
instance Ord t => Ring (Time t) where
  one = maxBound
  ~(Time fa fa') * ~(Time fb fb') = Time (mapT min fa fb) (mapT min fa' fb')
instance Ord t => Orderable (Time t) where
  inOrder a b = (a*b,if z then b else a,z)
    where z = a<=b

mapT :: (t -> t -> a) -> (t -> t) -> (t -> t) -> t -> a
mapT f fa fb h = f a (fb$!a) `unamb` f b (fa$!b)
  where a = fa h ; b = fb h

instance Bounded (Time t) where
  minBound = Time (pure minBound) (pure minBound)
  maxBound = Time (pure maxBound) (pure maxBound)
instance Unit Time where
  pure t = Time (pure (pure t)) (pure (pure t)) 

amb :: IO a -> IO a -> IO a
ma `amb` mb = do
  res <- newEmptyMVar
  ta <- forkIO $ ma >>= putMVar res . Left
  tb <- forkIO $ mb >>= putMVar res . Right
  
  takeMVar res >>= \c -> case c of
    Left a -> killThread tb >> return a
    Right a -> killThread ta >> return a
unamb :: a -> a -> a
unamb = warp2 (from _thunk) amb

type Seconds = Double

timeVal :: Time t -> TimeVal t
timeVal (Time fa _) = fa maxBound

timeIO :: IO a -> IO (Time Seconds)
timeIO io = do
  sem <- newEmptyMVar
  minAction <- newIORef $ \tm -> Since<$>case tm of
    Always -> currentTime
    Since t -> (waitTill t >> currentTime) `amb` readMVar sem
    Never -> readMVar sem
  maxAction <- newIORef $ \tm -> case tm of
    Always -> Since<$>readMVar sem
    Since t -> (waitTill t >> pure Never) `amb` (Since<$>readMVar sem)
    Never -> Since<$>currentTime
    
  let refAction ref = \t -> unsafePerformIO (join (readIORef ref<*>pure t))
  _ <- forkIO $ do
    t <- io >> currentTime
    writeIORef minAction (const (pure (pure t)))
    writeIORef maxAction (const (pure (pure t)))
    putMVar sem t
    
  return $ Time (refAction minAction) (refAction maxAction)
  
waitTill :: Seconds -> IO ()
waitTill t = do
  now <- t `seq` currentTime
  when (t>now) $ threadDelay (floor $ (t-now)*1000000)

seconds :: TimeSpec -> Seconds
seconds t = fromIntegral (sec t) + fromIntegral (nsec t)/1000000000 :: Seconds
currentTime :: IO Seconds
currentTime = seconds<$>getTime Realtime