Skip to content

Commit caf4d11

Browse files
svenpannesvenpanne
committed
Added most of the debug output API.
1 parent 068710c commit caf4d11

File tree

6 files changed

+365
-47
lines changed

6 files changed

+365
-47
lines changed

‎OpenGL.cabal

Lines changed: 9 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
name: OpenGL
2-
version: 2.11.0.0
2+
version: 2.11.1.0
33
synopsis: A binding for the OpenGL graphics system
44
description:
55
A Haskell binding for the OpenGL graphics system (GL, version 4.5) and its
@@ -36,6 +36,7 @@ library
3636
Graphics.Rendering.OpenGL.GL.Colors
3737
Graphics.Rendering.OpenGL.GL.ConditionalRendering
3838
Graphics.Rendering.OpenGL.GL.CoordTrans
39+
Graphics.Rendering.OpenGL.GL.DebugOutput
3940
Graphics.Rendering.OpenGL.GL.DisplayLists
4041
Graphics.Rendering.OpenGL.GL.Evaluators
4142
Graphics.Rendering.OpenGL.GL.Feedback
@@ -154,6 +155,13 @@ library
154155
DeriveDataTypeable
155156
KindSignatures
156157
TypeSynonymInstances
158+
if os(windows)
159+
if arch(i386)
160+
cpp-options: "-DCALLCONV=stdcall"
161+
else
162+
cpp-options: "-DCALLCONV=ccall"
163+
else
164+
cpp-options: "-DCALLCONV=ccall"
157165

158166
source-repository head
159167
type: git

‎src/Graphics/Rendering/OpenGL/GL.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -65,6 +65,7 @@ module Graphics.Rendering.OpenGL.GL (
6565
module Graphics.Rendering.OpenGL.GL.Hints,
6666
module Graphics.Rendering.OpenGL.GL.PixellikeObject,
6767
module Graphics.Rendering.OpenGL.GL.TransformFeedback,
68+
module Graphics.Rendering.OpenGL.GL.DebugOutput,
6869

6970
-- * State and State Requests
7071
module Graphics.Rendering.OpenGL.GL.StateVar,
@@ -117,6 +118,7 @@ import Graphics.Rendering.OpenGL.GL.DisplayLists
117118
import Graphics.Rendering.OpenGL.GL.Hints
118119
import Graphics.Rendering.OpenGL.GL.PixellikeObject
119120
import Graphics.Rendering.OpenGL.GL.TransformFeedback
121+
import Graphics.Rendering.OpenGL.GL.DebugOutput
120122

121123
import Graphics.Rendering.OpenGL.GL.StateVar
122124
import Graphics.Rendering.OpenGL.GL.Tensor

‎src/Graphics/Rendering/OpenGL/GL/Capability.hs

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -139,6 +139,8 @@ data EnableCap =
139139
| CapTextureColorTable
140140
| CapVertexProgramPointSize
141141
| CapVertexProgramTwoSide
142+
| CapDebugOutput
143+
| CapDebugOutputSynchronous
142144

143145
marshalEnableCap :: EnableCap -> Maybe GLenum
144146
marshalEnableCap x = case x of
@@ -236,6 +238,8 @@ marshalEnableCap x = case x of
236238
CapTextureColorTable -> Just gl_TEXTURE_COLOR_TABLE_SGI
237239
CapVertexProgramPointSize -> Just gl_VERTEX_PROGRAM_POINT_SIZE
238240
CapVertexProgramTwoSide -> Just gl_VERTEX_PROGRAM_TWO_SIDE
241+
CapDebugOutput -> Just gl_DEBUG_OUTPUT
242+
CapDebugOutputSynchronous -> Just gl_DEBUG_OUTPUT_SYNCHRONOUS
239243

240244
--------------------------------------------------------------------------------
241245

‎src/Graphics/Rendering/OpenGL/GL/DebugOutput.hs

Lines changed: 283 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,283 @@
1+
{-# LANGUAGE CPP #-}
2+
--------------------------------------------------------------------------------
3+
-- |
4+
-- Module : Graphics.Rendering.OpenGL.GL.DebugOutput
5+
-- Copyright : (c) Sven Panne 2015
6+
-- License : BSD3
7+
--
8+
-- Maintainer : Sven Panne <svenpanne@gmail.com>
9+
-- Stability : stable
10+
-- Portability : portable
11+
--
12+
-- This module corresponds to section 20 (Debug Output) of the OpenGL 4.5
13+
-- specs.
14+
--
15+
--------------------------------------------------------------------------------
16+
17+
module Graphics.Rendering.OpenGL.GL.DebugOutput (
18+
-- * Debug Messages
19+
debugOutput, DebugMessage(..), DebugSource(..), DebugType(..),
20+
DebugMessageID(..), DebugSeverity(..), maxDebugMessageLength,
21+
22+
-- * Debug Message Callback
23+
debugMessageCallback,
24+
25+
-- * Debug Message Log
26+
maxDebugLoggedMessages, debugLoggedMessages,
27+
28+
-- * Controlling Debug Messages (TODO)
29+
30+
-- * Externally Generated Messages
31+
debugMessageInsert,
32+
33+
-- * Debug Groups
34+
DebugGroup(..), pushDebugGroup, popDebugGroup, withDebugGroup,
35+
maxDebugGroupStackDepth,
36+
37+
-- * Debug Labels (TODO)
38+
39+
-- * Asynchronous and Synchronous Debug Output
40+
debugOutputSynchronous
41+
) where
42+
43+
import Control.Monad ( unless, replicateM )
44+
import Foreign.C.String ( peekCStringLen, withCStringLen )
45+
import Foreign.C.Types
46+
import Foreign.Marshal.Alloc ( alloca )
47+
import Foreign.Marshal.Array ( allocaArray )
48+
import Foreign.Ptr (
49+
Ptr, nullPtr, castPtrToFunPtr, FunPtr, nullFunPtr, freeHaskellFunPtr )
50+
import Graphics.Rendering.OpenGL.GL.Capability
51+
import Graphics.Rendering.OpenGL.GL.Exception
52+
import Graphics.Rendering.OpenGL.GL.PeekPoke
53+
import Graphics.Rendering.OpenGL.GL.QueryUtils
54+
import Graphics.Rendering.OpenGL.GL.StateVar
55+
import Graphics.Rendering.OpenGL.Raw
56+
57+
--------------------------------------------------------------------------------
58+
59+
debugOutput :: StateVar Capability
60+
debugOutput = makeCapability CapDebugOutput
61+
62+
--------------------------------------------------------------------------------
63+
64+
data DebugMessage =
65+
DebugMessage DebugSource DebugType DebugMessageID DebugSeverity String
66+
deriving ( Eq, Ord, Show )
67+
68+
--------------------------------------------------------------------------------
69+
70+
data DebugSource =
71+
DebugSourceAPI
72+
| DebugSourceShaderCompiler
73+
| DebugSourceWindowSystem
74+
| DebugSourceThirdParty
75+
| DebugSourceApplication
76+
| DebugSourceOther
77+
deriving ( Eq, Ord, Show )
78+
79+
marshalDebugSource :: DebugSource -> GLenum
80+
marshalDebugSource x = case x of
81+
DebugSourceAPI -> gl_DEBUG_SOURCE_API
82+
DebugSourceShaderCompiler -> gl_DEBUG_SOURCE_SHADER_COMPILER
83+
DebugSourceWindowSystem -> gl_DEBUG_SOURCE_WINDOW_SYSTEM
84+
DebugSourceThirdParty -> gl_DEBUG_SOURCE_THIRD_PARTY
85+
DebugSourceApplication -> gl_DEBUG_SOURCE_APPLICATION
86+
DebugSourceOther -> gl_DEBUG_SOURCE_OTHER
87+
88+
unmarshalDebugSource :: GLenum -> DebugSource
89+
unmarshalDebugSource x
90+
| x == gl_DEBUG_SOURCE_API = DebugSourceAPI
91+
| x == gl_DEBUG_SOURCE_SHADER_COMPILER = DebugSourceShaderCompiler
92+
| x == gl_DEBUG_SOURCE_WINDOW_SYSTEM = DebugSourceWindowSystem
93+
| x == gl_DEBUG_SOURCE_THIRD_PARTY = DebugSourceThirdParty
94+
| x == gl_DEBUG_SOURCE_APPLICATION = DebugSourceApplication
95+
| x == gl_DEBUG_SOURCE_OTHER = DebugSourceOther
96+
| otherwise = error ("unmarshalDebugSource: illegal value " ++ show x)
97+
98+
--------------------------------------------------------------------------------
99+
100+
data DebugType =
101+
DebugTypeError
102+
| DebugTypeDeprecatedBehavior
103+
| DebugTypeUndefinedBehavior
104+
| DebugTypePerformance
105+
| DebugTypePortability
106+
| DebugTypeMarker
107+
| DebugTypePushGroup
108+
| DebugTypePopGroup
109+
| DebugTypeOther
110+
deriving ( Eq, Ord, Show )
111+
112+
marshalDebugType :: DebugType -> GLenum
113+
marshalDebugType x = case x of
114+
DebugTypeError -> gl_DEBUG_TYPE_ERROR
115+
DebugTypeDeprecatedBehavior -> gl_DEBUG_TYPE_DEPRECATED_BEHAVIOR
116+
DebugTypeUndefinedBehavior -> gl_DEBUG_TYPE_UNDEFINED_BEHAVIOR
117+
DebugTypePerformance -> gl_DEBUG_TYPE_PERFORMANCE
118+
DebugTypePortability -> gl_DEBUG_TYPE_PORTABILITY
119+
DebugTypeMarker -> gl_DEBUG_TYPE_MARKER
120+
DebugTypePushGroup -> gl_DEBUG_TYPE_PUSH_GROUP
121+
DebugTypePopGroup -> gl_DEBUG_TYPE_POP_GROUP
122+
DebugTypeOther -> gl_DEBUG_TYPE_OTHER
123+
124+
unmarshalDebugType :: GLenum -> DebugType
125+
unmarshalDebugType x
126+
| x == gl_DEBUG_TYPE_ERROR = DebugTypeError
127+
| x == gl_DEBUG_TYPE_DEPRECATED_BEHAVIOR = DebugTypeDeprecatedBehavior
128+
| x == gl_DEBUG_TYPE_UNDEFINED_BEHAVIOR = DebugTypeUndefinedBehavior
129+
| x == gl_DEBUG_TYPE_PERFORMANCE = DebugTypePerformance
130+
| x == gl_DEBUG_TYPE_PORTABILITY = DebugTypePortability
131+
| x == gl_DEBUG_TYPE_MARKER = DebugTypeMarker
132+
| x == gl_DEBUG_TYPE_PUSH_GROUP = DebugTypePushGroup
133+
| x == gl_DEBUG_TYPE_POP_GROUP = DebugTypePopGroup
134+
| x == gl_DEBUG_TYPE_OTHER = DebugTypeOther
135+
| otherwise = error ("unmarshalDebugType: illegal value " ++ show x)
136+
137+
--------------------------------------------------------------------------------
138+
139+
newtype DebugMessageID = DebugMessageID { debugMessageID :: GLuint }
140+
deriving ( Eq, Ord, Show )
141+
142+
--------------------------------------------------------------------------------
143+
144+
data DebugSeverity =
145+
DebugSeverityHigh
146+
| DebugSeverityMedium
147+
| DebugSeverityLow
148+
| DebugSeverityNotification
149+
deriving ( Eq, Ord, Show )
150+
151+
marshalDebugSeverity :: DebugSeverity -> GLenum
152+
marshalDebugSeverity x = case x of
153+
DebugSeverityHigh -> gl_DEBUG_SEVERITY_HIGH
154+
DebugSeverityMedium -> gl_DEBUG_SEVERITY_MEDIUM
155+
DebugSeverityLow -> gl_DEBUG_SEVERITY_LOW
156+
DebugSeverityNotification -> gl_DEBUG_SEVERITY_NOTIFICATION
157+
158+
unmarshalDebugSeverity :: GLenum -> DebugSeverity
159+
unmarshalDebugSeverity x
160+
| x == gl_DEBUG_SEVERITY_HIGH = DebugSeverityHigh
161+
| x == gl_DEBUG_SEVERITY_MEDIUM = DebugSeverityMedium
162+
| x == gl_DEBUG_SEVERITY_LOW = DebugSeverityLow
163+
| x == gl_DEBUG_SEVERITY_NOTIFICATION = DebugSeverityNotification
164+
| otherwise = error ("unmarshalDebugSeverity: illegal value " ++ show x)
165+
166+
--------------------------------------------------------------------------------
167+
168+
maxDebugMessageLength :: GettableStateVar GLsizei
169+
maxDebugMessageLength =
170+
makeGettableStateVar (getSizei1 id GetMaxDebugMessageLength)
171+
172+
--------------------------------------------------------------------------------
173+
174+
debugMessageCallback :: StateVar (Maybe (DebugMessage -> IO ()))
175+
debugMessageCallback =
176+
makeStateVar getDebugMessageCallback setDebugMessageCallback
177+
178+
getDebugMessageCallback :: IO (Maybe (DebugMessage -> IO ()))
179+
getDebugMessageCallback = do
180+
cb <- castPtrToFunPtr `fmap` getPointer DebugCallbackFunction
181+
return $ if (cb == nullFunPtr)
182+
then Nothing
183+
else Just . toDebugProc . dyn_debugProc $ cb
184+
185+
foreign import CALLCONV "dynamic" dyn_debugProc
186+
:: FunPtr GLDEBUGPROCFunc -> GLDEBUGPROCFunc
187+
188+
toDebugProc:: GLDEBUGPROCFunc -> DebugMessage -> IO ()
189+
toDebugProc debugFunc (DebugMessage source typ msgID severity message) =
190+
withCStringLen message $ \(msg, len) -> do
191+
debugFunc (marshalDebugSource source)
192+
(marshalDebugType typ)
193+
(marshalDebugSeverity severity)
194+
(debugMessageID msgID)
195+
(fromIntegral len)
196+
msg
197+
nullPtr
198+
199+
setDebugMessageCallback :: Maybe (DebugMessage -> IO ()) -> IO ()
200+
setDebugMessageCallback maybeDebugProc = do
201+
oldCB <- castPtrToFunPtr `fmap` getPointer DebugCallbackFunction
202+
unless (oldCB == nullFunPtr) $
203+
freeHaskellFunPtr oldCB
204+
newCB <-
205+
maybe (return nullFunPtr) (makeGLDEBUGPROC . fromDebugProc) maybeDebugProc
206+
glDebugMessageCallbackARB newCB nullPtr
207+
208+
fromDebugProc:: (DebugMessage -> IO ()) -> GLDEBUGPROCFunc
209+
fromDebugProc debugProc source typ msgID severity len message _userParam = do
210+
msg <- peekCStringLen (message, fromIntegral len)
211+
debugProc (DebugMessage (unmarshalDebugSource source)
212+
(unmarshalDebugType typ)
213+
(DebugMessageID msgID)
214+
(unmarshalDebugSeverity severity)
215+
msg)
216+
217+
--------------------------------------------------------------------------------
218+
219+
maxDebugLoggedMessages :: GettableStateVar GLsizei
220+
maxDebugLoggedMessages =
221+
makeGettableStateVar (getSizei1 id GetMaxDebugLoggedMessages)
222+
223+
debugLoggedMessages :: IO [DebugMessage]
224+
debugLoggedMessages = do
225+
count <- getSizei1 fromIntegral GetDebugLoggedMessages
226+
replicateM count debugNextLoggedMessage
227+
228+
debugNextLoggedMessage :: IO DebugMessage
229+
debugNextLoggedMessage = do
230+
len <- getSizei1 id GetDebugNextLoggedMessageLength
231+
alloca $ \sourceBuf ->
232+
alloca $ \typeBuf ->
233+
alloca $ \idBuf ->
234+
alloca $ \severityBuf ->
235+
allocaArray (fromIntegral len) $ \messageBuf -> do
236+
glGetDebugMessageLog 1 len sourceBuf typeBuf idBuf severityBuf
237+
nullPtr messageBuf
238+
source <- peek1 unmarshalDebugSource sourceBuf
239+
typ <- peek1 unmarshalDebugType typeBuf
240+
msgID <- peek1 DebugMessageID idBuf
241+
severity <- peek1 unmarshalDebugSeverity severityBuf
242+
message <- peekCStringLen (messageBuf, fromIntegral len)
243+
return $ DebugMessage source typ msgID severity message
244+
245+
--------------------------------------------------------------------------------
246+
247+
debugMessageInsert :: DebugMessage -> IO ()
248+
debugMessageInsert (DebugMessage source typ msgID severity message) =
249+
withCStringLen message $ \(msg, len) ->
250+
glDebugMessageInsert (marshalDebugSource source)
251+
(marshalDebugType typ)
252+
(debugMessageID msgID)
253+
(marshalDebugSeverity severity)
254+
(fromIntegral len)
255+
msg
256+
257+
--------------------------------------------------------------------------------
258+
259+
data DebugGroup = DebugGroup DebugSource DebugMessageID String
260+
261+
pushDebugGroup :: DebugSource -> DebugMessageID -> String -> IO ()
262+
pushDebugGroup source msgID message =
263+
withCStringLen message $ \(msg, len) ->
264+
glPushDebugGroup (marshalDebugSource source)
265+
(debugMessageID msgID)
266+
(fromIntegral len)
267+
msg
268+
269+
popDebugGroup :: IO ()
270+
popDebugGroup = glPopDebugGroup
271+
272+
withDebugGroup :: DebugSource -> DebugMessageID -> String -> IO a -> IO a
273+
withDebugGroup source msgID message =
274+
bracket_ (pushDebugGroup source msgID message) popDebugGroup
275+
276+
maxDebugGroupStackDepth :: GettableStateVar GLsizei
277+
maxDebugGroupStackDepth =
278+
makeGettableStateVar (getSizei1 id GetMaxDebugGroupStackDepth)
279+
280+
--------------------------------------------------------------------------------
281+
282+
debugOutputSynchronous :: StateVar Capability
283+
debugOutputSynchronous = makeCapability CapDebugOutputSynchronous

0 commit comments

Comments
 (0)