netwire-3.0.0: Control/Wire/Trans/Clock.hs

-- |
-- Module:     Control.Wire.Trans.Clock
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Supplying clocks to wires.

module Control.Wire.Trans.Clock
    ( -- * Time deltas
      WWithDT(..),

      -- * Global time
      WWithSysTime(..),

      -- * Local time
      WWithTime(..)
    )
    where

import Control.Arrow
import Control.Monad.Fix
import Control.Wire.Classes
import Control.Wire.Types
import Data.AdditiveGroup


-- | Passes time deltas to the given wire with respect to the clock
-- represented by the underlying arrow.  Using this wire transformer you
-- can program in the more traditional AFRP way using time deltas
-- instead of time offsets.  Note:  The first time delta is 0.
--
-- * Depends: Like argument wire.
--
-- * Inhibits: When argument wire inhibits.

class Arrow (>~) => WWithDT t (>~) | (>~) -> t where
    -- | Simplified variant without additional input.
    passDT :: Wire e (>~) t b -> Wire e (>~) a b

    -- | Full variant.
    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)


-- | Passes the time passed since the first instant to the given wire.
--
-- * Depends: Like argument wire.
--
-- * Inhibits: When argument wire inhibits.

class Arrow (>~) => WWithTime t (>~) | (>~) -> t where
    -- | Simplified variant without additional input.
    passTime :: Wire e (>~) t b -> Wire e (>~) a b

    -- | Full variant.
    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)


-- | Passes the system time to the given wire.
--
-- * Depends: Like argument wire.
--
-- * Inhibits: When argument wire inhibits.

class Arrow (>~) => WWithSysTime t (>~) | (>~) -> t where
    -- | Simplified variant without additional input.
    passSysTime :: Wire e (>~) t b -> Wire e (>~) a b

    -- | Full variant.
    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)