{-# LANGUAGE TupleSections, RecursiveDo #-}
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
import Control.Exception (AsyncException(..))

type MinMax t = (t,t)
type PartCmp t = t -> IO t
-- |A repeatable action that converges to a single point
type Improve a = IO a
-- |An action that creates a new value upon each call
type New a = IO a
-- |A type wrappers for timestamps that can be compared unambiguously
newtype Time t = Time (New (Improve (PartCmp (MinMax (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 ta) (Time tb) = at _thunk $
    (mergeTimesBy ta tb >=> until) $ \a b -> do
      let cmpV a b = a (minBound,maxBound) >>= \a -> cmp a <$> b a
      (+)<$>cmpV a b<*>map invertOrd<$>cmpV b a 
    where cmp (a,a') (b,b') | a'<b = Just LT | b'<a = Just GT
                            | a==a' && b==b' = Just EQ
                            | otherwise = Nothing
instance Ord t => Semigroup (Time t) where
  Time ta + Time tb = Time $ mergeTimesBy ta tb $ \fa fb -> return $ \h ->
    max2<$>maxV h fa fb<*>maxV h fb fa
    where max2 (xa,ya) (xb,yb) = (max xa xb,max ya yb)
          maxV h fa fb = fa h >>= \a -> max2 a<$>fb a
instance Ord t => Monoid (Time t) where
  zero = minBound
instance Bounded (Time t) where
  minBound = Time (pure (pure (pure (pure (minBound,minBound)))))
  maxBound = Time (pure (pure (pure (pure (maxBound,maxBound)))))
instance Unit Time where
  pure t = Time (pure (pure (pure (pure (pure t,pure t)))))

type Seconds = Double

mergeTimesBy tta ttb f = newChan >>= \res -> do
  union <- newChan
  ta <- unsafeInterleaveIO tta ; tb <- unsafeInterleaveIO ttb
  let consume f ta = forkIO $ tillPoint ta $ writeChan union . f
      unknown = const (pure (minBound,maxBound))
  consume Left ta ; consume Right tb
  forkIO $ (\f -> f unknown unknown) $ fix $ \m a b -> do
    writeChan res =<< f a b
    end <- (&&)<$>isPoint a<*>isPoint b
    unless end $ (flip m b <|> m a) =<< readChan union
  return (readChan res)
  
isPoint f = f (minBound,maxBound) <&> uncurry (==)
tillPoint m f = fix (\p -> m >>= \x -> f x >> isPoint x >>= flip unless p)
timeVal (Time t) = at _thunk $ do
  r <- newIORef undefined
  t >>= flip tillPoint (writeIORef r <=< (&) (minBound,maxBound))
  fst <$> readIORef r

timeIO io = do
  sem <- newEmptyMVar
  defined <- newIORef False
  value <- newIORef undefined
  forkIO $ mdo
    io >> writeIORef value (Since t)
    writeIORef defined True
    t <- currentTime
    putMVar sem ()
    
  return $ Time $ map readChan $ newChan <*= \c -> do
    let valWrite m = writeChan c =<< (const.pure<$>m)
        pureFun t = (t,t)
        pureVal = pureFun<$>readIORef value

    def <- readIORef defined
    if def then valWrite pureVal
      else do
      forkIO $ readMVar sem >> valWrite pureVal
      writeChan c $ \(_,b) -> do
        c <- currentTime 
        let forkVal = forkAt b (currentTime >>= \t -> 
                               readIORef defined >>= \def -> 
                               unless def (valWrite (pure (Since t,Never))))
                      >> pure (Since c,Never)
        readIORef defined >>= bool pureVal forkVal 
-- print_ a = a <*= print

  
waitTill t = do
  now <- t `seq` currentTime
  when (t>now) $ threadDelay (floor $ (t-now)*1000000)
forkAt (Since t) io = () <$ forkIO (putStrLn ("Waiting till "+show t) >> waitTill t >> io)
forkAt Always io = () <$ forkIO io
forkAt Never io = return ()

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