Tools.hs

-- |
-- Module:     FRP.NetWire.Tools
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- The usual FRP tools you'll want to work with.

module FRP.NetWire.Tools
    ( -- * Basic utilities
      constant,
      identity,

      -- * Time
      time,
      timeFrom,

      -- * Signal transformers
      accum,
      delay,
      discrete,
      hold,
      keep,

      -- * Inhibitors
      forbid,
      forbid_,
      inhibit,
      inhibit_,
      require,
      require_,

      -- * Wire transformers
      exhibit,
      freeze,
      sample,
      swallow,
      (-->),
      (>--),
      (-=>),
      (>=-),

      -- * Arrow tools
      mapA,

      -- * Convenience functions
      dup,
      fmod,
      swap
    )
    where

import Control.Applicative
import Control.Arrow
import Control.Category hiding ((.))
import Control.Exception
import FRP.NetWire.Wire
import Prelude hiding (id)


-- | Override the output value at the first non-inhibited instant.
--
-- Same inhibition properties as argument wire.  Same feedback
-- properties as argument wire.

(-->) :: Monad m => b -> Wire m a b -> Wire m a b
y --> w' =
    WGen $ \ws x -> do
        (mx, w) <- toGen w' ws x
        case mx of
          Left _  -> return (mx, y --> w)
          Right _ -> return (Right y, w)


-- | Override the input value, until the wire starts producing.
--
-- Same inhibition properties as argument wire.  Same feedback
-- properties as argument wire.

(>--) :: Monad m => a -> Wire m a b -> Wire m a b
x' >-- w' =
    WGen $ \ws _ -> do
        (mx, w) <- toGen w' ws x'
        return (mx, either (const $ x' >-- w) (const w) mx)


-- | Apply a function to the wire's output at the first non-inhibited
-- instant.
--
-- Same inhibition properties as argument wire.  Same feedback
-- properties as argument wire.

(-=>) :: Monad m => (b -> b) -> Wire m a b -> Wire m a b
f -=> w' =
    WGen $ \ws x' -> do
        (mx, w) <- toGen w' ws x'
        case mx of
          Left _  -> return (mx, f -=> w)
          Right x -> return (Right (f x), w)


-- | Apply a function to the wire's input, until the wire starts
-- producing.
--
-- Same inhibition properties as argument wire.  Same feedback
-- properties as argument wire.

(>=-) :: Monad m => (a -> a) -> Wire m a b -> Wire m a b
f >=- w' =
    WGen $ \ws x' -> do
        (mx, w) <- toGen w' ws (f x')
        return (mx, either (const (f >=- w)) (const w) mx)


-- | This function corresponds to the 'iterate' function for lists.
-- Begins with an initial output value.  Each time an input function is
-- received, it is applied to the current accumulator and the new value
-- is emitted.
--
-- Never inhibits.  Direct feedback.

accum :: Monad m => a -> Wire m (a -> a) a
accum x = mkGen $ \_ f -> x `seq` return (Right x, accum (f x))


-- | The constant wire.  Please use this function instead of @arr (const
-- c)@.
--
-- Never inhibits.

constant :: Monad m => b -> Wire m a b
constant = pure


-- | One-instant delay.  Delay the signal for an instant returning the
-- argument value at the first instant.  This wire is mainly useful to
-- add feedback support to wires, which wouldn't support it by
-- themselves.  For example, the 'FRP.NetWire.Analyze.avg' wire does not
-- support feedback by itself, but the following works:
--
-- > do rec x <- delay 1 <<< avg 1000 -< x
--
-- Never inhibits.  Direct feedback.

delay :: Monad m => a -> Wire m a a
delay r = mkGen $ \_ x -> return (Right r, delay x)


-- | Turn a continuous signal into a discrete one.  This transformer
-- picks values from the right signal at intervals of the left signal.
--
-- The interval length is followed in real time.  If it's zero, then
-- this wire acts like @second id@.
--
-- Never inhibits.  Feedback by delay.

discrete :: forall a m. Monad m => Wire m (Time, a) a
discrete =
    mkGen $ \(wsDTime -> dt) (_, x0) ->
        return (Right x0, discrete' dt x0)

    where
    discrete' :: Time -> a -> Wire m (Time, a) a
    discrete' t' x' =
        mkGen $ \(wsDTime -> dt) (int, x) ->
            let t = t' + dt in
            if t >= int
              then return (Right x, discrete' (fmod t int) x)
              else return (Right x', discrete' t x')


-- | Duplicate a value to a tuple.

dup :: a -> (a, a)
dup x = (x, x)


-- | This function corresponds to 'try' for exceptions, allowing you to
-- observe inhibited signals.  See also 'FRP.NetWire.Event.event'.
--
-- Never inhibits.  Same feedback properties as argument wire.

exhibit :: Monad m => Wire m a b -> Wire m a (Output b)
exhibit w' =
    WGen $ \ws x' -> do
        (mx, w) <- toGen w' ws x'
        return (Right mx, exhibit w)


-- | Floating point modulo operation.  Note that @fmod n 0@ = 0.

fmod :: Double -> Double -> Double
fmod _ 0 = 0
fmod n d = n - d * realToFrac (floor $ n/d)


-- | Inhibit, when the left signal is true.
--
-- Inhibits on true left signal.  No feedback.

forbid :: Monad m => Wire m (Bool, a) a
forbid =
    mkGen $ \_ (b, x) ->
        return (if b then Left (inhibitEx "Forbidden condition met") else Right x,
                forbid)


-- | Inhibit, when the signal is true.
--
-- Inhibits on true signal.  No feedback.

forbid_ :: Monad m => Wire m Bool ()
forbid_ =
    mkGen $ \_ b ->
        return (if b then Left (inhibitEx "Forbidden condition met") else Right (),
                forbid_)


-- | Effectively prevent a wire from rewiring itself.  This function
-- will turn any stateful wire into a stateless wire, rendering most
-- wires useless.
--
-- Note:  This function should not be used normally.  Use it only, if
-- you know exactly what you're doing.
--
-- Same inhibition properties as first instant of argument wire.  Same
-- feedback properties as first instant of argument wire.

freeze :: Monad m => Wire m a b -> Wire m a b
freeze w =
    WGen $ \ws x' -> do
        (mx, _) <- toGen w ws x'
        return (mx, w)


-- | Keep the latest output.
--
-- Inhibits until first signal from argument wire.  Same feedback
-- properties as argument wire.

hold :: forall a b m. Monad m => Wire m a b -> Wire m a b
hold w' =
    mkGen $ \ws x' -> do
        (mx, w) <- toGen w' ws x'
        case mx of
          Right x -> return (mx, hold' x w)
          Left _  -> return (mx, hold w)

    where
    hold' :: b -> Wire m a b -> Wire m a b
    hold' x0 w' =
        mkGen $ \ws x' -> do
            (mx, w) <- toGen w' ws x'
            case mx of
              Left _  -> return (Right x0, hold' x0 w)
              Right x -> return (Right x, hold' x w)


-- | Identity signal transformer.  Outputs its input.
--
-- Never inhibits.  Feedback by delay.

identity :: Monad m => Wire m a a
identity = id


-- | Unconditional inhibition with the given inhibition exception.
--
-- Always inhibits.

inhibit :: (Exception e, Monad m) => Wire m e b
inhibit =
    WGen $ \_ ex -> return (Left (toException ex), inhibit)


-- | Unconditional inhibition with default inhibition exception.
--
-- Always inhibits.

inhibit_ :: Monad m => Wire m a b
inhibit_ = zeroArrow


-- | Keep the value in the first instant forever.
--
-- Never inhibits.  Feedback by delay.

keep :: Monad m => Wire m a a
keep = mkGen $ \_ x -> return (Right x, constant x)


-- | Apply an arrow to a list of inputs.

mapA :: ArrowChoice a => a b c -> a [b] [c]
mapA a =
    proc x ->
        case x of
          [] -> returnA -< []
          (x0:xs) -> arr (uncurry (:)) <<< a *** mapA a -< (x0, xs)


-- | Inhibit, when the left signal is false.
--
-- Inhibits on false left signal.  No feedback.

require :: Monad m => Wire m (Bool, a) a
require =
    mkGen $ \_ (b, x) ->
        return (if b then Right x else Left (inhibitEx "Required condition not met"),
                require)


-- | Inhibit, when the signal is false.
--
-- Inhibits on false signal.  No feedback.

require_ :: Monad m => Wire m Bool ()
require_ =
    mkGen $ \_ b ->
        return (if b then Right () else Left (inhibitEx "Required condition not met"),
                require_)


-- | Sample the given wire at specific intervals.  Use this instead of
-- 'discrete', if you want to prevent the signal from passing through
-- the wire all the time.  Returns the most recent result.
--
-- The left signal interval is allowed to become zero, at which point
-- the signal is passed through the wire at every instant.
--
-- Inhibits until the first result from the argument wire.  Same
-- feedback properties as argument wire.

sample :: forall a b m. Monad m => Wire m a b -> Wire m (Time, a) b
sample w' =
    WGen $ \ws@(wsDTime -> dt) (_, x') -> do
        (mx, w) <- toGen w' ws x'
        return (mx, sample' dt mx w)

    where
    sample' :: Time -> Output b -> Wire m a b -> Wire m (Time, a) b
    sample' t' mx' w' =
        WGen $ \ws@(wsDTime -> dt) (int, x'') ->
            let t = t' + dt in
            if t >= int || int <= 0
              then do
                  (mmx, w) <- toGen w' (ws { wsDTime = t }) x''
                  let mx = either (const mx') (const mmx) mmx
                      nextT = fmod t int
                  () `seq` return (mx, sample' nextT mx w)
              else
                  return (mx', sample' t mx' w')


-- | Wait for the first signal from the given wire and keep it forever.
--
-- Inhibits until signal from argument wire.  Direct feedback, if
-- argument wire never inhibits, otherwise no feedback.

swallow :: Monad m => Wire m a b -> Wire m a b
swallow w' =
    WGen $ \ws x' -> do
        (mx, w) <- toGen w' ws x'
        return (mx, either (const (swallow w)) constant mx)


-- | Swap the values in a tuple.

swap :: (a, b) -> (b, a)
swap (x, y) = (y, x)


-- | Get the local time.
--
-- Never inhibits.

time :: Monad m => Wire m a Time
time = timeFrom 0


-- | Get the local time, assuming it starts from the given value.
--
-- Never inhibits.

timeFrom :: Monad m => Time -> Wire m a Time
timeFrom t' =
    mkGen $ \(wsDTime -> dt) _ ->
        let t = t' + dt
        in t `seq` return (Right t, timeFrom t)