{-# 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

type Bounds 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 (Bounds (TimeVal t)))))
_Time = iso Time (\(Time t) -> 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 cmp a b = a (minBound,maxBound) >>= \a -> cmp a <$> b a
      (+)<$>cmpV cmp a b<*>cmpV (flip cmp) b a 
    where cmp (a,a') (b,b') | a'<b = Just LT | b'<a = Just GT
                            | a==a' && b==b' = Just EQ
                            | otherwise = Nothing
-- |The Time semigroup where @ta + tb == max ta tb@
instance Ord t => Semigroup (Time t) where
  Time ta + Time tb = mergeFun (warp2 (mapIso2 _Max _Max) (+))
                      stopMax (Time ta) (Time tb)
    where stopMax action (a,a') (b,b') | a'<b = _ioref action =- pure tb
                                       | a>b' = _ioref action =- pure ta
                                       | otherwise = unit
-- |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 ta * Time tb = mergeFun (warp2 (mapIso2 _Max _Max) (*))
                      stopMin (Time ta) (Time tb)
    where stopMin action (a,a') (b,b') | a'<b = _ioref action =- pure ta
                                       | a>b' = _ioref action =- pure tb
                                       | otherwise = unit
instance Ord t => Orderable (Time t) where
  inOrder a b = (a*b,if z then b else a,z)
    where z = a<=b

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


mergeFun f c (Time ta) (Time tb) =
  Time $ mergeTimesBy ta tb $ \action fa fb -> return $ \h -> do
    let cmb f c fa fb = fa h >>= \a -> fb a >>= \b -> f a b <$ c action a b
    f<$>cmb f c fa fb<*>cmb (flip f) (map flip c) fb fa

mergeTimesBy tta ttb f = join $ readIORef action
  where action = unsafePerformIO (newIORef chan)
        chan = 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
            r <- f action a b ; writeChan res r
            end <- (&&)<$>isPoint a<*>isPoint b
            if end then writeIORef action (return (pure r))
              else (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 = mdo
  sem <- newEmptyMVar
  action <- newIORef chan
  lookup <- newIORef forkVal
  notify <- newIORef (\c t t' -> writeVal c (pure (pure t,t')))

  let chan = map readChan $ newChan <*= \ch -> do
        forkIO $ readMVar sem >>= writeVal ch . pureFun 
        writeChan ch $ \(_,b) -> join (
          readIORef lookup<**>pure ch<**>currentTime<**>pure b)
      forkVal ch t b = do 
        forkAt b $ join (
          readIORef notify<**>pure ch<**>currentTime<**>pure Never)
        return (Since t,Never)
      writeVal ch m = writeChan ch =<< (const.pure<$>m)
      pureFun t = pure (pure t,pure t)
            
  forkIO $ mdo
    io
    _ioref action =- pure (pure t^.._Time)
    _ioref lookup =- pure (\_ _ _ -> pure (pure t,pure t))
    _ioref notify =- pure (const (const (const unit)))
    t <- currentTime
    putMVar sem t
    
  return $ Time $ join (readIORef action) 
-- print_ s a = putStrLn (s+": "+show a) >> pure a

  
waitTill t = do
  now <- t `seq` currentTime
  when (t>now) $ threadDelay (floor $ (t-now)*1000000)
forkAt (Since t) io = () <$ forkIO (waitTill t >> io)
forkAt Always io = () <$ forkIO io
forkAt Never _ = return ()

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