reactive-0.5: src/Data/SReactive.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables #-}
----------------------------------------------------------------------
-- |
-- Module      :  Data.SReactive
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Simple, semantics-based reactive values
----------------------------------------------------------------------

module Data.SReactive
  (
    -- * Primitives
    Reactive'(..), stepper
  , joinR
    -- * Extras (defined via primitives)
  , Reactive
  , switcher, snapshot, snapshot_, whenE
  , accumR, scanlR, monoidR, maybeR, flipFlop, countR, traceR
  ) where

import Control.Applicative
import Control.Monad
import Data.Monoid

-- TypeCompose
import Control.Compose (Unop)
import Data.Pair (Pair(..),pairEdit)

import Data.EventExtras
import Data.Improving


{----------------------------------------------------------
    Primitives
----------------------------------------------------------}

data Reactive' t a =
  Stepper {
    rInit  :: a                         -- ^ initial value
  , rEvent :: Event' t a                -- ^ waiting for event
  }

-- | Reactive value from an initial value and a new-value event.
stepper :: a -> Event' t a -> Reactive' t a
stepper = Stepper


instance Ord t => Pair (Reactive' t) where
  -- pair :: Reactive' t a -> Reactive' t b -> Reactive' t (a,b)
  (c `Stepper` ce) `pair` (d `Stepper` de) =
    (c,d) `accumR` pairEdit (ce,de)

instance Functor (Reactive' t) where
  fmap f (a `Stepper` e) = f a `stepper` fmap f e

instance Ord t => Applicative (Reactive' t) where
  pure a = a `stepper` mempty
  -- Standard definition.  See 'Pair'.
  rf <*> rx = uncurry ($) <$> (rf `pair` rx)

-- A wonderful thing about the <*> definition for Reactive' t is that it
-- automatically caches the previous value of the function or argument
-- when the argument or function changes.

instance Ord t => Monad (Reactive' t) where
  return  = pure
  r >>= f = joinR (f <$> r)

-- | Reactive' t 'join' (equivalent to 'join' but slightly more efficient, I think)
joinR :: Ord t => Reactive' t (Reactive' t a) -> Reactive' t a
joinR ((a `Stepper` e) `Stepper` er) = 
  a `stepper` (e `mappend` join (rToE <$> er))

-- | Turn a reactive value into an event, given a time for the initial
-- occurrence.
rToE :: Ord t => Reactive' t a -> Event' t a
rToE (a `Stepper` e) = pure a `mappend` e

-- e  :: Event' t a
-- er :: Event' t (Reactive' t a)
-- 
-- rToE <$> er ::: Event' t (Event' t a)
-- join (rToE <$> er) ::: Event' t a

-- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@
-- didn't.
snap :: forall a b t. Ord t =>
        Event' t a -> Reactive' t b -> Event' t (Maybe a, b)
ea `snap` (b0 `Stepper` eb) =
  (Nothing, b0) `accumE` (fmap fa ea `mappend` fmap fb eb)
 where
   fa :: a -> Unop (Maybe a, b)
   fb :: b -> Unop (Maybe a, b)
   fa a (_,b) = (Just a , b)
   fb b _     = (Nothing, b)


{----------------------------------------------------------
    Extras (defined via primitives)
----------------------------------------------------------}

type Reactive = Reactive' (Improving Double)

-- | Snapshot a reactive value whenever an event occurs.
snapshot :: Ord t => Event' t a -> Reactive' t b -> Event' t (a,b)
e `snapshot` r = joinMaybes $ fmap f (e `snap` r)
 where
   f (Nothing,_) = Nothing
   f (Just a ,b) = Just (a,b)

-- | Switch between reactive values.
switcher :: Ord t => Reactive' t a -> Event' t (Reactive' t a) -> Reactive' t a
r `switcher` e = joinR (r `stepper` e)

-- | Like 'snapshot' but discarding event data (often @a@ is @()@).
snapshot_ :: Ord t => Event' t a -> Reactive' t b -> Event' t b
e `snapshot_` src = snd <$> (e `snapshot` src)

-- | Filter an event according to whether a boolean source is true.
whenE :: Ord t => Event' t a -> Reactive' t Bool -> Event' t a
whenE e = joinMaybes . fmap h . snapshot e
 where
   h (a,True)  = Just a
   h (_,False) = Nothing


-- | Reactive' t value from an initial value and an updater event.  See also
-- 'accumE'.
accumR :: Ord t => a -> Event' t (a -> a) -> Reactive' t a
a `accumR` e = a `stepper` (a `accumE` e)

-- | Like 'scanl' for reactive values.  See also 'scanlE'.
scanlR :: Ord t => (a -> b -> a) -> a -> Event' t b -> Reactive' t a
scanlR f a e = a `stepper` scanlE f a e

-- | Accumulate values from a monoid-valued event.  Specialization of
-- 'scanlE', using 'mappend' and 'mempty'.  See also 'monoidE'.
monoidR :: (Ord t, Monoid a) => Event' t a -> Reactive' t a
monoidR = scanlR mappend mempty

-- | Start out blank ('Nothing'), latching onto each new @a@, and blanking
-- on each @b@.  If you just want to latch and not blank, then use
-- 'mempty' for @lose@.
maybeR :: Ord t => Event' t a -> Event' t b -> Reactive' t (Maybe a)
maybeR get lose =
  Nothing `stepper` (fmap Just get `mappend` (Nothing <$ lose))

-- | Flip-flopping source.  Turns true when @ea@ occurs and false when
-- @eb@ occurs.
flipFlop :: Ord t => Event' t a -> Event' t b -> Reactive' t Bool
flipFlop ea eb =
  False `stepper` ((True <$ ea) `mappend` (False <$ eb))

-- TODO: generalize 'maybeR' & 'flipFlop'.  Perhaps using 'Monoid'.
-- Note that Nothing and (Any False) are mempty.

-- | Count occurrences of an event.  See also 'countE'.
countR :: (Ord t, Num n) => Event' t a -> Reactive' t n
countR e = 0 `stepper` countE_ e

-- | Tracing of reactive values
traceR :: (a -> String) -> Unop (Reactive' t a)
traceR shw (a `Stepper` e) = a `Stepper` traceE shw e