Future.hs

-- {-# LANGUAGE RecursiveDo #-}
-- For ghc-6.6 compatibility
{-# OPTIONS_GHC -fglasgow-exts #-}
{-# 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
  , runFuture
  ) where

import Control.Concurrent
import Data.Monoid (Monoid(..))
import Control.Applicative
import Control.Monad (join,forever)
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.
data Future a =
    -- | Future that may arrive.  The 'IO' blocks until available.  No side-effect.
    Future (IO a)
    -- | Future that never arrives.
  | Never

-- Why not simply use @a@ (plain-old lazy value) in place of @IO a@ in
-- 'Future'?  Several of the definitions below get simpler, and many
-- examples work.  See NewFuture.hs.  But sometimes that implementation
-- mysteriously crashes or just doesn't update.  Odd.

-- | Access a future value.  Blocks until available.
force :: Future a -> IO a
force (Future io) = io
force Never       = hang

-- | Block forever
hang :: IO a
hang = do -- putStrLn "warning: blocking forever."
          -- Any never-terminating computation goes here
          -- This one can yield an exception "thread blocked indefinitely"
          -- newEmptyMVar >>= takeMVar
          -- sjanssen suggests this alternative:
          forever $ threadDelay maxBound
          -- forever's return type is (), though it could be fully
          -- polymorphic.  Until it's fixed, I need the following line.
          return undefined

-- | Make a 'Future' and a way to fill it.  The filler should be invoked
-- only once.
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 value.
future :: IO a -> Future a
future mka = unsafePerformIO $
             do (fut,sink) <- newFuture
                forkIO $ mka >>= sink
                return fut
{-# NOINLINE future #-}

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

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

-- 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)
  Never       >>= _ = Never

instance Monoid (Future a) where
  mempty  = Never
  mappend = race

-- | Race to extract a value.
race :: Future a -> Future a -> Future a
Never `race` b     = b
a     `race` Never = a
a     `race` b     = unsafePerformIO $
                     do (c,sink) <- newFuture
                        let run fut tid = forkIO $ do x <- force fut
                                                      killThread tid
                                                      sink x
                        mdo ta <- run a tb
                            tb <- run b ta
                            return ()
                        return c
{-# NOINLINE race #-}

-- TODO: make 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