Future.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
-- Module      :  FRP.Reactive.Internal.Future
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Representation of future values
----------------------------------------------------------------------

module FRP.Reactive.Internal.Future
  (
    -- * Time & futures
    Time
  , FutureG(..), inFuture, inFuture2
  , runF
  ) where


import Control.Applicative (Applicative(..))

import Test.QuickCheck

import FRP.Reactive.Internal.Misc (Sink)
import Data.Max
import Data.AddBounds
import Data.PairMonad ()


-- | Time used in futures.  The parameter @t@ can be any @Ord@ type.  The
-- added bounds represent -Infinity and +Infinity.  Pure values have time
-- minBound (-Infinity), while never-occurring futures have time maxBound
-- (+Infinity).
type Time t = Max (AddBounds t)


-- | A future value of type @a@ with time type @t@.  Simply a
-- time\/value pair.  Particularly useful with time types that have
-- non-flat structure.
newtype FutureG t a = Future { unFuture :: (Time t, a) }
  deriving (Functor, Applicative, Monad, Show,  Arbitrary)

-- TODO: see if the following definition is really necessary, instead of deriving.

--  The 'Applicative' and 'Monad' instances rely on the 'Monoid' instance
-- of 'Max'.


-- | Apply a unary function within the 'FutureG' representation.
inFuture :: ((Time t, a) -> (Time t', b))
         -> FutureG t a  -> FutureG t' b
inFuture f = Future . f . unFuture

-- | Apply a binary function within the 'FutureG' representation.
inFuture2 :: ((Time t, a) -> (Time t', b) -> (Time t', c))
          ->  FutureG t a -> FutureG t' b -> FutureG t' c
inFuture2 f =  inFuture . f . unFuture


-- | Run a future in the current thread.  Use the given time sink to sync
-- time, i.e., to wait for an output time before performing the action.
runF :: Ord t => Sink t -> FutureG t (IO a) -> IO a
runF sync (Future (Max t,io)) = tsync t >> io
 where
   tsync MinBound     = putStrLn "runE: skipping MinBound"
   tsync (NoBound t') = sync t'
   tsync MaxBound     = error "runE: infinite wait"