Added most of the debug output API.

haskell-opengl · Mar 3, 2015 · caf4d11 · caf4d11
1 parent 068710c
commit caf4d11
Show file tree

Hide file tree

Showing 6 changed files with 365 additions and 47 deletions.
diff --git a/OpenGL.cabal b/OpenGL.cabal
@@ -1,5 +1,5 @@
 name: OpenGL
-version: 2.11.0.0
+version: 2.11.1.0
 synopsis: A binding for the OpenGL graphics system
 description:
   A Haskell binding for the OpenGL graphics system (GL, version 4.5) and its
@@ -36,6 +36,7 @@ library
     Graphics.Rendering.OpenGL.GL.Colors
     Graphics.Rendering.OpenGL.GL.ConditionalRendering
     Graphics.Rendering.OpenGL.GL.CoordTrans
+    Graphics.Rendering.OpenGL.GL.DebugOutput
     Graphics.Rendering.OpenGL.GL.DisplayLists
     Graphics.Rendering.OpenGL.GL.Evaluators
     Graphics.Rendering.OpenGL.GL.Feedback
@@ -154,6 +155,13 @@ library
     DeriveDataTypeable
     KindSignatures
     TypeSynonymInstances
+  if os(windows)
+    if arch(i386)
+      cpp-options: "-DCALLCONV=stdcall"
+    else
+      cpp-options: "-DCALLCONV=ccall"
+  else
+    cpp-options: "-DCALLCONV=ccall"
 
 source-repository head
   type: git

diff --git a/src/Graphics/Rendering/OpenGL/GL.hs b/src/Graphics/Rendering/OpenGL/GL.hs
@@ -65,6 +65,7 @@ module Graphics.Rendering.OpenGL.GL (
    module Graphics.Rendering.OpenGL.GL.Hints,
    module Graphics.Rendering.OpenGL.GL.PixellikeObject,
    module Graphics.Rendering.OpenGL.GL.TransformFeedback,
+   module Graphics.Rendering.OpenGL.GL.DebugOutput,
 
    -- * State and State Requests
    module Graphics.Rendering.OpenGL.GL.StateVar,
@@ -117,6 +118,7 @@ import Graphics.Rendering.OpenGL.GL.DisplayLists
 import Graphics.Rendering.OpenGL.GL.Hints
 import Graphics.Rendering.OpenGL.GL.PixellikeObject
 import Graphics.Rendering.OpenGL.GL.TransformFeedback
+import Graphics.Rendering.OpenGL.GL.DebugOutput
 
 import Graphics.Rendering.OpenGL.GL.StateVar
 import Graphics.Rendering.OpenGL.GL.Tensor

diff --git a/src/Graphics/Rendering/OpenGL/GL/Capability.hs b/src/Graphics/Rendering/OpenGL/GL/Capability.hs
@@ -139,6 +139,8 @@ data EnableCap =
    | CapTextureColorTable
    | CapVertexProgramPointSize
    | CapVertexProgramTwoSide
+   | CapDebugOutput
+   | CapDebugOutputSynchronous
 
 marshalEnableCap :: EnableCap -> Maybe GLenum
 marshalEnableCap x = case x of
@@ -236,6 +238,8 @@ marshalEnableCap x = case x of
    CapTextureColorTable -> Just gl_TEXTURE_COLOR_TABLE_SGI
    CapVertexProgramPointSize -> Just gl_VERTEX_PROGRAM_POINT_SIZE
    CapVertexProgramTwoSide -> Just gl_VERTEX_PROGRAM_TWO_SIDE
+   CapDebugOutput -> Just gl_DEBUG_OUTPUT
+   CapDebugOutputSynchronous -> Just gl_DEBUG_OUTPUT_SYNCHRONOUS
 
 --------------------------------------------------------------------------------
 

diff --git a/src/Graphics/Rendering/OpenGL/GL/DebugOutput.hs b/src/Graphics/Rendering/OpenGL/GL/DebugOutput.hs
@@ -0,0 +1,283 @@
+{-# LANGUAGE CPP #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.Rendering.OpenGL.GL.DebugOutput
+-- Copyright   :  (c) Sven Panne 2015
+-- License     :  BSD3
+--
+-- Maintainer  :  Sven Panne <[email protected]>
+-- 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(..), DebugSeverity(..), maxDebugMessageLength,
+
+  -- * Debug Message Callback
+  debugMessageCallback,
+
+  -- * Debug Message Log
+  maxDebugLoggedMessages, debugLoggedMessages,
+
+  -- * Controlling Debug Messages (TODO)
+
+  -- * Externally Generated Messages
+  debugMessageInsert,
+
+  -- * Debug Groups
+  DebugGroup(..), pushDebugGroup, popDebugGroup, withDebugGroup,
+  maxDebugGroupStackDepth,
+
+  -- * Debug Labels (TODO)
+
+  -- * Asynchronous and Synchronous Debug Output
+  debugOutputSynchronous
+) where
+
+import Control.Monad ( unless, replicateM )
+import Foreign.C.String ( peekCStringLen, withCStringLen )
+import Foreign.C.Types
+import Foreign.Marshal.Alloc ( alloca )
+import Foreign.Marshal.Array ( allocaArray )
+import Foreign.Ptr (
+  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.Rendering.OpenGL.GL.StateVar
+import Graphics.Rendering.OpenGL.Raw
+
+--------------------------------------------------------------------------------
+
+debugOutput :: StateVar Capability
+debugOutput = makeCapability CapDebugOutput
+
+--------------------------------------------------------------------------------
+
+data DebugMessage =
+  DebugMessage DebugSource DebugType DebugMessageID DebugSeverity String
+  deriving ( Eq, Ord, Show )
+
+--------------------------------------------------------------------------------
+
+data DebugSource =
+    DebugSourceAPI
+  | DebugSourceShaderCompiler
+  | DebugSourceWindowSystem
+  | DebugSourceThirdParty
+  | DebugSourceApplication
+  | DebugSourceOther
+  deriving ( Eq, Ord, Show )
+
+marshalDebugSource :: DebugSource -> GLenum
+marshalDebugSource x = case x of
+  DebugSourceAPI -> gl_DEBUG_SOURCE_API
+  DebugSourceShaderCompiler -> gl_DEBUG_SOURCE_SHADER_COMPILER
+  DebugSourceWindowSystem -> gl_DEBUG_SOURCE_WINDOW_SYSTEM
+  DebugSourceThirdParty -> gl_DEBUG_SOURCE_THIRD_PARTY
+  DebugSourceApplication -> gl_DEBUG_SOURCE_APPLICATION
+  DebugSourceOther -> gl_DEBUG_SOURCE_OTHER
+
+unmarshalDebugSource :: GLenum -> DebugSource
+unmarshalDebugSource x
+  | x == gl_DEBUG_SOURCE_API = DebugSourceAPI
+  | x == gl_DEBUG_SOURCE_SHADER_COMPILER = DebugSourceShaderCompiler
+  | x == gl_DEBUG_SOURCE_WINDOW_SYSTEM = DebugSourceWindowSystem
+  | x == gl_DEBUG_SOURCE_THIRD_PARTY = DebugSourceThirdParty
+  | x == gl_DEBUG_SOURCE_APPLICATION = DebugSourceApplication
+  | x == gl_DEBUG_SOURCE_OTHER = DebugSourceOther
+  | otherwise = error ("unmarshalDebugSource: illegal value " ++ show x)
+
+--------------------------------------------------------------------------------
+
+data DebugType =
+    DebugTypeError
+  | DebugTypeDeprecatedBehavior
+  | DebugTypeUndefinedBehavior
+  | DebugTypePerformance
+  | DebugTypePortability
+  | DebugTypeMarker
+  | DebugTypePushGroup
+  | DebugTypePopGroup
+  | DebugTypeOther
+  deriving ( Eq, Ord, Show )
+
+marshalDebugType :: DebugType -> GLenum
+marshalDebugType x = case x of
+  DebugTypeError -> gl_DEBUG_TYPE_ERROR
+  DebugTypeDeprecatedBehavior -> gl_DEBUG_TYPE_DEPRECATED_BEHAVIOR
+  DebugTypeUndefinedBehavior -> gl_DEBUG_TYPE_UNDEFINED_BEHAVIOR
+  DebugTypePerformance -> gl_DEBUG_TYPE_PERFORMANCE
+  DebugTypePortability -> gl_DEBUG_TYPE_PORTABILITY
+  DebugTypeMarker -> gl_DEBUG_TYPE_MARKER
+  DebugTypePushGroup -> gl_DEBUG_TYPE_PUSH_GROUP
+  DebugTypePopGroup -> gl_DEBUG_TYPE_POP_GROUP
+  DebugTypeOther -> gl_DEBUG_TYPE_OTHER
+
+unmarshalDebugType :: GLenum -> DebugType
+unmarshalDebugType x
+  | x == gl_DEBUG_TYPE_ERROR = DebugTypeError
+  | x == gl_DEBUG_TYPE_DEPRECATED_BEHAVIOR = DebugTypeDeprecatedBehavior
+  | x == gl_DEBUG_TYPE_UNDEFINED_BEHAVIOR = DebugTypeUndefinedBehavior
+  | x == gl_DEBUG_TYPE_PERFORMANCE = DebugTypePerformance
+  | x == gl_DEBUG_TYPE_PORTABILITY = DebugTypePortability
+  | x == gl_DEBUG_TYPE_MARKER = DebugTypeMarker
+  | x == gl_DEBUG_TYPE_PUSH_GROUP = DebugTypePushGroup
+  | x == gl_DEBUG_TYPE_POP_GROUP = DebugTypePopGroup
+  | x == gl_DEBUG_TYPE_OTHER = DebugTypeOther
+  | otherwise = error ("unmarshalDebugType: illegal value " ++ show x)
+
+--------------------------------------------------------------------------------
+
+newtype DebugMessageID = DebugMessageID { debugMessageID :: GLuint }
+   deriving ( Eq, Ord, Show )
+
+--------------------------------------------------------------------------------
+
+data DebugSeverity =
+    DebugSeverityHigh
+  | DebugSeverityMedium
+  | DebugSeverityLow
+  | DebugSeverityNotification
+  deriving ( Eq, Ord, Show )
+
+marshalDebugSeverity :: DebugSeverity -> GLenum
+marshalDebugSeverity x = case x of
+  DebugSeverityHigh -> gl_DEBUG_SEVERITY_HIGH
+  DebugSeverityMedium -> gl_DEBUG_SEVERITY_MEDIUM
+  DebugSeverityLow -> gl_DEBUG_SEVERITY_LOW
+  DebugSeverityNotification -> gl_DEBUG_SEVERITY_NOTIFICATION
+
+unmarshalDebugSeverity :: GLenum -> DebugSeverity
+unmarshalDebugSeverity x
+  | x == gl_DEBUG_SEVERITY_HIGH = DebugSeverityHigh
+  | x == gl_DEBUG_SEVERITY_MEDIUM = DebugSeverityMedium
+  | x == gl_DEBUG_SEVERITY_LOW = DebugSeverityLow
+  | x == gl_DEBUG_SEVERITY_NOTIFICATION = DebugSeverityNotification
+  | otherwise = error ("unmarshalDebugSeverity: illegal value " ++ show x)
+
+--------------------------------------------------------------------------------
+
+maxDebugMessageLength :: GettableStateVar GLsizei
+maxDebugMessageLength =
+  makeGettableStateVar (getSizei1 id GetMaxDebugMessageLength)
+
+--------------------------------------------------------------------------------
+
+debugMessageCallback :: StateVar (Maybe (DebugMessage -> IO ()))
+debugMessageCallback =
+  makeStateVar getDebugMessageCallback setDebugMessageCallback
+
+getDebugMessageCallback :: IO (Maybe (DebugMessage -> IO ()))
+getDebugMessageCallback = do
+  cb <- castPtrToFunPtr `fmap` getPointer DebugCallbackFunction
+  return $ if (cb == nullFunPtr)
+             then Nothing
+             else Just . toDebugProc . dyn_debugProc $ cb
+
+foreign import CALLCONV "dynamic" dyn_debugProc
+  :: FunPtr GLDEBUGPROCFunc -> GLDEBUGPROCFunc
+
+toDebugProc:: GLDEBUGPROCFunc -> DebugMessage -> IO ()
+toDebugProc debugFunc (DebugMessage source typ msgID severity message) =
+  withCStringLen message $ \(msg, len) -> do
+    debugFunc (marshalDebugSource source)
+              (marshalDebugType typ)
+              (marshalDebugSeverity severity)
+              (debugMessageID msgID)
+              (fromIntegral len)
+              msg
+              nullPtr
+
+setDebugMessageCallback :: Maybe (DebugMessage -> IO ()) -> IO ()
+setDebugMessageCallback maybeDebugProc = do
+  oldCB <- castPtrToFunPtr `fmap` getPointer DebugCallbackFunction
+  unless (oldCB == nullFunPtr) $
+    freeHaskellFunPtr oldCB
+  newCB <-
+    maybe (return nullFunPtr) (makeGLDEBUGPROC . fromDebugProc) maybeDebugProc
+  glDebugMessageCallbackARB newCB  nullPtr
+
+fromDebugProc:: (DebugMessage -> IO ()) -> GLDEBUGPROCFunc
+fromDebugProc debugProc source typ msgID severity len message _userParam = do
+  msg <- peekCStringLen (message, fromIntegral len)
+  debugProc (DebugMessage (unmarshalDebugSource source)
+                          (unmarshalDebugType typ)
+                          (DebugMessageID msgID)
+                          (unmarshalDebugSeverity severity)
+                          msg)
+
+--------------------------------------------------------------------------------
+
+maxDebugLoggedMessages :: GettableStateVar GLsizei
+maxDebugLoggedMessages =
+  makeGettableStateVar (getSizei1 id GetMaxDebugLoggedMessages)
+
+debugLoggedMessages :: IO [DebugMessage]
+debugLoggedMessages = do
+  count <- getSizei1 fromIntegral GetDebugLoggedMessages
+  replicateM count debugNextLoggedMessage
+
+debugNextLoggedMessage :: IO DebugMessage
+debugNextLoggedMessage = do
+  len <- getSizei1 id GetDebugNextLoggedMessageLength
+  alloca $ \sourceBuf ->
+    alloca $ \typeBuf ->
+      alloca $ \idBuf ->
+        alloca $ \severityBuf ->
+          allocaArray (fromIntegral len) $ \messageBuf -> do
+            glGetDebugMessageLog 1 len sourceBuf typeBuf idBuf severityBuf
+                                 nullPtr messageBuf
+            source <- peek1 unmarshalDebugSource sourceBuf
+            typ <- peek1 unmarshalDebugType typeBuf
+            msgID <- peek1 DebugMessageID idBuf
+            severity <- peek1 unmarshalDebugSeverity severityBuf
+            message <- peekCStringLen (messageBuf, fromIntegral len)
+            return $ DebugMessage source typ msgID severity message
+
+--------------------------------------------------------------------------------
+
+debugMessageInsert :: DebugMessage -> IO ()
+debugMessageInsert (DebugMessage source typ msgID severity message) =
+  withCStringLen message $ \(msg, len) ->
+    glDebugMessageInsert (marshalDebugSource source)
+                         (marshalDebugType typ)
+                         (debugMessageID msgID)
+                         (marshalDebugSeverity severity)
+                         (fromIntegral len)
+                         msg
+
+--------------------------------------------------------------------------------
+
+data DebugGroup = DebugGroup DebugSource DebugMessageID String
+
+pushDebugGroup :: DebugSource -> DebugMessageID -> String -> IO ()
+pushDebugGroup source msgID message =
+  withCStringLen message $ \(msg, len) ->
+    glPushDebugGroup (marshalDebugSource source)
+                     (debugMessageID msgID)
+                     (fromIntegral len)
+                     msg
+
+popDebugGroup :: IO ()
+popDebugGroup = glPopDebugGroup
+
+withDebugGroup :: DebugSource -> DebugMessageID -> String -> IO a -> IO a
+withDebugGroup source msgID message =
+  bracket_ (pushDebugGroup source msgID message) popDebugGroup
+
+maxDebugGroupStackDepth :: GettableStateVar GLsizei
+maxDebugGroupStackDepth =
+  makeGettableStateVar (getSizei1 id GetMaxDebugGroupStackDepth)
+
+--------------------------------------------------------------------------------
+
+debugOutputSynchronous :: StateVar Capability
+debugOutputSynchronous = makeCapability CapDebugOutputSynchronous