Future.hs

{-# LANGUAGE RecursiveDo #-}
{-# OPTIONS -fno-warn-orphans #-}

----------------------------------------------------------------------
-- |
-- Module      :  Data.Future
-- Copyright   :  (c) Conal Elliott 2007
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- A /future value/ is a value that will become knowable only later.  This
-- module gives a way to manipulate them functionally.  For instance,
-- @a+b@ becomes knowable when the later of @a@ and @b@ becomes knowable.
-- See <http://en.wikipedia.org/wiki/Futures_and_promises>.
-- 
-- Primitive futures can be things like /the value of the next key you
-- press/, or /the value of LambdaPix stock at noon next Monday/.
-- 
-- Composition is via standard type classes: 'Functor', 'Applicative',
-- 'Monad', and 'Monoid'.  Some comments on the 'Future' instances of
-- these classes:
-- 
-- * Monoid: 'mempty' is a future that never becomes knowable.
--   @a `mappend` b@ is whichever of @a@ and @b@ is knowable first.
-- 
-- * 'Functor': apply a function to a future.  The result is knowable when
--   the given future is knowable.
-- 
-- * 'Applicative': 'pure' gives value knowable since the beginning of
--   time.  '(\<*\>)' applies a future function to a future argument.
--   Result available when /both/ are available, i.e., it becomes knowable
--   when the later of the two futures becomes knowable.
-- 
-- * 'Monad': 'return' is the same as 'pure' (as always).  @(>>=)@ cascades
--   futures.  'join' resolves a future future into a future.
-- 
-- The current implementation is nondeterministic in 'mappend' for futures
-- that become knowable at the same time or nearly the same time.  I
-- want to make a deterministic implementation.
-- 
-- See "Data.SFuture" for a simple denotational semantics of futures.  The
-- current implementation /does not/ quite implement this target semantics
-- for 'mappend' when futures are available simultaneously or nearly
-- simultaneously.  I'm still noodling how to implement that semantics.
----------------------------------------------------------------------

module Data.Future
  ( Future, force, newFuture
  , future
  , never, race, race'
  , runFuture
  ) where

import Control.Concurrent
import Data.Monoid (Monoid(..))
import Control.Applicative
import Control.Monad (join)
import System.IO.Unsafe
-- import Foreign (unsafePerformIO)

-- TypeCompose
import Control.Instances () -- IO monoid

-- About determinacy: for @f1 `mappend` f2@, we might get @f2@ instead of
-- @f1@ even if they're available simultaneously.  It's even possible to
-- get the later of the two if they're nearly simultaneous.
-- 
-- What will it take to get deterministic semantics for @f1 `mappend` f2@?
-- Idea: make an "event occurrence" type, which is a future with a time
-- and a value.  (The time is useful for snapshotting continuous
-- behaviors.)  When one occurrence happens with a time @t@, query whether
-- the other one occurs by the same time.  What does it take to support
-- this query operation?
-- 
-- Another idea: speculative execution.  When one event occurs, continue
-- to compute consequences.  If it turns out that an earlier occurrence
-- arrives later, do some kind of 'retry'.

-- The implementation is very like IVars.  Each future contains an MVar
-- reader.  'force' blocks until the MVar is written.


-- | Value available in the future.
newtype Future a =
  Future {
    force :: IO a -- ^ Get a future value.  Blocks until the value is
                  -- available.  No side-effect.
  }

-- | Make a 'Future' and a way to fill it.  The filler should be invoked
-- only once.  Later fillings may block.
newFuture :: IO (Future a, a -> IO ())
newFuture = do v <- newEmptyMVar
               return (Future (readMVar v), putMVar v)

-- | Make a 'Future', given a way to compute a (lazy) value.
future :: IO a -> Future a
future mka = unsafePerformIO $
             do (fut,snk) <- newFuture
                -- let snk' a = putStrLn "sink" >> snk a
                -- putStrLn "fork"
                forkIO $ mka >>= snk
                return fut
{-# NOINLINE future #-}

instance Functor Future where
  fmap f (Future get) = future (fmap f get)

instance Applicative Future where
  pure a                      = Future (pure a)
  Future getf <*> Future getx = future (getf <*> getx)

-- Note Applicative's pure uses 'Future' as an optimization over
-- 'future'.  No thread or MVar.

instance Monad Future where
  return            = pure
  Future geta >>= h = future (geta >>= force . h)

instance Monoid (Future a) where
  mempty  = never
  mappend = race'

-- | A future that will never happen
never :: Future a
never = fst (unsafePerformIO newFuture)
{-# NOINLINE never #-}

-- | A future equal to the earlier available of two given futures.  See also 'race\''.
race :: Future a -> Future a -> Future a
Future geta `race` Future getb =
  unsafePerformIO $
  do (w,snk) <- newFuture
     let run get = forkIO $ get >>= snk
     run geta
     run getb
     return w
{-# NOINLINE race #-}

-- | Like 'race', but the winner kills the loser's thread.
race' :: Future a -> Future a -> Future a
Future geta `race'` Future getb =
  unsafePerformIO $
  do (w,snk) <- newFuture
     let run get tid = forkIO $ do a <- get
                                   killThread tid
                                   snk a
     mdo ta <- run geta tb
         tb <- run getb ta
         return ()
     return w
{-# NOINLINE race' #-}

-- TODO: make race & race' deterministic, using explicit times.  Figure
-- out how one thread can inquire whether the other whether it is
-- available by a given time, and if so, what time.

-- | Run an 'IO'-action-valued 'Future'.
runFuture :: Future (IO ()) -> IO ()
runFuture = join . force