Dispatch.hs

{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
module PrioritySync.Internal.Dispatch
    (dispatch,TaskHandle,reprioritize,getResult,tryGetResult)
    where

import PrioritySync.Internal.Prioritized
import PrioritySync.Internal.Receipt
import PrioritySync.Internal.RoomGroup
import PrioritySync.Internal.Room
import PrioritySync.Internal.ClaimContext
import Control.Concurrent
import Control.Concurrent.STM

data TaskHandle p a = TaskHandle {
    task_reprioritize :: (p -> p) -> STM (),
    task_result :: TVar (Maybe a) }

-- | Perform a task on another thread.  This task can be reprioritized and canceled.
dispatch :: (RoomGroup c,ClaimContext c,Prioritized (ClaimHandle c)) => 
            c -> IO a -> IO (TaskHandle (Priority (ClaimHandle c)) a)
dispatch c actionM =
    do result <- newTVarIO Nothing
       receive_task_handle <- newTVarIO Nothing
       _ <- forkIO $ (atomically . writeTVar result . Just) =<< claim Acquire (Receipt c (writeTVar receive_task_handle . Just) (const $ return ())) actionM
       task_handle <- atomically $ maybe retry return =<< readTVar receive_task_handle
       return $ TaskHandle (reprioritize task_handle) result

-- | Change the priority of a task.  This will not work if the task has already started.
instance Prioritized (TaskHandle p a) where
    type Priority (TaskHandle p a) = p
    reprioritize = task_reprioritize

-- | Wait for the result from this task.
getResult :: TaskHandle p a -> STM a
getResult task = maybe retry return =<< readTVar (task_result task)

-- | Non-blocking version of 'getResult'.
tryGetResult :: TaskHandle p a -> STM (Maybe a)
tryGetResult = readTVar . task_result