{-# 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(..), 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)
--------------------------------------------------------------------}

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

-- TODO: redefine 'eFutures' as an unfold


-- Show a future
sFuture :: (Show t, Show a) => FutureG t a -> String
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 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) ++ "..."

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

instance (Show a, Show b) => Show (EventG a b) where
  show = sFutures . eFutures

instance (Show x, Show y) => Show (ReactiveG x y) 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 => Sink t -> Sink (EventG t Action)
runE sync (Event (Future (Max bt,r))) = tsync bt (runR sync r)
 where
   tsync :: AddBounds t -> Sink Action
   tsync MinBound    = id                               -- no wait
   tsync (NoBound t) = (sync t >>)                      -- wait
   tsync MaxBound    = const (return ())                -- finished!

-- TODO: I'm not sure about the MaxBound case.  We could instead just wait
-- forever (cheaply).  Try out this terminating definition instead.

-- | Run an event in a new thread, using the given time sink to sync time.
forkE :: Ord 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 :: 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 => Sink t -> ReactiveG t Action -> IO ThreadId
forkR = (fmap.fmap) forkIO runR
