module Graphics.Rendering.OpenGL.GL.SyncObjects (
SyncObject, syncGpuCommandsComplete,
WaitTimeout, WaitFlag(..), WaitResult(..), clientWaitSync,
waitSync, maxServerWaitTimeout,
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