diff --git a/OpenGL.cabal b/OpenGL.cabal --- 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 @@ 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 @@ 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 --- a/src/Graphics/Rendering/OpenGL/GL.hs +++ b/src/Graphics/Rendering/OpenGL/GL.hs @@ -65,6 +65,7 @@ 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.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 --- a/src/Graphics/Rendering/OpenGL/GL/Capability.hs +++ b/src/Graphics/Rendering/OpenGL/GL/Capability.hs @@ -139,6 +139,8 @@ | CapTextureColorTable | CapVertexProgramPointSize | CapVertexProgramTwoSide + | CapDebugOutput + | CapDebugOutputSynchronous marshalEnableCap :: EnableCap -> Maybe GLenum marshalEnableCap x = case x of @@ -236,6 +238,8 @@ 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 new file mode 100644 --- /dev/null +++ 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 +-- 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 diff --git a/src/Graphics/Rendering/OpenGL/GL/QueryUtils/PName.hs b/src/Graphics/Rendering/OpenGL/GL/QueryUtils/PName.hs --- a/src/Graphics/Rendering/OpenGL/GL/QueryUtils/PName.hs +++ b/src/Graphics/Rendering/OpenGL/GL/QueryUtils/PName.hs @@ -28,13 +28,16 @@ GetPNameMatrix(..), PNameMatrix(..), - clipPlaneIndexToEnum + clipPlaneIndexToEnum, + + GetPointervPName(..), getPointer ) where -import Foreign.Marshal.Alloc -import Foreign.Marshal.Array -import Foreign.Ptr -import Foreign.Storable +import Foreign.Marshal.Alloc ( alloca ) +import Foreign.Marshal.Array ( allocaArray, peekArray ) +import Foreign.Marshal.Utils ( with ) +import Foreign.Ptr ( Ptr, nullPtr, castPtr ) +import Foreign.Storable ( Storable(peek) ) import Graphics.Rendering.OpenGL.GL.PeekPoke import Graphics.Rendering.OpenGL.GLU.ErrorsInternal import Graphics.Rendering.OpenGL.Raw @@ -552,6 +555,12 @@ | GetShaderCompiler -- ^ bool | GetNumShaderBinaryFormats -- ^ int | GetNumProgramBinaryFormats -- ^ int + -- Debug Output + | GetMaxDebugMessageLength -- ^ int + | GetMaxDebugLoggedMessages -- ^ int + | GetDebugLoggedMessages -- ^ int + | GetDebugNextLoggedMessageLength -- ^ int + | GetMaxDebugGroupStackDepth -- ^ int instance GetPName1I PName1I where @@ -815,6 +824,12 @@ GetShaderCompiler -> Just gl_SHADER_COMPILER GetNumShaderBinaryFormats -> Just gl_NUM_SHADER_BINARY_FORMATS GetNumProgramBinaryFormats -> Just gl_NUM_PROGRAM_BINARY_FORMATS + -- Debug Output + GetMaxDebugMessageLength -> Just gl_MAX_DEBUG_MESSAGE_LENGTH + GetMaxDebugLoggedMessages -> Just gl_MAX_DEBUG_LOGGED_MESSAGES + GetDebugLoggedMessages -> Just gl_DEBUG_LOGGED_MESSAGES + GetDebugNextLoggedMessageLength -> Just gl_DEBUG_NEXT_LOGGED_MESSAGE_LENGTH + GetMaxDebugGroupStackDepth -> Just gl_MAX_DEBUG_GROUP_STACK_DEPTH -- 0x8825 through 0x8834 are reserved for draw buffers @@ -1187,3 +1202,49 @@ GetTextureMatrix -> Just gl_TEXTURE_MATRIX GetColorMatrix -> Just gl_COLOR_MATRIX GetMatrixPalette -> Just gl_MATRIX_PALETTE_ARB + +-------------------------------------------------------------------------------- + +data GetPointervPName = + -- core profile + DebugCallbackFunction + | DebugCallbackUserParam + -- compatibility profile + | SelectionBufferPointer + | FeedbackBufferPointer + | VertexArrayPointer + | NormalArrayPointer + | ColorArrayPointer + | SecondaryColorArrayPointer + | IndexArrayPointer + | TextureCoordArrayPointer + | FogCoordArrayPointer + | EdgeFlagArrayPointer + -- GL_ARB_vertex_blend + | WeightArrayPointer + -- GL_ARB_matrix_palette + | MatrixIndexArrayPointer + +marshalGetPointervPName :: GetPointervPName -> GLenum +marshalGetPointervPName x = case x of + DebugCallbackFunction -> gl_DEBUG_CALLBACK_FUNCTION + DebugCallbackUserParam -> gl_DEBUG_CALLBACK_USER_PARAM + SelectionBufferPointer -> gl_SELECTION_BUFFER_POINTER + FeedbackBufferPointer -> gl_FEEDBACK_BUFFER_POINTER + VertexArrayPointer -> gl_VERTEX_ARRAY_POINTER + NormalArrayPointer -> gl_NORMAL_ARRAY_POINTER + ColorArrayPointer -> gl_COLOR_ARRAY_POINTER + SecondaryColorArrayPointer -> gl_SECONDARY_COLOR_ARRAY_POINTER + IndexArrayPointer -> gl_INDEX_ARRAY_POINTER + TextureCoordArrayPointer -> gl_TEXTURE_COORD_ARRAY_POINTER + FogCoordArrayPointer -> gl_FOG_COORD_ARRAY_POINTER + EdgeFlagArrayPointer -> gl_EDGE_FLAG_ARRAY_POINTER + WeightArrayPointer -> gl_WEIGHT_ARRAY_POINTER_ARB + MatrixIndexArrayPointer -> gl_MATRIX_INDEX_ARRAY_POINTER_ARB + +-------------------------------------------------------------------------------- + +getPointer :: GetPointervPName -> IO (Ptr a) +getPointer n = with nullPtr $ \buf -> do + glGetPointerv (marshalGetPointervPName n) buf + peek buf diff --git a/src/Graphics/Rendering/OpenGL/GL/VertexArrays.hs b/src/Graphics/Rendering/OpenGL/GL/VertexArrays.hs --- a/src/Graphics/Rendering/OpenGL/GL/VertexArrays.hs +++ b/src/Graphics/Rendering/OpenGL/GL/VertexArrays.hs @@ -35,9 +35,7 @@ vertexAttribPointer, vertexAttribArray, ) where -import Foreign.Marshal.Utils -import Foreign.Ptr -import Foreign.Storable +import Foreign.Ptr ( Ptr, nullPtr ) import Graphics.Rendering.OpenGL.GL.Capability import Graphics.Rendering.OpenGL.GL.DataType import Graphics.Rendering.OpenGL.GL.GLboolean @@ -404,44 +402,6 @@ Nothing -> glDisableClientState gl_PRIMITIVE_RESTART_NV Just idx -> do glEnableClientState gl_PRIMITIVE_RESTART_NV glPrimitiveRestartIndexNV (fromIntegral idx) - --------------------------------------------------------------------------------- - -data GetPointervPName = - VertexArrayPointer - | NormalArrayPointer - | ColorArrayPointer - | IndexArrayPointer - | TextureCoordArrayPointer - | EdgeFlagArrayPointer - | FogCoordArrayPointer - | SecondaryColorArrayPointer - | FeedbackBufferPointer - | SelectionBufferPointer - | WeightArrayPointer - | MatrixIndexArrayPointer - -marshalGetPointervPName :: GetPointervPName -> GLenum -marshalGetPointervPName x = case x of - VertexArrayPointer -> gl_VERTEX_ARRAY_POINTER - NormalArrayPointer -> gl_NORMAL_ARRAY_POINTER - ColorArrayPointer -> gl_COLOR_ARRAY_POINTER - IndexArrayPointer -> gl_INDEX_ARRAY_POINTER - TextureCoordArrayPointer -> gl_TEXTURE_COORD_ARRAY_POINTER - EdgeFlagArrayPointer -> gl_EDGE_FLAG_ARRAY_POINTER - FogCoordArrayPointer -> gl_FOG_COORD_ARRAY_POINTER - SecondaryColorArrayPointer -> gl_SECONDARY_COLOR_ARRAY_POINTER - FeedbackBufferPointer -> gl_FEEDBACK_BUFFER_POINTER - SelectionBufferPointer -> gl_SELECTION_BUFFER_POINTER - WeightArrayPointer -> gl_WEIGHT_ARRAY_POINTER_ARB - MatrixIndexArrayPointer -> gl_MATRIX_INDEX_ARRAY_POINTER_ARB - --------------------------------------------------------------------------------- - -getPointer :: GetPointervPName -> IO (Ptr a) -getPointer n = with nullPtr $ \buf -> do - glGetPointerv (marshalGetPointervPName n) buf - peek buf --------------------------------------------------------------------------------