module Control.Reactive.Time (
Time,
timeVal,
Seconds,
timeIO,waitTill,currentTime,timeOrigin
) where
import SimpleH
import Control.Concurrent
import Control.Reactive.TimeVal
import System.IO.Unsafe
import Data.IORef
import System.Clock
import Control.Exception (handle,Exception(..))
import Data.Typeable
data Freezed = Freezed
deriving (Typeable,Show)
instance Exception Freezed
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
instance Ord t => Semigroup (Time t) where
~(Time fa fb) + ~(Time fa' fb') = Time (mapTL mini fa fa') (mapTL maxi fb fb')
where mini h x x' = if h < x then x else max x x'
maxi h x x' = if h > x then max x x' else x
instance Ord t => Monoid (Time t) where
zero = minBound
instance Ord t => Ring (Time t) where
one = maxBound
~(Time fa fb) * ~(Time fa' fb') = Time (mapTL mini fa fa') (mapTL maxi fb fb')
where mini h x x' = if h < x then min x x' else x
maxi h x x' = if h > x then x else min x x'
instance Ord t => Orderable (Time t) where
inOrder a b = (a*b,if z then b else a,z)
where z = a<=b
mapTL :: (a -> b -> b -> c) -> (a -> b) -> (a -> b) -> a -> c
mapTL _max fa fa' h = _max h x x'`unamb`_max h x' x
where x = fa h ; x' = fa' 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 $ handle (\Freezed -> unit) $ ma >>= putMVar res . Left
tb <- forkIO $ handle (\Freezed -> unit) $ mb >>= putMVar res . Right
takeMVar res >>= \c -> case c of
Left a -> pure a <* killThread tb
Right a -> pure a <* killThread ta
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
ret <- newIORef id
minAction <- newIORef $ \tm -> readIORef ret <**> amb (readMVar sem) (
Since<$>case tm of
Always -> currentTime
Since t -> waitTill t >> currentTime
Never -> throw (toException Freezed))
maxAction <- newIORef $ \tm -> readIORef ret <**> amb (readMVar sem) (
case tm of
Always -> throw (toException Freezed)
Since t -> waitTill t >> pure Never
Never -> Since<$>currentTime)
let refAction ref = \t -> unsafePerformIO (join (readIORef ref<*>pure t))
_ <- forkIO $ void $ mfix $ \t -> do
t' <- catch (\_ -> return Never) (io >> return (pure t))
writeIORef minAction (const (pure t'))
writeIORef maxAction (const (pure t'))
writeIORef ret (const t')
putMVar sem t'
currentTime
return $ Time (refAction minAction) (refAction maxAction)
waitTill :: Seconds -> IO ()
waitTill t = do
now <- t `seq` currentTime
when (t>now) $ threadDelay (floor $ (tnow)*1000000)
seconds :: TimeSpec -> Seconds
seconds t = fromIntegral (sec t) + fromIntegral (nsec t)/1000000000 :: Seconds
currentTime :: IO Seconds
currentTime = seconds<$>getTime Realtime
timeOrigin :: (( ?birthTime :: Seconds ) => IO a) -> IO a
timeOrigin m = currentTime >>= \t -> let ?birthTime = t in m