module Graphics.GPipe.Context.GLFW.RPC where

-- stdlib
import           Control.Concurrent            (ThreadId, myThreadId)
import           Control.Concurrent.MVar       (newEmptyMVar, putMVar, takeMVar)
import           Control.Concurrent.STM        (STM, atomically)
import           Control.Concurrent.STM.TQueue (TQueue, newTQueue, peekTQueue,
                                                tryReadTQueue, writeTQueue)
import           Data.Sequence                 (Seq, empty, (|>))
-- local
--import qualified Graphics.GPipe.Context.GLFW.Calls as Call

data Handle = Handle ThreadId (TQueue RPC)
    deriving
    ( Handle -> Handle -> Bool
(Handle -> Handle -> Bool)
-> (Handle -> Handle -> Bool) -> Eq Handle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Handle -> Handle -> Bool
$c/= :: Handle -> Handle -> Bool
== :: Handle -> Handle -> Bool
$c== :: Handle -> Handle -> Bool
Eq
    )

-- TODO: change RPC to a chan of `IO ()` and collapse `runActions`
data RPC
    = Execute (IO ())
    | Noop

-- | Create an RPC handle bound to the current thread. Actions sent from the
-- bound thread will just be run w/o doing an RPC.
newBound :: IO Handle
newBound :: IO Handle
newBound = do
    ThreadId
tid <- IO ThreadId
myThreadId
    TQueue RPC
comm <- STM (TQueue RPC) -> IO (TQueue RPC)
forall a. STM a -> IO a
atomically (STM (TQueue RPC) -> IO (TQueue RPC))
-> STM (TQueue RPC) -> IO (TQueue RPC)
forall a b. (a -> b) -> a -> b
$ STM (TQueue RPC)
forall a. STM (TQueue a)
newTQueue
    Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> IO Handle) -> Handle -> IO Handle
forall a b. (a -> b) -> a -> b
$ ThreadId -> TQueue RPC -> Handle
Handle ThreadId
tid TQueue RPC
comm

-- XXX: consider pushing thread-check to all callsites of sendEffect, fetchResult
-- TODO: dry-up thread id check
sendEffect :: Handle -> IO () -> IO ()
sendEffect :: Handle -> IO () -> IO ()
sendEffect (Handle ThreadId
boundTid TQueue RPC
comm) IO ()
action = do
    ThreadId
tid <- IO ThreadId
myThreadId
    if ThreadId
boundTid ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
tid
        then IO ()
action
        else STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue RPC -> RPC -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue RPC
comm (IO () -> RPC
Execute IO ()
action)

fetchResult :: Handle -> IO a -> IO a
fetchResult :: Handle -> IO a -> IO a
fetchResult (Handle ThreadId
boundTid TQueue RPC
comm) IO a
action = do
    ThreadId
tid <- IO ThreadId
myThreadId
    if ThreadId
boundTid ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
tid
        then IO a
action
        else do
            MVar a
reply <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
            -- XXX: Make sure the value put in the MVar is evaluated first
            STM () -> IO ()
forall a. STM a -> IO a
atomically(STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue RPC -> RPC -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue RPC
comm (IO () -> RPC
Execute (IO () -> RPC) -> IO () -> RPC
forall a b. (a -> b) -> a -> b
$ IO a
action IO a -> (a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
reply)
            MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
reply

drainComm :: TQueue a -> STM (Seq a)
drainComm :: TQueue a -> STM (Seq a)
drainComm TQueue a
queue = Seq a -> STM (Seq a)
go Seq a
forall a. Seq a
empty
    where
        go :: Seq a -> STM (Seq a)
go Seq a
rpcs = do
            Maybe a
result <- TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
queue
            case Maybe a
result of
                Just a
rpc -> Seq a -> STM (Seq a)
go (Seq a -> STM (Seq a)) -> Seq a -> STM (Seq a)
forall a b. (a -> b) -> a -> b
$ Seq a
rpcs Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
|> a
rpc
                Maybe a
Nothing  -> Seq a -> STM (Seq a)
forall (m :: * -> *) a. Monad m => a -> m a
return Seq a
rpcs

runActions :: Foldable t => t RPC -> IO ()
runActions :: t RPC -> IO ()
runActions = (RPC -> IO ()) -> t RPC -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RPC -> IO ()
go
    where
        go :: RPC -> IO ()
go RPC
Noop             = [Char] -> IO ()
forall a. Show a => a -> IO ()
print [Char]
"noop"
        go (Execute IO ()
action) = IO ()
action

awaitActions :: Handle -> IO RPC
awaitActions :: Handle -> IO RPC
awaitActions (Handle ThreadId
_ TQueue RPC
comm) = STM RPC -> IO RPC
forall a. STM a -> IO a
atomically (STM RPC -> IO RPC)
-> (TQueue RPC -> STM RPC) -> TQueue RPC -> IO RPC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue RPC -> STM RPC
forall a. TQueue a -> STM a
peekTQueue (TQueue RPC -> IO RPC) -> TQueue RPC -> IO RPC
forall a b. (a -> b) -> a -> b
$ TQueue RPC
comm

processActions :: Handle -> IO ()
processActions :: Handle -> IO ()
processActions (Handle ThreadId
_ TQueue RPC
comm) = (STM (Seq RPC) -> IO (Seq RPC)
forall a. STM a -> IO a
atomically (STM (Seq RPC) -> IO (Seq RPC))
-> (TQueue RPC -> STM (Seq RPC)) -> TQueue RPC -> IO (Seq RPC)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue RPC -> STM (Seq RPC)
forall a. TQueue a -> STM (Seq a)
drainComm (TQueue RPC -> IO (Seq RPC)) -> TQueue RPC -> IO (Seq RPC)
forall a b. (a -> b) -> a -> b
$ TQueue RPC
comm) IO (Seq RPC) -> (Seq RPC -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Seq RPC -> IO ()
forall (t :: * -> *). Foldable t => t RPC -> IO ()
runActions