Reactive.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS -Wall #-}

----------------------------------------------------------------------
-- |
-- Module      :  FRP.Reactive.Internal.Reactive
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Representation for 'Reactive' and 'Event' types.  Combined here,
-- because they're mutually recursive.
-- 
-- The representation used in this module is based on a close connection
-- between these two types.  A reactive value is defined by an initial
-- value and an event that yields future values; while an event is given
-- as a future reactive value.
----------------------------------------------------------------------

module FRP.Reactive.Internal.Reactive
  (
    EventG(..), isNeverE, inEvent, inEvent2, eFutures
  , ReactiveG(..), inREvent, inFutR
  , runE, runR, forkE, forkR
  ) where

-- import Data.List (intersperse)

import Control.Concurrent (forkIO,ThreadId)

import FRP.Reactive.Internal.Misc
import FRP.Reactive.Internal.Future
import Data.Max
-- import Data.AddBounds

-- | Events.  Semantically: time-ordered list 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'@.
-- 
-- * '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@.
-- 
-- * 'Applicative': @pure a@ is an event with a single occurrence at time
--   -Infinity.  @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 @tf `max` tx@.  N.B.: I
--   don't expect this instance to be very useful.  If @ef@ has @nf@
--   instances and @ex@ has @nx@ instances, then @ef \<*\> ex@ has @nf*nx@
--   instances.  However, there are only @nf+nx@ possibilities for @tf
--   `max` tx@, so many of the occurrences are simultaneous.  If you think
--   you want to use this instance, consider using 'Reactive' instead.
-- 
-- * 'Monad': @return a@ is the same as @pure a@ (as usual).  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 (temporal interleaving) 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/.  An especially useful
--   monad-based function is 'joinMaybes', which filters a Maybe-valued
--   event.

newtype EventG t a = Event { eFuture :: FutureG t (ReactiveG t a) }

-- The event representation requires temporal monotonicity but does not
-- enforce it, which invites bugs.  Every operation therefore must be
-- tested for preserving monotonicity.  (Better yet, find an efficient
-- representation that either enforces or doesn't require monotonicity.)

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


-- TODO: Alternative and MonadPlus instances for EventG

-- | 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 @at :: ReactiveG t a ->
-- (t -> a)@.  A reactive value may also be thought of (and in this module
-- is implemented as) a current value and an event (stream of future values).
-- 
-- The semantics of 'ReactiveG' instances are given by corresponding
-- instances for the semantic model (functions):
-- 
-- * 'Functor': @at (fmap f r) == fmap f (at r)@, i.e., @fmap f r `at`
--   t == f (r `at` t)@.
-- 
-- * 'Applicative': @at (pure a) == pure a@, and @at (s \<*\> r) == at s
--   \<*\> at t@.  That is, @pure a `at` t == a@, and @(s \<*\> r) `at` t
--   == (s `at` t) (r `at` t)@.
-- 
-- * 'Monad': @at (return a) == return a@, and @at (join rr) == join (at
--   . at rr)@.  That is, @return a `at` t == a@, and @join rr `at` t ==
--   (rr `at` t) `at` t@.  As always, @(r >>= f) == join (fmap f r)@.
--   @at (r >>= f) == at r >>= at . f@.
-- 
-- * 'Monoid': a typical lifted monoid.  If @o@ is a monoid, then
--   @Reactive o@ is a monoid, with @mempty == pure mempty@, and @mappend
--   == liftA2 mappend@.  That is, @mempty `at` t == mempty@, and @(r
--   `mappend` s) `at` t == (r `at` t) `mappend` (s `at` t).@

data ReactiveG t a = a `Stepper` EventG t a


{--------------------------------------------------------------------
    Applying functions inside of representations
--------------------------------------------------------------------}

-- | Apply a unary function inside an 'EventG' representation.
inEvent :: (FutureG s (ReactiveG s a) -> FutureG t (ReactiveG t b))
        -> (EventG s a -> EventG t b)
inEvent f = Event . f . eFuture

-- | Apply a unary function inside an 'EventG' representation.
inEvent2 :: (FutureG t (ReactiveG t a) -> FutureG t (ReactiveG t b)
                                       -> FutureG t (ReactiveG t c))
         -> (EventG t a -> EventG t b -> EventG t c)
inEvent2 f = inEvent . f . eFuture

-- | Apply a unary function inside the 'rEvent' part of a 'Reactive'
-- representation.
inREvent :: (EventG    s a -> EventG    t a)
         -> (ReactiveG s a -> ReactiveG t a)
inREvent f ~(a `Stepper` e) = a `Stepper` f e

-- | Apply a unary function inside the future reactive inside a 'Reactive'
-- representation.
inFutR :: (FutureG s (ReactiveG s b) -> FutureG t (ReactiveG t b))
       -> (ReactiveG s b -> ReactiveG t b)
inFutR = inREvent . inEvent


{--------------------------------------------------------------------
    Showing values (exposing rep)
--------------------------------------------------------------------}

isNeverE :: (Bounded t, Eq t) => EventG t a -> Bool
isNeverE = isNeverF . eFuture

-- | Make the event into a list of futures
eFutures :: (Bounded t, Eq t) => EventG t a -> [FutureG t a]
eFutures e | isNeverE e = []
eFutures (Event (Future (t,a `Stepper` e))) = Future (t,a) : eFutures e

-- TODO: redefine 'eFutures' as an unfold

-- TODO: does this isNeverE interfere with laziness?  Does it need an unamb?

-- Show a future
sFuture :: (Show t, Show a) => FutureG t a -> String
sFuture = show . unFuture

-- sFuture (Future (Max MinBound,a)) = "(-infty," ++ show a ++ ")"
-- sFuture (Future (Max MaxBound,_)) = "(infty,_)"
-- sFuture (Future (Max (NoBound t),a)) = "(" ++ show t ++ "," ++ show a ++ ")"

-- TODO: Better re-use in sFuture.

-- Truncated show
sFutures :: (Show t, Show a) => [FutureG t a] -> String

-- sFutures = show

-- This next implementation blocks all output until far future occurrences
-- are detected, which causes problems for debugging.  I like the "...",
-- so look for another implementation.

-- sFutures fs =
--   let maxleng = 20
--       a   = (intersperse "->" . map sFuture) fs
--       inf = length (take maxleng a) == maxleng
--   in
--     if not inf then concat a
--                else concat (take maxleng a) ++ "..."

-- This version uses a lazier intersperse
-- sFutures = take 100 . concat . intersperse' "->" . map sFuture

-- The following version adds "..." in case of truncation.

sFutures fs = leading early ++ trailing late
 where
  (early,late) = splitAt 20 fs
  leading  = concat . intersperse' "->" . map sFuture
  trailing [] = ""
  trailing _  = "-> ..."
   

-- TODO: clean up sFutures def: use intercalate, concat before trimming,
-- and define&use a general function for truncating and adding "...".
-- Test.

instance (Eq t, Bounded t, Show t, Show a) => Show (EventG t a) where
  show = ("Event: " ++) . sFutures . eFutures

instance (Eq t, Bounded t, Show t, Show a) => Show (ReactiveG t a) where
  show (x `Stepper` e) = show x ++ " `Stepper` " ++ show e


{--------------------------------------------------------------------
    Execution
--------------------------------------------------------------------}

-- | Run an event in the current thread.  Use the given time sink to sync
-- time, i.e., to wait for an output time before performing the action.
runE :: forall t. (Ord t, Bounded t) => Sink t -> Sink (EventG t Action)
runE sync ~(Event (Future (Max t,r)))
  | t == maxBound = return () -- finished!
  | otherwise     = sync t >> runR sync r

-- In most cases, the value of t won't be known ahead of time, so just
-- evaluating t will do the necessary waiting.


-- | Run an event in a new thread, using the given time sink to sync time.
forkE :: (Ord t, Bounded t) => Sink t -> EventG t Action -> IO ThreadId
forkE = (fmap.fmap) forkIO runE

-- TODO: Revisit this tsync definition.  For instance, maybe the MaxBound
-- case ought to simply return.

-- | Run a reactive value in the current thread, using the given time sink
-- to sync time.
runR :: (Bounded t, Ord t) => Sink t -> Sink (ReactiveG t Action)
runR sync (act `Stepper` e) = act >> runE sync e
                      
-- | Run a reactive value in a new thread, using the given time sink to
-- sync time.  The initial action happens in the current thread.
forkR :: (Ord t, Bounded t) => Sink t -> ReactiveG t Action -> IO ThreadId
forkR = (fmap.fmap) forkIO runR

-----

-- intersperse             :: a -> [a] -> [a]
-- intersperse _   []      = []
-- intersperse _   [x]     = [x]
-- intersperse sep (x:xs)  = x : sep : intersperse sep xs

-- Lazier intersperse

intersperse'             :: a -> [a] -> [a]
intersperse' _   []      = []
intersperse' sep (x:xs)  = x : continue xs
 where
   continue [] = []
   continue xs' = sep : intersperse' sep xs'