Sample.hs

-- |
-- Module:     Control.Wire.Trans.Sample
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Wire transformers for sampling wires.

module Control.Wire.Trans.Sample
    ( -- * Sampling
      hold,
      holdWith,
      sample,
      swallow
    )
    where

import Control.Arrow
import Control.Wire.Classes
import Control.Wire.Prefab.Simple
import Control.Wire.Types


-- | Keeps the latest produced value.
--
-- * Depends: Like argument wire.
-- * Inhibits: Until first production.

hold :: Arrow (>~) => Wire e (>~) a b -> Wire e (>~) a b
hold (WPure f) =
    mkPure $ \x' ->
        let (mx, w) = f x' in
        case mx of
          Left ex -> (Left ex, hold w)
          Right x -> (Right x, holdWith x w)
hold (WGen c) =
    mkGen $ proc x' -> do
        (mx, w) <- c -< x'
        returnA -<
            case mx of
              Left ex -> (Left ex, hold w)
              Right x -> (Right x, holdWith x w)


-- | Keeps the latest produced value.  Produces the argument value until
-- the argument wire starts producing.
--
-- * Depends: Like argument wire.

holdWith :: Arrow (>~) => b -> Wire e (>~) a b -> Wire e (>~) a b
holdWith x0 (WPure f) =
    mkPure $ \x' ->
        let (mx, w) = f x' in
        case mx of
          Left _  -> (Right x0, holdWith x0 w)
          Right x -> (Right x, holdWith x w)
holdWith x0 (WGen c) =
    mkGen $ proc x' -> do
        (mx, w) <- c -< x'
        returnA -<
            case mx of
              Left _  -> (Right x0, holdWith x0 w)
              Right x -> (Right x, holdWith x w)


-- | Samples the given wire at discrete intervals.  Only runs the input
-- through the wire, then the next sampling interval has elapsed.
--
-- * Depends: Current instant (left), like argument wire at sampling
--   intervals (right).
-- * Inhibits: Starts inhibiting when argument wire inhibits.  Keeps
--   inhibiting until next sampling interval.

sample ::
    forall a b e t (>~).
    (ArrowChoice (>~), ArrowClock (>~), Num t, Ord t, Time (>~) ~ t)
    => Wire e (>~) a b
    -> Wire e (>~) (a, t) b
sample w' =
    mkGen $ proc (x', _) -> do
        t <- arrTime -< ()
        (mx, w) <- toGen w' -< x'
        returnA -< (mx, sample' t mx w)

    where
    sample' :: t -> Either e b -> Wire e (>~) a b -> Wire e (>~) (a, t) b
    sample' t' mx0 w' =
        mkGen $ proc (x', dt) -> do
            t <- arrTime -< ()
            if t - t' < dt
              then returnA -< (mx0, sample' t' mx0 w')
              else do
                  (mx, w) <- toGen w' -< x'
                  returnA -< (mx, sample' t mx w)


-- | Waits for the argument wire to produce and then keeps the first
-- produced value forever.
--
-- * Depends: Like argument wire until first production.  Then stops
--   depending.
-- * Inhibits: Until the argument wire starts producing.

swallow :: ArrowChoice (>~) => Wire e (>~) a b -> Wire e (>~) a b
swallow (WPure f) =
    mkPure $ \x' ->
        case f x' of
          (Left ex, w) -> (Left ex, swallow w)
          (Right x, _) -> (Right x, constant x)
swallow (WGen c) =
    mkGen $ proc x' -> do
        (mx, w) <- c -< x'
        case mx of
          Left ex -> returnA -< (Left ex, swallow w)
          Right x -> returnA -< (Right x, constant x)