{-# 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
  (
    makeEvent, Fed, MkFed
  ) where


-- import Control.Arrow (first)
import Control.Applicative ((<$>))
import Control.Monad (forever)
import Control.Concurrent (forkIO,yield,ThreadId)
import Control.Concurrent.Chan
-- import System.Mem.Weak (mkWeakPtr,deRefWeak)
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)
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.  'undefinedAt' says
-- whether the value is still undefined at 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 }

makeTVal :: Clock TimeT -> MkFed (TVal TimeT a) a
makeTVal (Clock getT _) = f <$> newEmptyIVar
  where
    f v = (TVal (readIVar v) (unsafePerformIO . undefAt), sink)
     where   
      undefAt t =
        -- Read v after time t.  If it's undefined, then it wasn't defined
        -- at t.  If it is defined, then see whether it was defined before t.
        do -- ser $ putStrLn $ "sleepPast " ++ show t
           sleepPast getT t
--            maybe True ((> t) . fst) <$> tryReadIVar v
           
           value <- tryReadIVar v
           case value of
             -- We're past t, if it's not defined now, it wasn't at t.
             Nothing     -> return False
             -- If it became defined before t, then it's defined now.
             Just (t',_) -> return (t' < t)

      sink a = do t <- getT
                  writeIVar v (t,a)

  --  sink a = getT >>= writeIVar v . flip (,) a

-- TODO: oops - the undefAt 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)


-- The 'listSink' version of 'makeEvent' is not revealing the finiteness
-- of future times until those times are known exactly.  Since many
-- 'Event' operations (including 'mappend' and 'join') check for infinite
-- time (Max MaxBound) before anything else, they'll get stuck immediately.

-- | 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 =
  do chanA <- newChan
     chanF <- newChan
     spin $ do
         (tval,snka) <- makeTVal clock
         writeChan chanF (tValFuture tval)
         readChan  chanA >>= snka
     futs <- getChanContents chanF
     return (futuresE futs, writeChanY chanA)

-- makeTVal :: Clock TimeT -> MkFed (TVal TimeT a) a


{-

-- | 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))

-- Turn a single-feedable into a multi-feedable
listSink :: MkFed a b -> MkFed [a] b
listSink mk = do chanA <- newChan
                 chanB <- newChan
                 spin $ do
                     (a,snk) <- mk
                     writeChan chanA a
                     readChan  chanB >>= snk
                 as <- getChanContents chanA
                 return (as, writeChanY chanB)

-}

spin :: IO a -> IO ThreadId
spin = forkIO . forever


-- Yield control after channel write.  Helps responsiveness
-- tremendously.
writeChanY :: Chan a -> Sink a
writeChanY ch x = writeChan ch x >> yield
-- Equivalently:
-- writeChanY = (fmap.fmap) (>> yield) writeChan




-- I want to quit gathing input when no one is listening, to eliminate a
-- space leak.  Here's my first attempt:

{-

listSink :: MkFed a b -> MkFed [a] b
listSink mk = do chanA <- newChan
                 chanB <- newChan
                 wchanA <- mkWeakPtr chanA Nothing
                 let loop =
                       do mbch <- deRefWeak wchanA
                          case mbch of
                            Nothing -> do putStrLn "qutting"
                                          return ()
                            Just ch ->
                              do putStrLn "something"
                                 (a,snk) <- mk
                                 writeChan ch a
                                 readChan chanB >>= snk
                                 loop
                 forkIO loop
                 as  <- getChanContents chanA
                 return (as, writeChanY chanB)

-}

-- This attempt fails.  The weak reference gets lost almost immediately.
-- My hunch: ghc optimizes away the Chan representation when compiling
-- getChanContents, and just holds onto the read and write ends (mvars),
-- via a technique described at ICFP 07.  I don't know how to get a
-- reliable weak reference, without altering Control.Concurrent.Chan.
-- 
-- Apparently this problem has popped up before.  See
-- http://haskell.org/ghc/docs/latest/html/libraries/base/System-Mem-Weak.html#v%3AaddFinalizer