module SimpleH.Reactive.Time (
Time,
timeVal,
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
type Improve a = IO a
type New a = IO a
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
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
instance Ord t => Monoid (Time t) where
zero = minBound
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)
waitTill t = do
now <- t `seq` currentTime
when (t>now) $ threadDelay (floor $ (tnow)*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