module Graphics.Caramia.Internal.OpenGLDebug
( activateDebugMode
, flushDebugMessages )
where
import Graphics.GL.Ext.KHR.Debug
import Graphics.Caramia.Prelude
import Graphics.Caramia.Internal.OpenGLCApi
import Graphics.Caramia.Internal.ContextLocalData
import Control.Monad.Trans.State.Strict
import Control.Monad.IO.Class
import Control.Monad.Catch
import System.IO
import Foreign.Storable
import Foreign.C.String
import Foreign.Marshal.Array
import Foreign.Ptr
newtype DebugModeActivated = DebugModeActivated Bool
deriving ( Typeable )
activateDebugMode :: IO ()
activateDebugMode = when gl_KHR_debug $ mask_ $ do
glDebugMessageControl GL_DONT_CARE
GL_DONT_CARE
GL_DONT_CARE
0
nullPtr
GL_TRUE
glEnable GL_DEBUG_OUTPUT
withCStringLen "Debug output activated." $ \(cstr, len) ->
glDebugMessageInsert GL_DEBUG_SOURCE_APPLICATION
GL_DEBUG_TYPE_OTHER
0
GL_DEBUG_SEVERITY_LOW
(fromIntegral len)
cstr
storeContextLocalData (DebugModeActivated True)
flushDebugMessages :: MonadIO m => m ()
flushDebugMessages = liftIO $ do
DebugModeActivated debug_mode <-
retrieveContextLocalData $ return $ DebugModeActivated False
when debug_mode $
allocaArray 65535 $ \cstr_msg ->
allocaArray maxMsgs $ \sources ->
allocaArray maxMsgs $ \types ->
allocaArray maxMsgs $ \ids ->
allocaArray maxMsgs $ \severities ->
allocaArray maxMsgs $ \lengths -> do
num_msgs <- fromIntegral <$>
glGetDebugMessageLog (fromIntegral maxMsgs)
65535
sources
types
ids
severities
lengths
cstr_msg
flip evalStateT cstr_msg $ for_ [0..num_msgs1] $ \index -> do
src <- peo sources index
typ <- peo types index
id <- peo ids index
severity <- peo severities index
length <- peo lengths index
cur_ptr <- get
str <- liftIO $ peekCStringLen (cur_ptr, fromIntegral length)
liftIO $ hPutStrLn stderr $
"[" <> show id <> ", " <>
showSrc src <> ", " <>
showType typ <> ", " <>
showSeverity severity <> "] " <>
str
put (plusPtr cur_ptr $ fromIntegral length)
when (num_msgs >= maxMsgs) flushDebugMessages
where
peo ptr idx = liftIO $ peekElemOff ptr idx
maxMsgs = 10000
showSeverity :: GLenum -> String
showSeverity x | x == GL_DEBUG_SEVERITY_HIGH = "high"
| x == GL_DEBUG_SEVERITY_MEDIUM = "medium"
| x == GL_DEBUG_SEVERITY_LOW = "low"
showSeverity _ = "unknown"
showType :: GLenum -> String
showType x | x == GL_DEBUG_TYPE_ERROR = "error"
| x == GL_DEBUG_TYPE_DEPRECATED_BEHAVIOR = "deprecated"
| x == GL_DEBUG_TYPE_UNDEFINED_BEHAVIOR = "undefined"
| x == GL_DEBUG_TYPE_PORTABILITY = "portability"
| x == GL_DEBUG_TYPE_PERFORMANCE = "performance"
| x == GL_DEBUG_TYPE_OTHER = "other"
showType _ = "unknown"
showSrc :: GLenum -> String
showSrc x | x == GL_DEBUG_SOURCE_APPLICATION = "application"
| x == GL_DEBUG_SOURCE_OTHER = "other"
| x == GL_DEBUG_SOURCE_API = "api"
| x == GL_DEBUG_SOURCE_WINDOW_SYSTEM = "windowsystem"
| x == GL_DEBUG_SOURCE_SHADER_COMPILER = "shadercompiler"
| x == GL_DEBUG_SOURCE_THIRD_PARTY = "thirdparty"
showSrc _ = "unknown"