Reactive.hs

-- {-# LANGUAGE TypeOperators, ScopedTypeVariables, PatternSignatures
--            , FlexibleInstances
--  #-}

-- For ghc-6.6 compatibility
{-# OPTIONS_GHC -fglasgow-exts #-}


----------------------------------------------------------------------
-- |
-- Module      :  Data.Reactive
-- Copyright   :  (c) Conal Elliott 2007
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Functional /events/ and /reactive values/.  An 'Event' is stream of
-- future values in time order.  A 'Reactive' value is a discretly
-- time-varying value.  These two types are closely linked: a reactive
-- value is defined by an initial value and an event that yields future
-- values; while an event is simply a future reactive value.
-- 
-- Many of the operations on events and reactive values are packaged as
-- instances of the standard type classes 'Monoid', 'Functor',
-- 'Applicative', and 'Monad'.
-- 
-- Although the basic 'Reactive' type describes /discretely/-changing
-- values, /continuously/-changing values are modeled simply as reactive
-- functions.  For convenience, this module defines 'ReactiveB' as a type
-- composition of 'Reactive' and a constant-optimized representation of
-- functions of time.
-- 
-- The exact packaging of discrete vs continuous will probably change with
-- more experience.
----------------------------------------------------------------------

module Data.Reactive
  ( -- * Events and reactive values
    Event(..), Reactive(..), Source, inEvent, inEvent2
  , stepper, switcher, mkEvent, mkEventTrace, mkEventShow
  , runE, forkE, subscribe, forkR
    -- * Event extras
  , accumE, scanlE, monoidE
  , withPrevE, countE, countE_, diffE
  , snapshot, snapshot_, whenE, once, traceE, eventX
    -- * Reactive extras
  , mkReactive, accumR, scanlR, monoidR, maybeR, flipFlop, countR, traceR
    -- * Reactive behaviors
  , Time, ReactiveB
    -- * To be moved elsewhere
  , replace, forget
  , Action, Sink
  , joinMaybes, filterMP
  ) where

import Data.Monoid
import Control.Arrow (first,second)
import Control.Applicative
import Control.Monad
import Debug.Trace (trace)
import Data.IORef
import Control.Concurrent (forkIO,ThreadId)

-- TypeCompose
import Control.Compose (Unop,(:.)(..), inO2, Monoid_f(..))
import Data.Pair

import Data.Future
import Data.Fun


{--------------------------------------------------------------------
    Events and reactive values
--------------------------------------------------------------------}

-- | Event, i.e., a stream of future values.  Instances:
-- 
-- * 'Monoid': 'mempty' is the event that never occurs, and @e `mappend`
-- e'@ is the event that combines occurrences from @e@ and @e'@.  (Fran's
-- @neverE@ and @(.|.)@.)
-- 
-- * 'Functor': @fmap f e@ is the event that occurs whenever @e@ occurs,
-- and whose occurrence values come from applying @f@ to the values from
-- @e@.  (Fran's @(==>)@.)
-- 
-- * 'Applicative': @pure a@ is an event with a single occurrence,
-- available from the beginning of time.  @ef \<*\> ex@ is an event whose
-- occurrences are made from the /product/ of the occurrences of @ef@ and
-- @ex@.  For every occurrence @f@ at time @tf@ of @ef@ and occurrence @x@
-- at time @tx@ of @ex@, @ef \<*\> ex@ has an occurrence @f x@ at time @max
-- tf tx@.
-- 
-- * 'Monad': @return a@ is the same as @pure a@ (as always).  In @e >>=
-- f@, each occurrence of @e@ leads, through @f@, to a new event.
-- Similarly for @join ee@, which is somehow simpler for me to think
-- about.  The occurrences of @e >>= f@ (or @join ee@) correspond to the
-- union of the occurrences of all such events.  For example, suppose
-- we're playing Asteroids and tracking collisions.  Each collision can
-- break an asteroid into more of them, each of which has to be tracked
-- for more collisions.  Another example: A chat room has an /enter/
-- event, whose occurrences contain new events like /speak/.
-- 
newtype Event a = Event { eFuture :: Future (Reactive a) }

-- | Reactive value: a discretely changing value.  Reactive values can be
-- understood in terms of (a) a simple denotational semantics of reactive
-- values as functions of time, and (b) the corresponding instances for
-- functions.  The semantics is given by the function @(%$) :: Reactive a
-- -> (Time -> a)@.  A reactive value also has a current value and an
-- event (stream of future values).
-- 
-- Instances for 'Reactive'
-- 
-- * 'Monoid': a typical lifted monoid.  If @o@ is a monoid, then
-- @Reactive o@ is a monoid, with @mempty = pure mempty@, and @mappend =
-- liftA2 mappend@.  In other words, @mempty %$ t == mempty@, and @(r
-- `mappend` s) %$ t == (r %$ t) `mappend` (s %$ t).@
-- 
-- * 'Functor': @fmap f r %$ t == f (r %$ t)@.
-- 
-- * 'Applicative': @pure a %$ t == a@, and @(s \<*\> r) %$ t ==
-- (s %$ t) (r %$ t)@.
-- 
-- * 'Monad': @return a %$ t == a@, and @join rr %$ t == (rr %$ t)
-- %$ t@.  As always, @(r >>= f) == join (fmap f r)@.
-- 
data Reactive a =
  Stepper {
    rInit  :: a                         -- ^ initial value
  , rEvent :: Event a                   -- ^ waiting for event
  }

-- data Reactive a = a `Stepper` Event a

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

-- | Compatibility synonym (for ease of transition from DataDriven)
type Source = Reactive

-- | Apply a unary function inside an 'Event' representation.
inEvent :: (Future (Reactive a) -> Future (Reactive b)) -> (Event a -> Event b)
inEvent f = Event . f . eFuture

-- | Apply a unary function inside an 'Event' representation.
inEvent2 :: (Future (Reactive a) -> Future (Reactive b) -> Future (Reactive c))
         -> (Event a -> Event b -> Event c)
inEvent2 f = inEvent . f . eFuture

-- Why the newtype for Event?  Because the 'Monoid' instance of 'Future'
-- does not do what I want for 'Event'.  It will pick just the
-- earlier-occurring event, while I want an interleaving of occurrences
-- from each.

instance Monoid (Event a) where
  mempty  = Event mempty
  mappend = inEvent2 merge

-- Standard instance for Applicative of Monoid
instance Monoid a => Monoid (Reactive a) where
  mempty  = pure mempty
  mappend = liftA2 mappend

-- | Merge two 'Future' streams into one.
merge :: Future (Reactive a) -> Future (Reactive a) -> Future (Reactive a)
Never `merge` fut   = fut
fut   `merge` Never = fut
u     `merge` v     =
  (onFut (`merge` v) <$> u) `mappend` (onFut (u `merge`) <$> v)
 where
   onFut f (a `Stepper` Event t') = a `stepper` Event (f t')

instance Functor Event where
  fmap f = inEvent $ (fmap.fmap) f

-- I could probably define an Applicative instance like []'s for Event,
-- i.e., apply all functions to all arguments.  I don't think I want that
-- semantics.

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

instance Applicative Event where { pure = return; (<*>) = ap }

instance Applicative Reactive where
  pure a = a `stepper` mempty
  rf@(f `Stepper` Event vf) <*> rx@(x `Stepper` Event vx) =
   f x `stepper` Event (((<*> rx) <$> vf) `mappend` ((rf <*>) <$> vx))

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

-- TODO: The definitions of merge and <*> have some similarities.  Can I
-- factor out a common pattern?

instance Monad Event where
  return a = Event (pure (pure a))
  e >>= f  = joinE (fmap f e)

joinE :: forall a. Event (Event a) -> Event a
joinE = inEvent q
 where
   q :: Future (Reactive (Event a)) -> Future (Reactive a)
   q = (>>= eFuture . h)
   h :: Reactive (Event a) -> Event a
   h (ea `Stepper` eea) = ea `mappend` joinE eea

instance MonadPlus Event where { mzero = mempty; mplus = mappend }

instance Monad Reactive where
  return  = pure
  r >>= h = joinR (fmap h r)

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

-- Reactive 'join'
joinR :: Reactive (Reactive a) -> Reactive a
joinR ((a `Stepper` Event fut) `Stepper` e'@(Event fut')) =
  a `stepper` Event fut''
 where
   -- If fut  arrives first, switch and continue waiting for e'.
   -- If fut' arrives first, abandon fut and keep switching with new
   -- reactive values from fut'.
   fut'' = fmap (`switcher` e') fut `mappend` fmap join fut'

-- | Make an event and a sink for feeding the event.  Each value sent to
-- the sink becomes an occurrence of the event.
mkEvent :: IO (Event a, Sink a)
mkEvent = do (fut,snk) <- newFuture
             -- remember how to save the next occurrence.
             r <- newIORef snk
             return (Event fut, writeTo r)
 where
   -- Fill in an occurrence while preparing for the next one
   writeTo r a = do snk  <- readIORef r
                    (fut',snk') <- newFuture
                    writeIORef r snk'
                    snk (a `stepper` Event fut')

-- | Tracing variant of 'mkEvent'
mkEventTrace :: (a -> String) -> IO (Event a, Sink a)
mkEventTrace shw = second tr <$> mkEvent
 where
   tr snk = (putStrLn.shw) `mappend` snk

-- | Show specialization of 'mkEventTrace'
mkEventShow :: Show a => String -> IO (Event a, Sink a)
mkEventShow str = mkEventTrace ((str ++).(' ':).show)

-- | Run an event in a new thread.
forkE :: Event (IO b) -> IO ThreadId
forkE = forkIO . runE

-- | Subscribe a listener to an event.  Wrapper around 'forkE' and 'fmap'.
subscribe :: Event a -> Sink a -> IO ThreadId
subscribe e snk = forkE (snk <$> e)

-- | Run an event in the current thread.
runE :: Event (IO b) -> IO a
runE (Event fut) = do act `Stepper` e' <- force fut
                      act
                      runE e'
                    
-- | Run a reactive value in a new thread.  The initial action happens in
-- the current thread.
forkR :: Reactive (IO b) -> IO ThreadId
forkR (act `Stepper` e) = act >> forkE e


{--------------------------------------------------------------------
    Event extras
--------------------------------------------------------------------}

-- | Accumulating event, starting from an initial value and a
-- update-function event.  See also 'accumR'.
accumE :: a -> Event (a -> a) -> Event a
accumE a = inEvent $ fmap $ \ (f `Stepper` e') -> f a `accumR` e'

-- | Like 'scanl' for events.  See also 'scanE'.
scanlE :: (a -> b -> a) -> a -> Event b -> Event a
scanlE f a e = a `accumE` (flip f <$> e)

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

-- | Pair each event value with the previous one, given an initial value.
withPrevE :: Event a -> Event (a,a)
withPrevE e = (joinMaybes . fmap combineMaybes) $
              (Nothing,Nothing) `accumE` fmap (shift.Just) e
 where
   -- Shift newer value into (old,new) pair if present.
   shift :: u -> Unop (u,u)
   shift new (_,old) = (old,new)
   combineMaybes :: (Maybe u, Maybe v) -> Maybe (u,v)
   combineMaybes = uncurry (liftA2 (,))

-- | Count occurrences of an event, remembering the occurrence values.
-- See also 'countE_'.
countE :: Num n => Event b -> Event (b,n)
countE = scanlE h (b0,0)
 where
   b0        = error "withCountE: no initial value"
   h (_,n) b = (b,n+1)

-- | Count occurrences of an event, forgetting the occurrence values.  See
-- also 'countE'.  See also 'countR'.
countE_ :: Num n => Event b -> Event n
countE_ e = snd <$> countE e

-- | Difference of successive event occurrences.
diffE :: Num n => Event n -> Event n
diffE e = uncurry (-) <$> withPrevE e

-- | Snapshot a reactive value whenever an event occurs.
snapshot :: Event a -> Reactive b -> Event (a,b)
e `snapshot` r = joinMaybes $ e `snap` r

-- This variant of 'snapshot' yields 'Just's when @e@ happens and
-- 'Nothing's when @r@ changes.
snap :: forall a b. Event a -> Reactive b -> Event (Maybe (a,b))
e@(Event ve) `snap` r@(b `Stepper` Event vr) =
  Event ((g <$> ve) `mappend` (h <$> vr))
 where
   -- When e occurs, produce a pair, and start snapshotting the old
   -- reactive value with the new event.
   g :: Reactive a -> Reactive (Maybe (a,b))
   g (a `Stepper` e') = Just (a,b) `stepper` (e' `snap` r)
   -- When r changes, produce no pair, and start snapshotting the new
   -- reactive value with the old event.
   h :: Reactive b -> Reactive (Maybe (a,b))
   h r' = Nothing `stepper` (e `snap` r')

-- Introducing Nothing above allows the mappend to commit to the RHS.

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

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

-- | Just the first occurrence of an event.
once :: Event a -> Event a
once = inEvent $ fmap $ pure . rInit

-- | Tracing of events.
traceE :: (a -> String) -> Unop (Event a)
traceE shw = fmap (\ a -> trace (shw a) a)


-- | Make an extensible event.  The returned sink is a way to add new
-- events to mix.  You can often use '(>>=)' or 'join' instead.  Warning:
-- this function might be removed at some point.
eventX :: IO (Event a, Sink (Event a))
eventX = first join <$> mkEvent


{--------------------------------------------------------------------
    Reactive extras
--------------------------------------------------------------------}

mkReactive :: a -> IO (Reactive a, Sink a)
mkReactive a0 = first (a0 `stepper`) <$> mkEvent

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

-- | Like 'scanl' for reactive values.  See also 'scanE'.
scanlR :: (a -> b -> a) -> a -> Event b -> Reactive 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 :: Monoid a => Event a -> Reactive 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 :: Event a -> Event b -> Reactive (Maybe a)
maybeR get lose =
  Nothing `stepper` (fmap Just get `mappend` replace Nothing lose)

-- | Flip-flopping source.  Turns true when @ea@ occurs and false when
-- @eb@ occurs.
flipFlop :: Event a -> Event b -> Reactive Bool
flipFlop ea eb =
  False `stepper` (replace True ea `mappend` replace 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 :: Num n => Event a -> Reactive n
countR e = 0 `stepper` countE_ e

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


{--------------------------------------------------------------------
    Other instances
--------------------------------------------------------------------}

-- Standard instances
instance Pair Reactive where pair = liftA2 (,)
instance (Monoid_f f) => Monoid_f (Reactive :. f) where
    { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) }
instance Pair f => Pair (Reactive :. f) where pair = apPair

instance Unpair Reactive where {pfst = fmap fst; psnd = fmap snd}

-- Standard instances
instance Monoid_f Event where
  { mempty_f = mempty ; mappend_f = mappend }
instance Monoid ((Event :. f) a) where
  { mempty = O mempty; mappend = inO2 mappend }
instance Monoid_f (Event :. f) where
  { mempty_f = mempty ; mappend_f = mappend }
instance Copair f => Pair (Event :. f) where
  pair = copair

-- Standard instance for functors
instance Unpair Event where {pfst = fmap fst; psnd = fmap snd}



{--------------------------------------------------------------------
    Reactive behaviors over continuous time
--------------------------------------------------------------------}

-- | Time for continuous behaviors
type Time = Double

-- | Reactive behaviors.  Simply a reactive 'Fun'ction value.  Wrapped in
-- a type composition to get 'Functor' and 'Applicative' for free.
type ReactiveB = Reactive :. Fun Time


{--------------------------------------------------------------------
    To be moved elsewhere
--------------------------------------------------------------------}

-- | Replace a functor value with a given one.
replace :: Functor f => b -> f a -> f b
replace b = fmap (const b)

-- | Forget a functor value, replace with @()@
forget :: Functor f => f a -> f ()
forget = replace ()

-- | Convenient alias for dropping parentheses.
type Action = IO ()

-- | Value sink
type Sink a = a -> Action

-- | Pass through @Just@ occurrences.
joinMaybes :: MonadPlus m => m (Maybe a) -> m a
joinMaybes = (>>= maybe mzero return)

-- | Pass through values satisfying @p@.
filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a
filterMP p m = joinMaybes (liftM f m)
 where
   f a | p a       = Just a
       | otherwise = Nothing

-- Alternatively:
-- filterMP p m = m >>= guarded p
--  where
--    guarded p x = guard (p x) >> return x