{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
-- Module      :  FRP.Reactive.Internal.TVal
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Timed values.  A primitive interface for futures.
----------------------------------------------------------------------

module FRP.Reactive.Internal.TVal
  (
    makeFuture, makeEvent, Fed, MkFed
  ) where


import Control.Arrow (first)
import Control.Applicative ((<$>))
import Control.Monad (forever)
import Control.Concurrent (forkIO,yield)
import Control.Concurrent.Chan
import System.IO.Unsafe (unsafePerformIO)

import Data.Unamb (unamb,assuming)

import FRP.Reactive.Improving (Improving(..))
import FRP.Reactive.Future (FutureG,future)
import FRP.Reactive.Reactive (Event,TimeT,ITime)
import FRP.Reactive.PrimReactive (futuresE)

import FRP.Reactive.Internal.Misc (Sink)
import FRP.Reactive.Internal.Clock
import FRP.Reactive.Internal.Timing (sleepPast)
import FRP.Reactive.Internal.IVar

-- | A value that becomes defined at some time.  'timeVal' may block if
-- forced before the time & value are knowable.  'definedAt' says whether
-- the value is defined at (and after) a given time and likely blocks
-- until the earlier of the query time and the value's actual time.
data TVal t a = TVal { timeVal :: (t,a), definedAt :: t -> Bool }

-- | Make a 'TVal' and a sink to write to it (at most once).
makeTVal :: Clock TimeT -> IO (TVal TimeT a, Sink a)
makeTVal (Clock getT serial) = f <$> newEmptyIVar
 where
   f v = ( TVal (readIVar v)
                (\ t -> unsafePerformIO $ do 
                            sleepPast getT t
                            do value <- tryReadIVar v
                               return $ case value of
                                           -- We're past t, so if it's not 
                                           -- defined now, it wasn't at t.
                                           Nothing -> False
                                           -- If it became defined before
                                           -- t, then it's defined now.
                                           Just (t',_) -> t' < t)
         , \ a -> serial (getT >>= \ t -> writeIVar v (t,a))
         )

-- TODO: oops - the definedAt in makeTVal always waits until the given
-- time.  It could also grab the time and compare with t.  Currently that
-- comparison is done in tValImp.  How can we avoid the redundant test?  We
-- don't really have to avoid it, since makeTVal isn't exported.

-- | 'TVal' as 'Future'
tValFuture :: Ord t => TVal t a -> FutureG (Improving t) a
tValFuture v = future (tValImp v) (snd (timeVal v))

-- | 'TVal' as 'Improving'
tValImp :: Ord t => TVal t a -> Improving t
tValImp v = Imp ta (\ t -> assuming (not (definedAt v t)) GT
                            `unamb` (ta `compare` t))
 where
   ta = fst (timeVal v)

-- | An @a@ that's fed by a @b@
type Fed a b = (a, Sink b)

-- | Make a 'Fed'.
type MkFed a b = IO (Fed a b)

-- | Make a connected sink/future pair.  The sink may only be written to once.
makeFuture :: Clock TimeT -> MkFed (FutureG ITime a) a
makeFuture = (fmap.fmap.first) tValFuture makeTVal

-- | Make a new event and a sink that writes to it.  Uses the given
-- clock to serialize and time-stamp.
makeEvent :: Clock TimeT -> MkFed (Event a) a
makeEvent clock = (fmap.first) futuresE (listSink (makeFuture clock))

listSink :: MkFed a b -> MkFed [a] b
listSink mk = do chanA <- newChan
                 chanB <- newChan
                 forkIO . forever $ do
                     (a,snk) <- mk
                     writeChan chanB a
                     readChan  chanA >>= snk
                 as <- getChanContents chanB
                 return (as, writeChanY chanA)
 where
   -- Yield control after each input write.  Helps responsiveness
   -- tremendously.
   writeChanY ch x = writeChan ch x >> yield
   -- writeChanY = (fmap.fmap) (>> yield) writeChan