{-# LANGUAGE CPP #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OpenGL.GL.DebugOutput
-- Copyright   :  (c) Sven Panne 2019
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- This module corresponds to section 20 (Debug Output) of the OpenGL 4.5
-- specs.
--
--------------------------------------------------------------------------------

module Graphics.Rendering.OpenGL.GL.DebugOutput (
  -- * Debug Messages
  debugOutput, DebugMessage(..), DebugSource(..), DebugType(..),
  DebugMessageID(DebugMessageID), DebugSeverity(..), maxDebugMessageLength,

  -- * Debug Message Callback
  debugMessageCallback,

  -- * Debug Message Log
  maxDebugLoggedMessages, debugLoggedMessages,

  -- * Controlling Debug Messages
  MessageGroup(..), debugMessageControl,

  -- * Externally Generated Messages
  debugMessageInsert,

  -- * Debug Groups
  DebugGroup(..), pushDebugGroup, popDebugGroup, withDebugGroup,
  maxDebugGroupStackDepth,

  -- * Debug Labels
  CanBeLabeled(..), maxLabelLength,

  -- * Asynchronous and Synchronous Debug Output
  debugOutputSynchronous
) where

import Control.Monad ( unless, replicateM )
import Data.StateVar
import Foreign.C.String ( peekCStringLen, withCStringLen )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( allocaArray, withArrayLen )
import Foreign.Ptr (
  nullPtr, castPtrToFunPtr, FunPtr, nullFunPtr, freeHaskellFunPtr )
import Graphics.Rendering.OpenGL.GL.Capability
import Graphics.Rendering.OpenGL.GL.Exception
import Graphics.Rendering.OpenGL.GL.PeekPoke
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.GL

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

debugOutput :: StateVar Capability
debugOutput :: StateVar Capability
debugOutput = EnableCap -> StateVar Capability
makeCapability EnableCap
CapDebugOutput

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

data DebugMessage =
  DebugMessage DebugSource DebugType DebugMessageID DebugSeverity String
  deriving ( DebugMessage -> DebugMessage -> Bool
(DebugMessage -> DebugMessage -> Bool)
-> (DebugMessage -> DebugMessage -> Bool) -> Eq DebugMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DebugMessage -> DebugMessage -> Bool
== :: DebugMessage -> DebugMessage -> Bool
$c/= :: DebugMessage -> DebugMessage -> Bool
/= :: DebugMessage -> DebugMessage -> Bool
Eq, Eq DebugMessage
Eq DebugMessage =>
(DebugMessage -> DebugMessage -> Ordering)
-> (DebugMessage -> DebugMessage -> Bool)
-> (DebugMessage -> DebugMessage -> Bool)
-> (DebugMessage -> DebugMessage -> Bool)
-> (DebugMessage -> DebugMessage -> Bool)
-> (DebugMessage -> DebugMessage -> DebugMessage)
-> (DebugMessage -> DebugMessage -> DebugMessage)
-> Ord DebugMessage
DebugMessage -> DebugMessage -> Bool
DebugMessage -> DebugMessage -> Ordering
DebugMessage -> DebugMessage -> DebugMessage
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
$ccompare :: DebugMessage -> DebugMessage -> Ordering
compare :: DebugMessage -> DebugMessage -> Ordering
$c< :: DebugMessage -> DebugMessage -> Bool
< :: DebugMessage -> DebugMessage -> Bool
$c<= :: DebugMessage -> DebugMessage -> Bool
<= :: DebugMessage -> DebugMessage -> Bool
$c> :: DebugMessage -> DebugMessage -> Bool
> :: DebugMessage -> DebugMessage -> Bool
$c>= :: DebugMessage -> DebugMessage -> Bool
>= :: DebugMessage -> DebugMessage -> Bool
$cmax :: DebugMessage -> DebugMessage -> DebugMessage
max :: DebugMessage -> DebugMessage -> DebugMessage
$cmin :: DebugMessage -> DebugMessage -> DebugMessage
min :: DebugMessage -> DebugMessage -> DebugMessage
Ord, Int -> DebugMessage -> ShowS
[DebugMessage] -> ShowS
DebugMessage -> String
(Int -> DebugMessage -> ShowS)
-> (DebugMessage -> String)
-> ([DebugMessage] -> ShowS)
-> Show DebugMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DebugMessage -> ShowS
showsPrec :: Int -> DebugMessage -> ShowS
$cshow :: DebugMessage -> String
show :: DebugMessage -> String
$cshowList :: [DebugMessage] -> ShowS
showList :: [DebugMessage] -> ShowS
Show )

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

data DebugSource =
    DebugSourceAPI
  | DebugSourceShaderCompiler
  | DebugSourceWindowSystem
  | DebugSourceThirdParty
  | DebugSourceApplication
  | DebugSourceOther
  deriving ( DebugSource -> DebugSource -> Bool
(DebugSource -> DebugSource -> Bool)
-> (DebugSource -> DebugSource -> Bool) -> Eq DebugSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DebugSource -> DebugSource -> Bool
== :: DebugSource -> DebugSource -> Bool
$c/= :: DebugSource -> DebugSource -> Bool
/= :: DebugSource -> DebugSource -> Bool
Eq, Eq DebugSource
Eq DebugSource =>
(DebugSource -> DebugSource -> Ordering)
-> (DebugSource -> DebugSource -> Bool)
-> (DebugSource -> DebugSource -> Bool)
-> (DebugSource -> DebugSource -> Bool)
-> (DebugSource -> DebugSource -> Bool)
-> (DebugSource -> DebugSource -> DebugSource)
-> (DebugSource -> DebugSource -> DebugSource)
-> Ord DebugSource
DebugSource -> DebugSource -> Bool
DebugSource -> DebugSource -> Ordering
DebugSource -> DebugSource -> DebugSource
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
$ccompare :: DebugSource -> DebugSource -> Ordering
compare :: DebugSource -> DebugSource -> Ordering
$c< :: DebugSource -> DebugSource -> Bool
< :: DebugSource -> DebugSource -> Bool
$c<= :: DebugSource -> DebugSource -> Bool
<= :: DebugSource -> DebugSource -> Bool
$c> :: DebugSource -> DebugSource -> Bool
> :: DebugSource -> DebugSource -> Bool
$c>= :: DebugSource -> DebugSource -> Bool
>= :: DebugSource -> DebugSource -> Bool
$cmax :: DebugSource -> DebugSource -> DebugSource
max :: DebugSource -> DebugSource -> DebugSource
$cmin :: DebugSource -> DebugSource -> DebugSource
min :: DebugSource -> DebugSource -> DebugSource
Ord, Int -> DebugSource -> ShowS
[DebugSource] -> ShowS
DebugSource -> String
(Int -> DebugSource -> ShowS)
-> (DebugSource -> String)
-> ([DebugSource] -> ShowS)
-> Show DebugSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DebugSource -> ShowS
showsPrec :: Int -> DebugSource -> ShowS
$cshow :: DebugSource -> String
show :: DebugSource -> String
$cshowList :: [DebugSource] -> ShowS
showList :: [DebugSource] -> ShowS
Show )

marshalDebugSource :: DebugSource -> GLenum
marshalDebugSource :: DebugSource -> GLenum
marshalDebugSource DebugSource
x = case DebugSource
x of
  DebugSource
DebugSourceAPI -> GLenum
GL_DEBUG_SOURCE_API
  DebugSource
DebugSourceShaderCompiler -> GLenum
GL_DEBUG_SOURCE_SHADER_COMPILER
  DebugSource
DebugSourceWindowSystem -> GLenum
GL_DEBUG_SOURCE_WINDOW_SYSTEM
  DebugSource
DebugSourceThirdParty -> GLenum
GL_DEBUG_SOURCE_THIRD_PARTY
  DebugSource
DebugSourceApplication -> GLenum
GL_DEBUG_SOURCE_APPLICATION
  DebugSource
DebugSourceOther -> GLenum
GL_DEBUG_SOURCE_OTHER

unmarshalDebugSource :: GLenum -> DebugSource
unmarshalDebugSource :: GLenum -> DebugSource
unmarshalDebugSource GLenum
x
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_SOURCE_API = DebugSource
DebugSourceAPI
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_SOURCE_SHADER_COMPILER = DebugSource
DebugSourceShaderCompiler
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_SOURCE_WINDOW_SYSTEM = DebugSource
DebugSourceWindowSystem
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_SOURCE_THIRD_PARTY = DebugSource
DebugSourceThirdParty
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_SOURCE_APPLICATION = DebugSource
DebugSourceApplication
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_SOURCE_OTHER = DebugSource
DebugSourceOther
  | Bool
otherwise = String -> DebugSource
forall a. HasCallStack => String -> a
error (String
"unmarshalDebugSource: illegal value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GLenum -> String
forall a. Show a => a -> String
show GLenum
x)

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

data DebugType =
    DebugTypeError
  | DebugTypeDeprecatedBehavior
  | DebugTypeUndefinedBehavior
  | DebugTypePerformance
  | DebugTypePortability
  | DebugTypeMarker
  | DebugTypePushGroup
  | DebugTypePopGroup
  | DebugTypeOther
  deriving ( DebugType -> DebugType -> Bool
(DebugType -> DebugType -> Bool)
-> (DebugType -> DebugType -> Bool) -> Eq DebugType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DebugType -> DebugType -> Bool
== :: DebugType -> DebugType -> Bool
$c/= :: DebugType -> DebugType -> Bool
/= :: DebugType -> DebugType -> Bool
Eq, Eq DebugType
Eq DebugType =>
(DebugType -> DebugType -> Ordering)
-> (DebugType -> DebugType -> Bool)
-> (DebugType -> DebugType -> Bool)
-> (DebugType -> DebugType -> Bool)
-> (DebugType -> DebugType -> Bool)
-> (DebugType -> DebugType -> DebugType)
-> (DebugType -> DebugType -> DebugType)
-> Ord DebugType
DebugType -> DebugType -> Bool
DebugType -> DebugType -> Ordering
DebugType -> DebugType -> DebugType
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
$ccompare :: DebugType -> DebugType -> Ordering
compare :: DebugType -> DebugType -> Ordering
$c< :: DebugType -> DebugType -> Bool
< :: DebugType -> DebugType -> Bool
$c<= :: DebugType -> DebugType -> Bool
<= :: DebugType -> DebugType -> Bool
$c> :: DebugType -> DebugType -> Bool
> :: DebugType -> DebugType -> Bool
$c>= :: DebugType -> DebugType -> Bool
>= :: DebugType -> DebugType -> Bool
$cmax :: DebugType -> DebugType -> DebugType
max :: DebugType -> DebugType -> DebugType
$cmin :: DebugType -> DebugType -> DebugType
min :: DebugType -> DebugType -> DebugType
Ord, Int -> DebugType -> ShowS
[DebugType] -> ShowS
DebugType -> String
(Int -> DebugType -> ShowS)
-> (DebugType -> String)
-> ([DebugType] -> ShowS)
-> Show DebugType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DebugType -> ShowS
showsPrec :: Int -> DebugType -> ShowS
$cshow :: DebugType -> String
show :: DebugType -> String
$cshowList :: [DebugType] -> ShowS
showList :: [DebugType] -> ShowS
Show )

marshalDebugType :: DebugType -> GLenum
marshalDebugType :: DebugType -> GLenum
marshalDebugType DebugType
x = case DebugType
x of
  DebugType
DebugTypeError -> GLenum
GL_DEBUG_TYPE_ERROR
  DebugType
DebugTypeDeprecatedBehavior -> GLenum
GL_DEBUG_TYPE_DEPRECATED_BEHAVIOR
  DebugType
DebugTypeUndefinedBehavior -> GLenum
GL_DEBUG_TYPE_UNDEFINED_BEHAVIOR
  DebugType
DebugTypePerformance -> GLenum
GL_DEBUG_TYPE_PERFORMANCE
  DebugType
DebugTypePortability -> GLenum
GL_DEBUG_TYPE_PORTABILITY
  DebugType
DebugTypeMarker -> GLenum
GL_DEBUG_TYPE_MARKER
  DebugType
DebugTypePushGroup -> GLenum
GL_DEBUG_TYPE_PUSH_GROUP
  DebugType
DebugTypePopGroup -> GLenum
GL_DEBUG_TYPE_POP_GROUP
  DebugType
DebugTypeOther -> GLenum
GL_DEBUG_TYPE_OTHER

unmarshalDebugType :: GLenum -> DebugType
unmarshalDebugType :: GLenum -> DebugType
unmarshalDebugType GLenum
x
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_TYPE_ERROR = DebugType
DebugTypeError
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_TYPE_DEPRECATED_BEHAVIOR = DebugType
DebugTypeDeprecatedBehavior
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_TYPE_UNDEFINED_BEHAVIOR = DebugType
DebugTypeUndefinedBehavior
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_TYPE_PERFORMANCE = DebugType
DebugTypePerformance
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_TYPE_PORTABILITY = DebugType
DebugTypePortability
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_TYPE_MARKER = DebugType
DebugTypeMarker
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_TYPE_PUSH_GROUP = DebugType
DebugTypePushGroup
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_TYPE_POP_GROUP = DebugType
DebugTypePopGroup
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_TYPE_OTHER = DebugType
DebugTypeOther
  | Bool
otherwise = String -> DebugType
forall a. HasCallStack => String -> a
error (String
"unmarshalDebugType: illegal value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GLenum -> String
forall a. Show a => a -> String
show GLenum
x)

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

newtype DebugMessageID = DebugMessageID { DebugMessageID -> GLenum
debugMessageID :: GLuint }
   deriving ( DebugMessageID -> DebugMessageID -> Bool
(DebugMessageID -> DebugMessageID -> Bool)
-> (DebugMessageID -> DebugMessageID -> Bool) -> Eq DebugMessageID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DebugMessageID -> DebugMessageID -> Bool
== :: DebugMessageID -> DebugMessageID -> Bool
$c/= :: DebugMessageID -> DebugMessageID -> Bool
/= :: DebugMessageID -> DebugMessageID -> Bool
Eq, Eq DebugMessageID
Eq DebugMessageID =>
(DebugMessageID -> DebugMessageID -> Ordering)
-> (DebugMessageID -> DebugMessageID -> Bool)
-> (DebugMessageID -> DebugMessageID -> Bool)
-> (DebugMessageID -> DebugMessageID -> Bool)
-> (DebugMessageID -> DebugMessageID -> Bool)
-> (DebugMessageID -> DebugMessageID -> DebugMessageID)
-> (DebugMessageID -> DebugMessageID -> DebugMessageID)
-> Ord DebugMessageID
DebugMessageID -> DebugMessageID -> Bool
DebugMessageID -> DebugMessageID -> Ordering
DebugMessageID -> DebugMessageID -> DebugMessageID
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
$ccompare :: DebugMessageID -> DebugMessageID -> Ordering
compare :: DebugMessageID -> DebugMessageID -> Ordering
$c< :: DebugMessageID -> DebugMessageID -> Bool
< :: DebugMessageID -> DebugMessageID -> Bool
$c<= :: DebugMessageID -> DebugMessageID -> Bool
<= :: DebugMessageID -> DebugMessageID -> Bool
$c> :: DebugMessageID -> DebugMessageID -> Bool
> :: DebugMessageID -> DebugMessageID -> Bool
$c>= :: DebugMessageID -> DebugMessageID -> Bool
>= :: DebugMessageID -> DebugMessageID -> Bool
$cmax :: DebugMessageID -> DebugMessageID -> DebugMessageID
max :: DebugMessageID -> DebugMessageID -> DebugMessageID
$cmin :: DebugMessageID -> DebugMessageID -> DebugMessageID
min :: DebugMessageID -> DebugMessageID -> DebugMessageID
Ord, Int -> DebugMessageID -> ShowS
[DebugMessageID] -> ShowS
DebugMessageID -> String
(Int -> DebugMessageID -> ShowS)
-> (DebugMessageID -> String)
-> ([DebugMessageID] -> ShowS)
-> Show DebugMessageID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DebugMessageID -> ShowS
showsPrec :: Int -> DebugMessageID -> ShowS
$cshow :: DebugMessageID -> String
show :: DebugMessageID -> String
$cshowList :: [DebugMessageID] -> ShowS
showList :: [DebugMessageID] -> ShowS
Show )

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

data DebugSeverity =
    DebugSeverityHigh
  | DebugSeverityMedium
  | DebugSeverityLow
  | DebugSeverityNotification
  deriving ( DebugSeverity -> DebugSeverity -> Bool
(DebugSeverity -> DebugSeverity -> Bool)
-> (DebugSeverity -> DebugSeverity -> Bool) -> Eq DebugSeverity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DebugSeverity -> DebugSeverity -> Bool
== :: DebugSeverity -> DebugSeverity -> Bool
$c/= :: DebugSeverity -> DebugSeverity -> Bool
/= :: DebugSeverity -> DebugSeverity -> Bool
Eq, Eq DebugSeverity
Eq DebugSeverity =>
(DebugSeverity -> DebugSeverity -> Ordering)
-> (DebugSeverity -> DebugSeverity -> Bool)
-> (DebugSeverity -> DebugSeverity -> Bool)
-> (DebugSeverity -> DebugSeverity -> Bool)
-> (DebugSeverity -> DebugSeverity -> Bool)
-> (DebugSeverity -> DebugSeverity -> DebugSeverity)
-> (DebugSeverity -> DebugSeverity -> DebugSeverity)
-> Ord DebugSeverity
DebugSeverity -> DebugSeverity -> Bool
DebugSeverity -> DebugSeverity -> Ordering
DebugSeverity -> DebugSeverity -> DebugSeverity
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
$ccompare :: DebugSeverity -> DebugSeverity -> Ordering
compare :: DebugSeverity -> DebugSeverity -> Ordering
$c< :: DebugSeverity -> DebugSeverity -> Bool
< :: DebugSeverity -> DebugSeverity -> Bool
$c<= :: DebugSeverity -> DebugSeverity -> Bool
<= :: DebugSeverity -> DebugSeverity -> Bool
$c> :: DebugSeverity -> DebugSeverity -> Bool
> :: DebugSeverity -> DebugSeverity -> Bool
$c>= :: DebugSeverity -> DebugSeverity -> Bool
>= :: DebugSeverity -> DebugSeverity -> Bool
$cmax :: DebugSeverity -> DebugSeverity -> DebugSeverity
max :: DebugSeverity -> DebugSeverity -> DebugSeverity
$cmin :: DebugSeverity -> DebugSeverity -> DebugSeverity
min :: DebugSeverity -> DebugSeverity -> DebugSeverity
Ord, Int -> DebugSeverity -> ShowS
[DebugSeverity] -> ShowS
DebugSeverity -> String
(Int -> DebugSeverity -> ShowS)
-> (DebugSeverity -> String)
-> ([DebugSeverity] -> ShowS)
-> Show DebugSeverity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DebugSeverity -> ShowS
showsPrec :: Int -> DebugSeverity -> ShowS
$cshow :: DebugSeverity -> String
show :: DebugSeverity -> String
$cshowList :: [DebugSeverity] -> ShowS
showList :: [DebugSeverity] -> ShowS
Show )

marshalDebugSeverity :: DebugSeverity -> GLenum
marshalDebugSeverity :: DebugSeverity -> GLenum
marshalDebugSeverity DebugSeverity
x = case DebugSeverity
x of
  DebugSeverity
DebugSeverityHigh -> GLenum
GL_DEBUG_SEVERITY_HIGH
  DebugSeverity
DebugSeverityMedium -> GLenum
GL_DEBUG_SEVERITY_MEDIUM
  DebugSeverity
DebugSeverityLow -> GLenum
GL_DEBUG_SEVERITY_LOW
  DebugSeverity
DebugSeverityNotification -> GLenum
GL_DEBUG_SEVERITY_NOTIFICATION

unmarshalDebugSeverity :: GLenum -> DebugSeverity
unmarshalDebugSeverity :: GLenum -> DebugSeverity
unmarshalDebugSeverity GLenum
x
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_SEVERITY_HIGH = DebugSeverity
DebugSeverityHigh
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_SEVERITY_MEDIUM = DebugSeverity
DebugSeverityMedium
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_SEVERITY_LOW = DebugSeverity
DebugSeverityLow
  | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_DEBUG_SEVERITY_NOTIFICATION = DebugSeverity
DebugSeverityNotification
  | Bool
otherwise = String -> DebugSeverity
forall a. HasCallStack => String -> a
error (String
"unmarshalDebugSeverity: illegal value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GLenum -> String
forall a. Show a => a -> String
show GLenum
x)

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

maxDebugMessageLength :: GettableStateVar GLsizei
maxDebugMessageLength :: GettableStateVar GLsizei
maxDebugMessageLength =
  GettableStateVar GLsizei -> GettableStateVar GLsizei
forall a. IO a -> IO a
makeGettableStateVar ((GLsizei -> GLsizei) -> PName1I -> GettableStateVar GLsizei
forall p a. GetPName1I p => (GLsizei -> a) -> p -> IO a
forall a. (GLsizei -> a) -> PName1I -> IO a
getSizei1 GLsizei -> GLsizei
forall a. a -> a
id PName1I
GetMaxDebugMessageLength)

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

debugMessageCallback :: StateVar (Maybe (DebugMessage -> IO ()))
debugMessageCallback :: StateVar (Maybe (DebugMessage -> IO ()))
debugMessageCallback =
  IO (Maybe (DebugMessage -> IO ()))
-> (Maybe (DebugMessage -> IO ()) -> IO ())
-> StateVar (Maybe (DebugMessage -> IO ()))
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar IO (Maybe (DebugMessage -> IO ()))
getDebugMessageCallback Maybe (DebugMessage -> IO ()) -> IO ()
setDebugMessageCallback

getDebugMessageCallback :: IO (Maybe (DebugMessage -> IO ()))
getDebugMessageCallback :: IO (Maybe (DebugMessage -> IO ()))
getDebugMessageCallback = do
  FunPtr GLDEBUGPROCFunc
cb <- IO (FunPtr GLDEBUGPROCFunc)
getDebugCallbackFunction
  Maybe (DebugMessage -> IO ()) -> IO (Maybe (DebugMessage -> IO ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (DebugMessage -> IO ())
 -> IO (Maybe (DebugMessage -> IO ())))
-> Maybe (DebugMessage -> IO ())
-> IO (Maybe (DebugMessage -> IO ()))
forall a b. (a -> b) -> a -> b
$ if (FunPtr GLDEBUGPROCFunc
cb FunPtr GLDEBUGPROCFunc -> FunPtr GLDEBUGPROCFunc -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr GLDEBUGPROCFunc
forall a. FunPtr a
nullFunPtr)
             then Maybe (DebugMessage -> IO ())
forall a. Maybe a
Nothing
             else (DebugMessage -> IO ()) -> Maybe (DebugMessage -> IO ())
forall a. a -> Maybe a
Just ((DebugMessage -> IO ()) -> Maybe (DebugMessage -> IO ()))
-> (FunPtr GLDEBUGPROCFunc -> DebugMessage -> IO ())
-> FunPtr GLDEBUGPROCFunc
-> Maybe (DebugMessage -> IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLDEBUGPROCFunc -> DebugMessage -> IO ()
toDebugProc (GLDEBUGPROCFunc -> DebugMessage -> IO ())
-> (FunPtr GLDEBUGPROCFunc -> GLDEBUGPROCFunc)
-> FunPtr GLDEBUGPROCFunc
-> DebugMessage
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunPtr GLDEBUGPROCFunc -> GLDEBUGPROCFunc
dyn_debugProc (FunPtr GLDEBUGPROCFunc -> Maybe (DebugMessage -> IO ()))
-> FunPtr GLDEBUGPROCFunc -> Maybe (DebugMessage -> IO ())
forall a b. (a -> b) -> a -> b
$ FunPtr GLDEBUGPROCFunc
cb

foreign import CALLCONV "dynamic" dyn_debugProc
  :: FunPtr GLDEBUGPROCFunc -> GLDEBUGPROCFunc

toDebugProc:: GLDEBUGPROCFunc -> DebugMessage -> IO ()
toDebugProc :: GLDEBUGPROCFunc -> DebugMessage -> IO ()
toDebugProc GLDEBUGPROCFunc
debugFunc (DebugMessage DebugSource
source DebugType
typ DebugMessageID
msgID DebugSeverity
severity String
message) =
  String -> (CStringLen -> IO ()) -> IO ()
forall a. String -> (CStringLen -> IO a) -> IO a
withCStringLen String
message ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr GLchar
msg, Int
len) -> do
    GLDEBUGPROCFunc
debugFunc (DebugSource -> GLenum
marshalDebugSource DebugSource
source)
              (DebugType -> GLenum
marshalDebugType DebugType
typ)
              (DebugSeverity -> GLenum
marshalDebugSeverity DebugSeverity
severity)
              (DebugMessageID -> GLenum
debugMessageID DebugMessageID
msgID)
              (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
              Ptr GLchar
msg
              Ptr ()
forall a. Ptr a
nullPtr

setDebugMessageCallback :: Maybe (DebugMessage -> IO ()) -> IO ()
setDebugMessageCallback :: Maybe (DebugMessage -> IO ()) -> IO ()
setDebugMessageCallback Maybe (DebugMessage -> IO ())
maybeDebugProc = do
  FunPtr GLDEBUGPROCFunc
oldCB <- IO (FunPtr GLDEBUGPROCFunc)
getDebugCallbackFunction
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FunPtr GLDEBUGPROCFunc
oldCB FunPtr GLDEBUGPROCFunc -> FunPtr GLDEBUGPROCFunc -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr GLDEBUGPROCFunc
forall a. FunPtr a
nullFunPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    FunPtr GLDEBUGPROCFunc -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr GLDEBUGPROCFunc
oldCB
  FunPtr GLDEBUGPROCFunc
newCB <-
    IO (FunPtr GLDEBUGPROCFunc)
-> ((DebugMessage -> IO ()) -> IO (FunPtr GLDEBUGPROCFunc))
-> Maybe (DebugMessage -> IO ())
-> IO (FunPtr GLDEBUGPROCFunc)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FunPtr GLDEBUGPROCFunc -> IO (FunPtr GLDEBUGPROCFunc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FunPtr GLDEBUGPROCFunc
forall a. FunPtr a
nullFunPtr) (GLDEBUGPROCFunc -> IO (FunPtr GLDEBUGPROCFunc)
makeGLDEBUGPROC (GLDEBUGPROCFunc -> IO (FunPtr GLDEBUGPROCFunc))
-> ((DebugMessage -> IO ()) -> GLDEBUGPROCFunc)
-> (DebugMessage -> IO ())
-> IO (FunPtr GLDEBUGPROCFunc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DebugMessage -> IO ()) -> GLDEBUGPROCFunc
fromDebugProc) Maybe (DebugMessage -> IO ())
maybeDebugProc
  FunPtr GLDEBUGPROCFunc -> Ptr Any -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
FunPtr GLDEBUGPROCFunc -> Ptr a -> m ()
glDebugMessageCallbackARB FunPtr GLDEBUGPROCFunc
newCB  Ptr Any
forall a. Ptr a
nullPtr

fromDebugProc:: (DebugMessage -> IO ()) -> GLDEBUGPROCFunc
fromDebugProc :: (DebugMessage -> IO ()) -> GLDEBUGPROCFunc
fromDebugProc DebugMessage -> IO ()
debugProc GLenum
source GLenum
typ GLenum
msgID GLenum
severity GLsizei
len Ptr GLchar
message Ptr ()
_userParam = do
  String
msg <- CStringLen -> IO String
peekCStringLen (Ptr GLchar
message, GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
len)
  DebugMessage -> IO ()
debugProc (DebugSource
-> DebugType
-> DebugMessageID
-> DebugSeverity
-> String
-> DebugMessage
DebugMessage (GLenum -> DebugSource
unmarshalDebugSource GLenum
source)
                          (GLenum -> DebugType
unmarshalDebugType GLenum
typ)
                          (GLenum -> DebugMessageID
DebugMessageID GLenum
msgID)
                          (GLenum -> DebugSeverity
unmarshalDebugSeverity GLenum
severity)
                          String
msg)

getDebugCallbackFunction :: IO (FunPtr GLDEBUGPROCFunc)
getDebugCallbackFunction :: IO (FunPtr GLDEBUGPROCFunc)
getDebugCallbackFunction =
  Ptr Any -> FunPtr GLDEBUGPROCFunc
forall a b. Ptr a -> FunPtr b
castPtrToFunPtr (Ptr Any -> FunPtr GLDEBUGPROCFunc)
-> IO (Ptr Any) -> IO (FunPtr GLDEBUGPROCFunc)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` GetPointervPName -> IO (Ptr Any)
forall a. GetPointervPName -> IO (Ptr a)
getPointer GetPointervPName
DebugCallbackFunction

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

maxDebugLoggedMessages :: GettableStateVar GLsizei
maxDebugLoggedMessages :: GettableStateVar GLsizei
maxDebugLoggedMessages =
  GettableStateVar GLsizei -> GettableStateVar GLsizei
forall a. IO a -> IO a
makeGettableStateVar ((GLsizei -> GLsizei) -> PName1I -> GettableStateVar GLsizei
forall p a. GetPName1I p => (GLsizei -> a) -> p -> IO a
forall a. (GLsizei -> a) -> PName1I -> IO a
getSizei1 GLsizei -> GLsizei
forall a. a -> a
id PName1I
GetMaxDebugLoggedMessages)

debugLoggedMessages :: IO [DebugMessage]
debugLoggedMessages :: IO [DebugMessage]
debugLoggedMessages = do
  Int
count <- (GLsizei -> Int) -> PName1I -> IO Int
forall p a. GetPName1I p => (GLsizei -> a) -> p -> IO a
forall a. (GLsizei -> a) -> PName1I -> IO a
getSizei1 GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PName1I
GetDebugLoggedMessages
  Int -> IO DebugMessage -> IO [DebugMessage]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
count IO DebugMessage
debugNextLoggedMessage

debugNextLoggedMessage :: IO DebugMessage
debugNextLoggedMessage :: IO DebugMessage
debugNextLoggedMessage = do
  GLsizei
len <- (GLsizei -> GLsizei) -> PName1I -> GettableStateVar GLsizei
forall p a. GetPName1I p => (GLsizei -> a) -> p -> IO a
forall a. (GLsizei -> a) -> PName1I -> IO a
getSizei1 GLsizei -> GLsizei
forall a. a -> a
id PName1I
GetDebugNextLoggedMessageLength
  (Ptr GLenum -> IO DebugMessage) -> IO DebugMessage
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLenum -> IO DebugMessage) -> IO DebugMessage)
-> (Ptr GLenum -> IO DebugMessage) -> IO DebugMessage
forall a b. (a -> b) -> a -> b
$ \Ptr GLenum
sourceBuf ->
    (Ptr GLenum -> IO DebugMessage) -> IO DebugMessage
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLenum -> IO DebugMessage) -> IO DebugMessage)
-> (Ptr GLenum -> IO DebugMessage) -> IO DebugMessage
forall a b. (a -> b) -> a -> b
$ \Ptr GLenum
typeBuf ->
      (Ptr GLenum -> IO DebugMessage) -> IO DebugMessage
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLenum -> IO DebugMessage) -> IO DebugMessage)
-> (Ptr GLenum -> IO DebugMessage) -> IO DebugMessage
forall a b. (a -> b) -> a -> b
$ \Ptr GLenum
idBuf ->
        (Ptr GLenum -> IO DebugMessage) -> IO DebugMessage
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLenum -> IO DebugMessage) -> IO DebugMessage)
-> (Ptr GLenum -> IO DebugMessage) -> IO DebugMessage
forall a b. (a -> b) -> a -> b
$ \Ptr GLenum
severityBuf ->
          Int -> (Ptr GLchar -> IO DebugMessage) -> IO DebugMessage
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
len) ((Ptr GLchar -> IO DebugMessage) -> IO DebugMessage)
-> (Ptr GLchar -> IO DebugMessage) -> IO DebugMessage
forall a b. (a -> b) -> a -> b
$ \Ptr GLchar
messageBuf -> do
            GLenum
_ <- GLenum
-> GLsizei
-> Ptr GLenum
-> Ptr GLenum
-> Ptr GLenum
-> Ptr GLenum
-> Ptr GLsizei
-> Ptr GLchar
-> IO GLenum
forall (m :: * -> *).
MonadIO m =>
GLenum
-> GLsizei
-> Ptr GLenum
-> Ptr GLenum
-> Ptr GLenum
-> Ptr GLenum
-> Ptr GLsizei
-> Ptr GLchar
-> m GLenum
glGetDebugMessageLog GLenum
1 GLsizei
len Ptr GLenum
sourceBuf Ptr GLenum
typeBuf Ptr GLenum
idBuf
                                      Ptr GLenum
severityBuf Ptr GLsizei
forall a. Ptr a
nullPtr Ptr GLchar
messageBuf
            DebugSource
source <- (GLenum -> DebugSource) -> Ptr GLenum -> IO DebugSource
forall a b. Storable a => (a -> b) -> Ptr a -> IO b
peek1 GLenum -> DebugSource
unmarshalDebugSource Ptr GLenum
sourceBuf
            DebugType
typ <- (GLenum -> DebugType) -> Ptr GLenum -> IO DebugType
forall a b. Storable a => (a -> b) -> Ptr a -> IO b
peek1 GLenum -> DebugType
unmarshalDebugType Ptr GLenum
typeBuf
            DebugMessageID
msgID <- (GLenum -> DebugMessageID) -> Ptr GLenum -> IO DebugMessageID
forall a b. Storable a => (a -> b) -> Ptr a -> IO b
peek1 GLenum -> DebugMessageID
DebugMessageID Ptr GLenum
idBuf
            DebugSeverity
severity <- (GLenum -> DebugSeverity) -> Ptr GLenum -> IO DebugSeverity
forall a b. Storable a => (a -> b) -> Ptr a -> IO b
peek1 GLenum -> DebugSeverity
unmarshalDebugSeverity Ptr GLenum
severityBuf
            String
message <- CStringLen -> IO String
peekCStringLen (Ptr GLchar
messageBuf, GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
len)
            DebugMessage -> IO DebugMessage
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DebugMessage -> IO DebugMessage)
-> DebugMessage -> IO DebugMessage
forall a b. (a -> b) -> a -> b
$ DebugSource
-> DebugType
-> DebugMessageID
-> DebugSeverity
-> String
-> DebugMessage
DebugMessage DebugSource
source DebugType
typ DebugMessageID
msgID DebugSeverity
severity String
message

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

data MessageGroup =
    MessageGroup (Maybe DebugSource) (Maybe DebugType) (Maybe DebugSeverity)
  | MessageGroupWithIDs DebugSource DebugType [DebugMessageID]
  deriving ( MessageGroup -> MessageGroup -> Bool
(MessageGroup -> MessageGroup -> Bool)
-> (MessageGroup -> MessageGroup -> Bool) -> Eq MessageGroup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MessageGroup -> MessageGroup -> Bool
== :: MessageGroup -> MessageGroup -> Bool
$c/= :: MessageGroup -> MessageGroup -> Bool
/= :: MessageGroup -> MessageGroup -> Bool
Eq, Eq MessageGroup
Eq MessageGroup =>
(MessageGroup -> MessageGroup -> Ordering)
-> (MessageGroup -> MessageGroup -> Bool)
-> (MessageGroup -> MessageGroup -> Bool)
-> (MessageGroup -> MessageGroup -> Bool)
-> (MessageGroup -> MessageGroup -> Bool)
-> (MessageGroup -> MessageGroup -> MessageGroup)
-> (MessageGroup -> MessageGroup -> MessageGroup)
-> Ord MessageGroup
MessageGroup -> MessageGroup -> Bool
MessageGroup -> MessageGroup -> Ordering
MessageGroup -> MessageGroup -> MessageGroup
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
$ccompare :: MessageGroup -> MessageGroup -> Ordering
compare :: MessageGroup -> MessageGroup -> Ordering
$c< :: MessageGroup -> MessageGroup -> Bool
< :: MessageGroup -> MessageGroup -> Bool
$c<= :: MessageGroup -> MessageGroup -> Bool
<= :: MessageGroup -> MessageGroup -> Bool
$c> :: MessageGroup -> MessageGroup -> Bool
> :: MessageGroup -> MessageGroup -> Bool
$c>= :: MessageGroup -> MessageGroup -> Bool
>= :: MessageGroup -> MessageGroup -> Bool
$cmax :: MessageGroup -> MessageGroup -> MessageGroup
max :: MessageGroup -> MessageGroup -> MessageGroup
$cmin :: MessageGroup -> MessageGroup -> MessageGroup
min :: MessageGroup -> MessageGroup -> MessageGroup
Ord, Int -> MessageGroup -> ShowS
[MessageGroup] -> ShowS
MessageGroup -> String
(Int -> MessageGroup -> ShowS)
-> (MessageGroup -> String)
-> ([MessageGroup] -> ShowS)
-> Show MessageGroup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MessageGroup -> ShowS
showsPrec :: Int -> MessageGroup -> ShowS
$cshow :: MessageGroup -> String
show :: MessageGroup -> String
$cshowList :: [MessageGroup] -> ShowS
showList :: [MessageGroup] -> ShowS
Show )

debugMessageControl :: MessageGroup -> SettableStateVar Capability
debugMessageControl :: MessageGroup -> SettableStateVar Capability
debugMessageControl MessageGroup
x = case MessageGroup
x of
  MessageGroup Maybe DebugSource
maybeSource Maybe DebugType
maybeType Maybe DebugSeverity
maybeSeverity ->
    Maybe DebugSource
-> Maybe DebugType
-> Maybe DebugSeverity
-> [DebugMessageID]
-> SettableStateVar Capability
doDebugMessageControl Maybe DebugSource
maybeSource Maybe DebugType
maybeType Maybe DebugSeverity
maybeSeverity []
  MessageGroupWithIDs DebugSource
source DebugType
typ [DebugMessageID]
messageIDs ->
    Maybe DebugSource
-> Maybe DebugType
-> Maybe DebugSeverity
-> [DebugMessageID]
-> SettableStateVar Capability
doDebugMessageControl (DebugSource -> Maybe DebugSource
forall a. a -> Maybe a
Just DebugSource
source) (DebugType -> Maybe DebugType
forall a. a -> Maybe a
Just DebugType
typ) Maybe DebugSeverity
forall a. Maybe a
Nothing [DebugMessageID]
messageIDs

doDebugMessageControl :: Maybe DebugSource
                      -> Maybe DebugType
                      -> Maybe DebugSeverity
                      -> [DebugMessageID]
                      -> SettableStateVar Capability
doDebugMessageControl :: Maybe DebugSource
-> Maybe DebugType
-> Maybe DebugSeverity
-> [DebugMessageID]
-> SettableStateVar Capability
doDebugMessageControl Maybe DebugSource
maybeSource Maybe DebugType
maybeType Maybe DebugSeverity
maybeSeverity [DebugMessageID]
messageIDs =
  (Capability -> IO ()) -> SettableStateVar Capability
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar ((Capability -> IO ()) -> SettableStateVar Capability)
-> (Capability -> IO ()) -> SettableStateVar Capability
forall a b. (a -> b) -> a -> b
$ \Capability
cap ->
    [GLenum] -> (Int -> Ptr GLenum -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen ((DebugMessageID -> GLenum) -> [DebugMessageID] -> [GLenum]
forall a b. (a -> b) -> [a] -> [b]
map DebugMessageID -> GLenum
debugMessageID [DebugMessageID]
messageIDs) ((Int -> Ptr GLenum -> IO ()) -> IO ())
-> (Int -> Ptr GLenum -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
len Ptr GLenum
idsBuf ->
      GLenum
-> GLenum -> GLenum -> GLsizei -> Ptr GLenum -> GLboolean -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum
-> GLenum -> GLenum -> GLsizei -> Ptr GLenum -> GLboolean -> m ()
glDebugMessageControl (GLenum -> (DebugSource -> GLenum) -> Maybe DebugSource -> GLenum
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GLenum
GL_DONT_CARE DebugSource -> GLenum
marshalDebugSource Maybe DebugSource
maybeSource)
                            (GLenum -> (DebugType -> GLenum) -> Maybe DebugType -> GLenum
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GLenum
GL_DONT_CARE DebugType -> GLenum
marshalDebugType Maybe DebugType
maybeType)
                            (GLenum
-> (DebugSeverity -> GLenum) -> Maybe DebugSeverity -> GLenum
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GLenum
GL_DONT_CARE DebugSeverity -> GLenum
marshalDebugSeverity Maybe DebugSeverity
maybeSeverity)
                            (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
                            Ptr GLenum
idsBuf
                            (Capability -> GLboolean
marshalCapability Capability
cap)

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

debugMessageInsert :: DebugMessage -> IO ()
debugMessageInsert :: DebugMessage -> IO ()
debugMessageInsert (DebugMessage DebugSource
source DebugType
typ DebugMessageID
msgID DebugSeverity
severity String
message) =
  String -> (CStringLen -> IO ()) -> IO ()
forall a. String -> (CStringLen -> IO a) -> IO a
withCStringLen String
message ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr GLchar
msg, Int
len) ->
    GLenum
-> GLenum -> GLenum -> GLenum -> GLsizei -> Ptr GLchar -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum
-> GLenum -> GLenum -> GLenum -> GLsizei -> Ptr GLchar -> m ()
glDebugMessageInsert (DebugSource -> GLenum
marshalDebugSource DebugSource
source)
                         (DebugType -> GLenum
marshalDebugType DebugType
typ)
                         (DebugMessageID -> GLenum
debugMessageID DebugMessageID
msgID)
                         (DebugSeverity -> GLenum
marshalDebugSeverity DebugSeverity
severity)
                         (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
                         Ptr GLchar
msg

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

data DebugGroup = DebugGroup DebugSource DebugMessageID String

pushDebugGroup :: DebugSource -> DebugMessageID -> String -> IO ()
pushDebugGroup :: DebugSource -> DebugMessageID -> String -> IO ()
pushDebugGroup DebugSource
source DebugMessageID
msgID String
message =
  String -> (CStringLen -> IO ()) -> IO ()
forall a. String -> (CStringLen -> IO a) -> IO a
withCStringLen String
message ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr GLchar
msg, Int
len) ->
    GLenum -> GLenum -> GLsizei -> Ptr GLchar -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLenum -> GLsizei -> Ptr GLchar -> m ()
glPushDebugGroup (DebugSource -> GLenum
marshalDebugSource DebugSource
source)
                     (DebugMessageID -> GLenum
debugMessageID DebugMessageID
msgID)
                     (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
                     Ptr GLchar
msg

popDebugGroup :: IO ()
popDebugGroup :: IO ()
popDebugGroup = IO ()
forall (m :: * -> *). MonadIO m => m ()
glPopDebugGroup

withDebugGroup :: DebugSource -> DebugMessageID -> String -> IO a -> IO a
withDebugGroup :: forall a. DebugSource -> DebugMessageID -> String -> IO a -> IO a
withDebugGroup DebugSource
source DebugMessageID
msgID String
message =
  IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (DebugSource -> DebugMessageID -> String -> IO ()
pushDebugGroup DebugSource
source DebugMessageID
msgID String
message) IO ()
popDebugGroup

maxDebugGroupStackDepth :: GettableStateVar GLsizei
maxDebugGroupStackDepth :: GettableStateVar GLsizei
maxDebugGroupStackDepth =
  GettableStateVar GLsizei -> GettableStateVar GLsizei
forall a. IO a -> IO a
makeGettableStateVar ((GLsizei -> GLsizei) -> PName1I -> GettableStateVar GLsizei
forall p a. GetPName1I p => (GLsizei -> a) -> p -> IO a
forall a. (GLsizei -> a) -> PName1I -> IO a
getSizei1 GLsizei -> GLsizei
forall a. a -> a
id PName1I
GetMaxDebugGroupStackDepth)

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

-- TODO: Make instances for the following features when we have them:
--   * PROGRAM_PIPELINE / glGenProgramPipelines
--   * SAMPLER / glGenSamplers
--   * TRANSFORM_FEEDBACK / glGenTransformFeedbacks

class CanBeLabeled a where
  objectLabel :: a -> StateVar (Maybe String)

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

debugOutputSynchronous :: StateVar Capability
debugOutputSynchronous :: StateVar Capability
debugOutputSynchronous = EnableCap -> StateVar Capability
makeCapability EnableCap
CapDebugOutputSynchronous