-- |
-- 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
      discrete,
      keep,

      -- * Inhibitors
      inhibit,
      require,

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

      -- * Switches
      -- ** Unconditional switches
      constantAfter,
      initially,

      -- * Arrow tools
      mapA,

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

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.

(-->) :: 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
          e@(Left _) -> return (e, y --> w)
          Right _    -> return (Right y, w)


-- | Override the input value, until the wire starts producing.

(>--) :: 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.

(-=>) :: 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
          e@(Left _) -> return (e, f -=> w)
          Right x    -> return (Right (f x), w)


-- | Apply a function to the wire's input, until the wire starts
-- producing.

(>=-) :: 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')
        case mx of
          e@(Left _) -> return (e, f >=- w)
          Right _    -> return (mx, w)


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

constant :: b -> Wire m a b
constant = WConst


-- | Produce the value of the second argument at the first instant.
-- Then produce the second value forever.

constantAfter :: Monad m => b -> b -> Wire m a b
constantAfter x1 x0 =
    mkGen $ \_ _ -> return (Right x0, constant x1)


-- | 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@.

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.

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)


-- | 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.

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)


-- | Identity signal transformer.  Outputs its input.

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


-- | Unconditional inhibition with the given inhibition exception.

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


-- | Produce the argument value at the first instant.  Then act as the
-- identity signal transformer forever.

initially :: Monad m => a -> Wire m a a
initially x0 =
    mkGen $ \_ _ -> return (Right x0, identity)


-- | Keep the value in the first instant forever.

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 right signal, when the left signal is false.

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)


-- | 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.
--
-- The left signal interval is allowed to become zero, at which point
-- the signal is passed through the wire at every instant.

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
                  (mx, w) <- toGen w' ws x''
                  let nextT = fmod t int
                  nextT `seq` return (either (const mx') (const mx) 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.

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.

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


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

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