module Control.Wire.Trans.Clock
(
WWithDT(..),
WWithSysTime(..),
WWithTime(..)
)
where
import Control.Arrow
import Control.Monad.Fix
import Control.Wire.Classes
import Control.Wire.Types
import Data.AdditiveGroup
class Arrow (>~) => WWithDT t (>~) | (>~) -> t where
passDT :: Wire e (>~) t b -> Wire e (>~) a b
withDT :: Wire e (>~) (a, t) b -> Wire e (>~) a b
instance (AdditiveGroup t, MonadClock t m) => WWithDT t (Kleisli m) where
passDT w' =
WmGen $ \_ -> do
t <- getTime
(mx, w) <- toGenM w' zeroV
return (mx, withDT' t w)
where
withDT' :: t -> Wire e (Kleisli m) t b -> Wire e (Kleisli m) a b
withDT' t' w' =
WmGen $ \_ -> do
t <- getTime
let dt = t ^-^ t'
(mx, w) <- toGenM w' dt
return (mx, withDT' t w)
withDT w' =
WmGen $ \x' -> do
t <- getTime
(mx, w) <- toGenM w' (x', zeroV)
return (mx, withDT' t w)
where
withDT' :: t -> Wire e (Kleisli m) (a, t) b -> Wire e (Kleisli m) a b
withDT' t' w' =
WmGen $ \x' -> do
t <- getTime
let dt = t ^-^ t'
(mx, w) <- toGenM w' (x', dt)
return (mx, withDT' t w)
class Arrow (>~) => WWithTime t (>~) | (>~) -> t where
passTime :: Wire e (>~) t b -> Wire e (>~) a b
withTime :: Wire e (>~) (a, t) b -> Wire e (>~) a b
instance (AdditiveGroup t, MonadClock t m) => WWithTime t (Kleisli m) where
passTime = withTime . mapInputM snd
withTime w' =
WmGen $ \x' -> do
t0 <- getTime
(mx, w) <- toGenM w' (x', zeroV)
return (mx, withTime' t0 w)
where
withTime' :: t -> Wire e (Kleisli m) (a, t) b -> Wire e (Kleisli m) a b
withTime' t0 =
fix $ \again w' ->
WmGen $ \x' -> do
t <- getTime
(mx, w) <- toGenM w' (x', t ^-^ t0)
return (mx, again w)
class Arrow (>~) => WWithSysTime t (>~) | (>~) -> t where
passSysTime :: Wire e (>~) t b -> Wire e (>~) a b
withSysTime :: Wire e (>~) (a, t) b -> Wire e (>~) a b
instance MonadClock t m => WWithSysTime t (Kleisli m) where
passSysTime = withSysTime . mapInputM snd
withSysTime w' =
WmGen $ \x' -> do
t <- getTime
(mx, w) <- toGenM w' (x', t)
return (mx, withSysTime w)