Futures.hs

{- |
Module      :  <File name or $Header$ to be replaced automatically>
Description :  This module implements several kinds of futures using Concurrent Haskell
Maintainer  :  sabel@ki.cs.uni-frankfurt.de; willig@ki.cs.uni-frankfurt.de
Stability   :  provisional
Portability :  portable

This module implements explicit futures ('EFuture', 'efuture', 'force') as well as several variants of implicit futures
('future', 'recursiveFuture', 'strictFuture', 'strictRecursiveFuture', 'lazyFuture', 'lazyRecursiveFuture')
While explicit futures must be forced (using 'force') if their value is needed, this is not necessary for implicit futures.
For implicit futures it is necessary to put them into the global wrapper 'withFuturesDo'.
-}

module Control.Concurrent.Futures.Futures (
             EFuture,
             efuture,
             force,
             future,
             recursiveFuture,
             withFuturesDo,
             strictFuture,
             strictRecursiveFuture,
             lazyFuture,
             lazyRecursiveFuture,
             hbind,
             newhandled,
             bhandle
  ) where
import Control.Concurrent
import Control.Exception(evaluate)
import System.IO.Unsafe

--import Data.IO

-- | The type 'EFuture' implements explicit futures, i.e. if the value of the future is need it must be forced explicitly using 'force'
type EFuture a = MVar a

-- | 'efuture' creates an explicit future, i.e. the computation is performed concurrently. The future value can be forced using 'force'
efuture :: IO a -> IO (EFuture a)
efuture act = 
 do  ack <- newEmptyMVar
     forkIO (act >>= putMVar ack)
     return ack

-- | 'force' forces the value of an explicit future ('EFuture'), i.e. the calling thread blocks until the result becomes available.
force :: EFuture a -> IO a
force = takeMVar


-- | 'future' creates an implicit future. A non-blocking concurrent computation is started. If the value of the future is needed, then
--  the future will be forced implicitly. The concurrent computation is killed if the calling thread stops, even if 'future' is used
--  within 'withFuturesDo'.
future :: IO a -> IO a    
future code = do ack <-newEmptyMVar
                 thread <- forkIO (code >>= putMVar ack)
                 unsafeInterleaveIO (do result <- takeMVar ack
                                        killThread thread
                                        return result)

-- | 'recursiveFuture' behaves similar to 'future' with the difference that the future is recursive, i.e. the future created by
--  'recursiveFuture' is used as argument of the code of the future.
recursiveFuture :: (a -> IO a) -> IO a    
recursiveFuture code = do ack <- newEmptyMVar
                          res <- unsafeInterleaveIO (takeMVar ack)
                          thread <- forkIO (code res >>= putMVar ack)
                          unsafeInterleaveIO (do res' <- evaluate res
                                                 killThread thread
                                                 return res')

-- --------------------------------------------------
-- not-exported functions for the global manager, they shouldn't be visible outside this module.
-- 

-- The manager is an MVar containing a list of unit-tuples
type Manager = MVar [()]

-- creating a new Manager
newManager :: IO Manager
newManager = newMVar []

-- register a future to a manager
register :: a -> Manager -> IO ()
register  l man =  do
                     list <- takeMVar man
                     putMVar man ((seq l ()):list)

-- synchronizeMan forces the evaluation of all registered futures 
synchronizeMan :: Manager -> IO ()
synchronizeMan man = do 
                      list <- takeMVar man
                      seqList list

seqList []     = return ()
seqList (x:xs) = seq x (seqList xs)


globalMan = unsafePerformIO newManager

--
-- --------------------------------------------------

-- | 'withFuturesDo' is the global wrapper which should be used around the code involving futures.
--  I.e., instead of writing @main=code@ one should use @main=withFuturesDo code@. Note, that there
-- should be only one call to 'withFuturesDo' in a program.  
withFuturesDo :: IO () -> IO ()
withFuturesDo code =  do code   
                         synchronizeMan globalMan


-- | creating a strict future is similar to 'future' with the difference that if used inside 'withFuturesDo'
-- it is guaranteed that the concurrent computation is forced (and finished) before the main thread terminates.
-- Warning: 'strictFuture' should only be used within the global wrapper 'withFuturesDo'!
strictFuture :: IO a -> IO a
strictFuture code = do fut <- future code
                       register fut globalMan
                       return fut

-- | a recursive variant of 'strictFuture' (see 'recursiveFuture' and 'future)
-- Warning: 'strictRecursiveFuture' should only be used within the global wrapper 'withFuturesDo'!
strictRecursiveFuture :: (a -> IO a) -> IO a    
strictRecursiveFuture code = do fut <- recursiveFuture code
                                register fut globalMan
                                return fut

-- | a lazy future. Initially, no concurrent computation is started, but if the lazy future gets (implicitly) forced,
-- then the lazy future becomes a strict future.
-- Warning: 'lazyFuture' should only be used within the global wrapper 'withFuturesDo'!
lazyFuture :: IO a -> IO a     
lazyFuture code = unsafeInterleaveIO (strictFuture code)

-- | a recursive variant of 'lazyFuture' (see 'recursiveFuture' and 'future)
-- Warning: 'lazyRecursiveFuture' should only be used within the global wrapper 'withFuturesDo'!
lazyRecursiveFuture :: (a -> IO a) -> IO a     
lazyRecursiveFuture code = unsafeInterleaveIO (strictRecursiveFuture code)

-- | a new handle component. 
bhandle :: (a -> (a -> IO ()) -> t) -> IO t
bhandle x = do 
             f' <- newEmptyMVar
             f  <- lazyFuture  (do 
                                 v <- takeMVar f'
                                 putMVar f' v
                                 return v
                               )
             h <- strictFuture (return (\z -> (putMVar f' z)))
             return (x f h)
             
-- | creates a new handle.
newhandled :: IO (a -> IO (), a)
newhandled = bhandle (\f -> \h -> (h,f))


-- | binds a handle to its value.
hbind :: (t -> t1) -> t -> t1
hbind h v = h v