--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OpenGL.GL.SyncObjects
-- Copyright   :  (c) Sven Panne 2019
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- This module corresponds to section 4.1 (Sync Objects and Fences) of the
-- OpenGL 4.4 specs.
--
--------------------------------------------------------------------------------

module Graphics.Rendering.OpenGL.GL.SyncObjects (
   -- * Sync Objects and Fences
   SyncObject, syncGpuCommandsComplete,

   -- * Waiting for Sync Objects
   WaitTimeout, WaitFlag(..), WaitResult(..), clientWaitSync,
   waitSync, maxServerWaitTimeout,

   -- * Sync Object Queries
   SyncStatus(..), syncStatus
) where

import Control.Monad.IO.Class
import Data.ObjectName
import Data.StateVar
import Foreign.Marshal.Utils ( with )
import Foreign.Ptr ( nullPtr )
import Graphics.Rendering.OpenGL.GL.DebugOutput
import Graphics.Rendering.OpenGL.GL.GLboolean
import Graphics.Rendering.OpenGL.GL.PeekPoke
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.GL

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

newtype SyncObject = SyncObject { SyncObject -> GLsync
syncID :: GLsync }
   deriving ( SyncObject -> SyncObject -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SyncObject -> SyncObject -> Bool
$c/= :: SyncObject -> SyncObject -> Bool
== :: SyncObject -> SyncObject -> Bool
$c== :: SyncObject -> SyncObject -> Bool
Eq, Eq SyncObject
SyncObject -> SyncObject -> Bool
SyncObject -> SyncObject -> Ordering
SyncObject -> SyncObject -> SyncObject
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SyncObject -> SyncObject -> SyncObject
$cmin :: SyncObject -> SyncObject -> SyncObject
max :: SyncObject -> SyncObject -> SyncObject
$cmax :: SyncObject -> SyncObject -> SyncObject
>= :: SyncObject -> SyncObject -> Bool
$c>= :: SyncObject -> SyncObject -> Bool
> :: SyncObject -> SyncObject -> Bool
$c> :: SyncObject -> SyncObject -> Bool
<= :: SyncObject -> SyncObject -> Bool
$c<= :: SyncObject -> SyncObject -> Bool
< :: SyncObject -> SyncObject -> Bool
$c< :: SyncObject -> SyncObject -> Bool
compare :: SyncObject -> SyncObject -> Ordering
$ccompare :: SyncObject -> SyncObject -> Ordering
Ord, Int -> SyncObject -> ShowS
[SyncObject] -> ShowS
SyncObject -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SyncObject] -> ShowS
$cshowList :: [SyncObject] -> ShowS
show :: SyncObject -> String
$cshow :: SyncObject -> String
showsPrec :: Int -> SyncObject -> ShowS
$cshowsPrec :: Int -> SyncObject -> ShowS
Show )

instance ObjectName SyncObject where
   isObjectName :: forall (m :: * -> *). MonadIO m => SyncObject -> m Bool
isObjectName = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. (Eq a, Num a) => a -> Bool
unmarshalGLboolean forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadIO m => GLsync -> m GLboolean
glIsSync forall b c a. (b -> c) -> (a -> b) -> a -> c
. SyncObject -> GLsync
syncID
   deleteObjectName :: forall (m :: * -> *). MonadIO m => SyncObject -> m ()
deleteObjectName = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadIO m => GLsync -> m ()
glDeleteSync forall b c a. (b -> c) -> (a -> b) -> a -> c
. SyncObject -> GLsync
syncID

instance CanBeLabeled SyncObject where
   objectLabel :: SyncObject -> StateVar (Maybe String)
objectLabel = GLsync -> StateVar (Maybe String)
objectPtrLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. SyncObject -> GLsync
syncID

syncGpuCommandsComplete :: IO SyncObject
syncGpuCommandsComplete :: IO SyncObject
syncGpuCommandsComplete =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GLsync -> SyncObject
SyncObject forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m GLsync
glFenceSync GLenum
GL_SYNC_GPU_COMMANDS_COMPLETE GLenum
0

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

type WaitTimeout = GLuint64

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

data WaitFlag = SyncFlushCommands
   deriving ( WaitFlag -> WaitFlag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WaitFlag -> WaitFlag -> Bool
$c/= :: WaitFlag -> WaitFlag -> Bool
== :: WaitFlag -> WaitFlag -> Bool
$c== :: WaitFlag -> WaitFlag -> Bool
Eq, Eq WaitFlag
WaitFlag -> WaitFlag -> Bool
WaitFlag -> WaitFlag -> Ordering
WaitFlag -> WaitFlag -> WaitFlag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WaitFlag -> WaitFlag -> WaitFlag
$cmin :: WaitFlag -> WaitFlag -> WaitFlag
max :: WaitFlag -> WaitFlag -> WaitFlag
$cmax :: WaitFlag -> WaitFlag -> WaitFlag
>= :: WaitFlag -> WaitFlag -> Bool
$c>= :: WaitFlag -> WaitFlag -> Bool
> :: WaitFlag -> WaitFlag -> Bool
$c> :: WaitFlag -> WaitFlag -> Bool
<= :: WaitFlag -> WaitFlag -> Bool
$c<= :: WaitFlag -> WaitFlag -> Bool
< :: WaitFlag -> WaitFlag -> Bool
$c< :: WaitFlag -> WaitFlag -> Bool
compare :: WaitFlag -> WaitFlag -> Ordering
$ccompare :: WaitFlag -> WaitFlag -> Ordering
Ord, Int -> WaitFlag -> ShowS
[WaitFlag] -> ShowS
WaitFlag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WaitFlag] -> ShowS
$cshowList :: [WaitFlag] -> ShowS
show :: WaitFlag -> String
$cshow :: WaitFlag -> String
showsPrec :: Int -> WaitFlag -> ShowS
$cshowsPrec :: Int -> WaitFlag -> ShowS
Show )

marshalWaitFlag :: WaitFlag -> GLbitfield
marshalWaitFlag :: WaitFlag -> GLenum
marshalWaitFlag WaitFlag
x = case WaitFlag
x of
   WaitFlag
SyncFlushCommands -> GLenum
GL_SYNC_FLUSH_COMMANDS_BIT

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

data WaitResult =
     AlreadySignaled
   | TimeoutExpired
   | ConditionSatisfied
   | WaitFailed
   deriving ( WaitResult -> WaitResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WaitResult -> WaitResult -> Bool
$c/= :: WaitResult -> WaitResult -> Bool
== :: WaitResult -> WaitResult -> Bool
$c== :: WaitResult -> WaitResult -> Bool
Eq, Eq WaitResult
WaitResult -> WaitResult -> Bool
WaitResult -> WaitResult -> Ordering
WaitResult -> WaitResult -> WaitResult
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WaitResult -> WaitResult -> WaitResult
$cmin :: WaitResult -> WaitResult -> WaitResult
max :: WaitResult -> WaitResult -> WaitResult
$cmax :: WaitResult -> WaitResult -> WaitResult
>= :: WaitResult -> WaitResult -> Bool
$c>= :: WaitResult -> WaitResult -> Bool
> :: WaitResult -> WaitResult -> Bool
$c> :: WaitResult -> WaitResult -> Bool
<= :: WaitResult -> WaitResult -> Bool
$c<= :: WaitResult -> WaitResult -> Bool
< :: WaitResult -> WaitResult -> Bool
$c< :: WaitResult -> WaitResult -> Bool
compare :: WaitResult -> WaitResult -> Ordering
$ccompare :: WaitResult -> WaitResult -> Ordering
Ord, Int -> WaitResult -> ShowS
[WaitResult] -> ShowS
WaitResult -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WaitResult] -> ShowS
$cshowList :: [WaitResult] -> ShowS
show :: WaitResult -> String
$cshow :: WaitResult -> String
showsPrec :: Int -> WaitResult -> ShowS
$cshowsPrec :: Int -> WaitResult -> ShowS
Show )

unmarshalWaitResult :: GLenum -> WaitResult
unmarshalWaitResult :: GLenum -> WaitResult
unmarshalWaitResult GLenum
x
   | GLenum
x forall a. Eq a => a -> a -> Bool
== GLenum
GL_ALREADY_SIGNALED = WaitResult
AlreadySignaled
   | GLenum
x forall a. Eq a => a -> a -> Bool
== GLenum
GL_TIMEOUT_EXPIRED = WaitResult
TimeoutExpired
   | GLenum
x forall a. Eq a => a -> a -> Bool
== GLenum
GL_CONDITION_SATISFIED = WaitResult
ConditionSatisfied
   | GLenum
x forall a. Eq a => a -> a -> Bool
== GLenum
GL_WAIT_FAILED = WaitResult
WaitFailed
   | Bool
otherwise = forall a. HasCallStack => String -> a
error (String
"unmarshalWaitResult: illegal value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GLenum
x)

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

clientWaitSync :: SyncObject -> [WaitFlag] -> WaitTimeout -> IO WaitResult
clientWaitSync :: SyncObject -> [WaitFlag] -> WaitTimeout -> IO WaitResult
clientWaitSync SyncObject
syncObject [WaitFlag]
flags =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GLenum -> WaitResult
unmarshalWaitResult forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall (m :: * -> *).
MonadIO m =>
GLsync -> GLenum -> WaitTimeout -> m GLenum
glClientWaitSync (SyncObject -> GLsync
syncID SyncObject
syncObject) (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map WaitFlag -> GLenum
marshalWaitFlag [WaitFlag]
flags))

waitSync :: SyncObject -> IO ()
waitSync :: SyncObject -> IO ()
waitSync SyncObject
syncObject =
   forall (m :: * -> *).
MonadIO m =>
GLsync -> GLenum -> WaitTimeout -> m ()
glWaitSync (SyncObject -> GLsync
syncID SyncObject
syncObject) GLenum
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral WaitTimeout
GL_TIMEOUT_IGNORED)

maxServerWaitTimeout :: GettableStateVar WaitTimeout
maxServerWaitTimeout :: GettableStateVar WaitTimeout
maxServerWaitTimeout =
   forall a. IO a -> IO a
makeGettableStateVar (forall p a. GetPName1I p => (GLint64 -> a) -> p -> IO a
getInteger64 forall a b. (Integral a, Num b) => a -> b
fromIntegral PName1I
GetMaxServerWaitTimeout)

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

data SyncStatus =
     Unsignaled
   | Signaled
   deriving ( SyncStatus -> SyncStatus -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SyncStatus -> SyncStatus -> Bool
$c/= :: SyncStatus -> SyncStatus -> Bool
== :: SyncStatus -> SyncStatus -> Bool
$c== :: SyncStatus -> SyncStatus -> Bool
Eq, Eq SyncStatus
SyncStatus -> SyncStatus -> Bool
SyncStatus -> SyncStatus -> Ordering
SyncStatus -> SyncStatus -> SyncStatus
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SyncStatus -> SyncStatus -> SyncStatus
$cmin :: SyncStatus -> SyncStatus -> SyncStatus
max :: SyncStatus -> SyncStatus -> SyncStatus
$cmax :: SyncStatus -> SyncStatus -> SyncStatus
>= :: SyncStatus -> SyncStatus -> Bool
$c>= :: SyncStatus -> SyncStatus -> Bool
> :: SyncStatus -> SyncStatus -> Bool
$c> :: SyncStatus -> SyncStatus -> Bool
<= :: SyncStatus -> SyncStatus -> Bool
$c<= :: SyncStatus -> SyncStatus -> Bool
< :: SyncStatus -> SyncStatus -> Bool
$c< :: SyncStatus -> SyncStatus -> Bool
compare :: SyncStatus -> SyncStatus -> Ordering
$ccompare :: SyncStatus -> SyncStatus -> Ordering
Ord, Int -> SyncStatus -> ShowS
[SyncStatus] -> ShowS
SyncStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SyncStatus] -> ShowS
$cshowList :: [SyncStatus] -> ShowS
show :: SyncStatus -> String
$cshow :: SyncStatus -> String
showsPrec :: Int -> SyncStatus -> ShowS
$cshowsPrec :: Int -> SyncStatus -> ShowS
Show )

unmarshalSyncStatus :: GLenum -> SyncStatus
unmarshalSyncStatus :: GLenum -> SyncStatus
unmarshalSyncStatus GLenum
x
   | GLenum
x forall a. Eq a => a -> a -> Bool
== GLenum
GL_UNSIGNALED = SyncStatus
Unsignaled
   | GLenum
x forall a. Eq a => a -> a -> Bool
== GLenum
GL_SIGNALED = SyncStatus
Signaled
   | Bool
otherwise = forall a. HasCallStack => String -> a
error (String
"unmarshalSyncStatus: illegal value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GLenum
x)

syncStatus :: SyncObject -> GettableStateVar SyncStatus
syncStatus :: SyncObject -> GettableStateVar SyncStatus
syncStatus SyncObject
syncObject =
   forall a. IO a -> IO a
makeGettableStateVar forall a b. (a -> b) -> a -> b
$
      forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with GLint
0 forall a b. (a -> b) -> a -> b
$ \Ptr GLint
buf -> do
         forall (m :: * -> *).
MonadIO m =>
GLsync -> GLenum -> GLint -> Ptr GLint -> Ptr GLint -> m ()
glGetSynciv (SyncObject -> GLsync
syncID SyncObject
syncObject) GLenum
GL_SYNC_STATUS GLint
1 forall a. Ptr a
nullPtr Ptr GLint
buf
         forall a b. Storable a => (a -> b) -> Ptr a -> IO b
peek1 (GLenum -> SyncStatus
unmarshalSyncStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) Ptr GLint
buf