Debug info for gtk Lambda2 experiment.

1 files changed, 38 insertions, 1 deletions

diff --git a/Lambda2.hs b/Lambda2.hs
index bedf18c..9e0be24 100644
--- a/Lambda2.hs
+++ b/Lambda2.hs
@@ -2,6 +2,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Lambda2 where
 
+import qualified Graphics.Rendering.OpenGL as GL
+
 import GI.Gtk.Objects (GLArea,gLAreaGetContext,widgetGetWindow)
 import GI.Gdk.Objects.GLContext (GLContext, gLContextGetDebugEnabled,
                                  gLContextGetForwardCompatible,
@@ -10,7 +12,8 @@ import GI.Gdk.Objects.GLContext (GLContext, gLContextGetDebugEnabled,
                                  gLContextGetRequiredVersion,
                                  gLContextSetRequiredVersion,
                                  gLContextGetUseEs,
-                                 getGLContextWindow)
+                                 getGLContextWindow,
+                                 gLContextMakeCurrent)
 import GI.Gdk.Objects.Window (windowCreateGlContext,windowGetWidth,windowGetHeight)
 
 import qualified Data.Map as Map
@@ -21,6 +24,8 @@ import LambdaCube.GL.Mesh as LambdaCubeGL
 import Codec.Picture as Juicy
 import Data.Aeson
 import qualified Data.ByteString as SB
+import Data.Char
+import Text.Printf
 
 data State = State
 
@@ -74,6 +79,8 @@ render st glarea gl = do
                               Just t <- return $ Just (1.0::Double) -- GLFW.getTime
                               return (realToFrac t :: Float)
                 -- render
+                GL.clearColor GL.$= GL.Color4 0 255 0 1
+                GL.clear [GL.ColorBuffer]
                 putStrLn "LambdaCubeGL.renderFrame enter"
                 LambdaCubeGL.renderFrame renderer
                 putStrLn "LambdaCubeGL.renderFrame exit"
@@ -112,12 +119,28 @@ triangleB = Mesh
 realize :: State -> GLArea -> IO ()
 realize st glarea = do
     putStrLn "realize!"
+    {-
+    GL.debugMessageInsert (GL.DebugMessage GL.DebugSourceApplication
+                                           GL.DebugTypeOther
+                                           (GL.DebugMessageID 0)
+                                           GL.DebugSeverityHigh
+                                           "Hello2 world!")
+    -}
     return ()
 
 unrealize :: State -> GLArea -> IO ()
 unrealize st glarea = do
     return ()
 
+prettyDebug (GL.DebugMessage src typ (GL.DebugMessageID mid) severity msg) = unwords ws
+ where
+    ws = [wsrc,wtyp,wmid,wseverity,msg]
+    -- DebugSourceShaderCompiler DebugTypeOther 1 DebugSeverityNotification
+    wsrc = filter isUpper $ drop 11 $ show src
+    wtyp = take 2 $ drop 9 $ show typ
+    wmid = printf "%03i" mid
+    wseverity = drop 13 $ show severity
+
 createContext :: State -> GLArea -> IO GLContext
 createContext st glarea = do
     putStrLn "createContext!"
@@ -147,4 +170,18 @@ createContext st glarea = do
                        , "fw:",show v_fw
                        , "ver:", show (maj,min)
                        ]
+    let pdebug m@(GL.DebugMessage src typ mid severity msg) = do
+            putStrLn (">> " ++ prettyDebug m)
+    gLContextMakeCurrent gl
+    GL.debugOutput GL.$= GL.Enabled
+    GL.debugOutputSynchronous GL.$= GL.Enabled
+    GL.debugMessageControl (GL.MessageGroup Nothing Nothing Nothing) GL.$= GL.Enabled
+    GL.debugMessageCallback GL.$= Just pdebug
+    {-
+    GL.debugMessageInsert (GL.DebugMessage GL.DebugSourceApplication
+                                           GL.DebugTypeOther
+                                           (GL.DebugMessageID 0)
+                                           GL.DebugSeverityHigh
+                                           "Hello world!")
+    -}
     return gl