Example using GLArea without gtk-declarative.

3 files changed, 286 insertions, 0 deletions

diff --git a/Triangle.hs b/Triangle.hs
new file mode 100644
index 0000000..cf26fe6
--- /dev/null
+++ b/Triangle.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Triangle where
+
+import Graphics.Rendering.OpenGL as GL
+import GI.Gtk as Gtk
+import GI.Gdk.Objects
+
+import Control.Concurrent
+import Control.Monad
+import Data.ByteString (ByteString)
+import Foreign.Marshal (newArray)
+import Foreign.Ptr
+import Foreign.Storable
+
+import UtilGL
+
+fragment_source :: ByteString
+fragment_source = [glslFragment|
+#version 330
+in vec4 inputColor;
+out vec4 outputColor;
+void main() {
+outputColor = vec4(1.0f, 0.0f, 0.0f, 0.0f); //constant red. I know it's a poor shader
+}
+|]
+
+vertex_source :: ByteString
+vertex_source = [glslVertex|
+#version 330
+in vec4 position;
+void main() { gl_Position =  position; }
+|]
+
+data State = State
+    { stProgram :: Maybe Program
+    , stBuffer  :: Maybe BufferObject
+    }
+
+initState :: IO (MVar State)
+initState = newMVar State
+    { stProgram = Nothing
+    , stBuffer  = Nothing
+    }
+
+drawTriangle :: MVar State -> IO ()
+drawTriangle svar = withMVar svar $ \st -> do
+    forM_ ((,) <$> stProgram st <*> stBuffer st) $ \(program,position_buffer) -> do
+
+    -- Use our shaders
+    GL.currentProgram $= Just program
+
+    -- Use the vertices in our buffer
+    GL.bindBuffer ArrayBuffer $= Just position_buffer
+    GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled
+    GL.vertexAttribPointer (GL.AttribLocation 0) $= (GL.ToFloat,VertexArrayDescriptor 4 GL.Float 0 nullPtr)
+    -- Draw the three vertices as a triangle
+    GL.drawArrays Triangles 0 3
+
+    -- We finished using the buffers and program
+    GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Disabled
+    GL.bindBuffer ArrayBuffer $= Nothing
+
+render :: MVar State -> GLArea -> GLContext -> IO Bool
+render svar w gl = do
+    putStrLn "render!"
+    me <- gLAreaGetError w
+    maybe id (\e _ -> print e) me $ do
+        -- Clear the viewport
+        GL.clearColor $= GL.Color4 0 0 0 1
+        GL.clear [ColorBuffer]
+        -- draw our object
+        drawTriangle svar
+        GL.flush
+
+    return True
+
+realize :: MVar State -> GLArea -> IO ()
+realize svar w = do
+    putStrLn "realize!"
+    gLAreaMakeCurrent w
+    me <- gLAreaGetError w
+    maybe id (\e _ -> print e) me $ do
+        ctx <- gLAreaGetContext w
+
+        -- We only use one VAO, so we always keep it bound
+        vao <- GL.genObjectName
+        GL.bindVertexArrayObject $= Just vao
+
+        (vertex_data_sz,vertex_data) <- do
+            ptr <- newArray [ GL.Vertex4  0      0.5       0  1
+                            , GL.Vertex4  0.5    (-0.366)  0  1
+                            , GL.Vertex4  (-0.5) (-0.366)  0  1
+                            ]
+            return ( fromIntegral $ 3 * sizeOf (GL.Vertex4 0 0 0 (0 :: Float) )
+                   , ptr :: Ptr (GL.Vertex4 Float) )
+
+        -- This is the buffer that holds the vertices
+        buffer <- GL.genObjectName
+        GL.bindBuffer ArrayBuffer $= Just buffer
+        GL.bufferData ArrayBuffer $= (vertex_data_sz, vertex_data, StaticDraw)
+        GL.bindBuffer ArrayBuffer $= Nothing
+
+        mfrag <- makeShader FragmentShader fragment_source
+        mvert <- makeShader VertexShader vertex_source
+        mprog <- makeProgram mfrag mvert
+
+        modifyMVar_ svar $ \_ -> return State
+            { stProgram = mprog
+            , stBuffer  = Just buffer
+            }
+
+        return ()
+
+
+unrealize :: GLArea -> IO ()
+unrealize _ = do
+    putStrLn "unrealize!"
diff --git a/UtilGL.hs b/UtilGL.hs
new file mode 100644
index 0000000..22347c3
--- /dev/null
+++ b/UtilGL.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE QuasiQuotes #-}
+module UtilGL where
+
+import Control.Concurrent (threadDelay, yield)
+import Control.Monad
+import Data.Bool
+import Data.ByteString (ByteString)
+import Data.Maybe
+import Data.IORef
+import System.IO
+import System.Directory
+import System.Process
+import System.Exit
+import Graphics.Rendering.OpenGL as GL
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+import Text.Printf
+
+data Env = Env
+    { mycolor :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
+    }
+
+
+cbDebugMessage :: GL.DebugMessage -> IO ()
+cbDebugMessage (DebugMessage src typ mid severity msg) = do
+    let src' = take 14 $ drop 11 $ show src ++ repeat ' '
+    hPutStrLn stderr $ concat [src', ": ", msg]
+
+notify :: String -> IO ()
+notify msg = do
+    cb <- get GL.debugMessageCallback
+    (maybe cbDebugMessage (const GL.debugMessageInsert) cb)
+        $ DebugMessage DebugSourceApplication DebugTypeMarker (DebugMessageID 0) DebugSeverityNotification msg
+
+invertedColor4 :: Num a => a -> a -> a -> a -> Color4 a
+invertedColor4 r g b a = Color4 (1-r) (1-g) (1-b) a
+
+initGL :: IO Env
+initGL = do
+    GL.debugOutput $=! Enabled
+    dbref <- newIORef Nothing
+    let setDebugMessageCallback _ = do
+            writeIORef dbref $ Just cbDebugMessage
+            hPutStrLn stderr "Application   : Debug log enabled."
+    GL.debugMessageCallback $=! Just setDebugMessageCallback
+    GL.debugMessageInsert
+        $ DebugMessage DebugSourceApplication DebugTypeMarker (DebugMessageID 0) DebugSeverityNotification
+                       "Debug log test: timeout."
+    stamp <- fmap (++ "/.config/inverted") getHomeDirectory
+    mycolor <- bool Color4 invertedColor4 <$> doesFileExist stamp
+    yield
+    threadDelay 10000
+    dbc <- readIORef dbref
+    GL.debugMessageCallback $=! dbc
+    notify "Initialized."
+    return Env { mycolor = mycolor }
+
+makeShader :: ShaderType -> ByteString -> IO (Maybe Shader)
+makeShader typ src = do
+    shader <- GL.createShader typ
+    GL.shaderSourceBS shader $= src
+    GL.compileShader shader
+    stv <- get (GL.compileStatus shader)
+    nfo <- get (GL.shaderInfoLog shader)
+    when (not stv) $ hPutStrLn stderr nfo
+    return $ guard stv >> Just shader
+
+makeProgram :: Maybe Shader -> Maybe Shader -> IO (Maybe Program)
+makeProgram vshader fshader = mkP $ catMaybes [vshader,fshader]
+ where
+    mkP [vshader,fshader] = do
+        prog <- GL.createProgram
+        GL.attachShader prog vshader
+        GL.attachShader prog fshader
+        GL.linkProgram prog
+        stp <- get (GL.linkStatus prog)
+        nfo <- get(GL.programInfoLog prog)
+        when (not stp) $ hPutStrLn stderr nfo
+        return $ guard stp >> Just prog
+    mkP _ = return Nothing
+
+
+
+unsupported :: Monad m => p -> m a
+unsupported _ = fail "not supported."
+
+qw :: QuasiQuoter
+qw = QuasiQuoter f unsupported unsupported unsupported
+ where unsupported _ = fail "not supported."
+       f x = return $ ListE $ map (LitE . StringL) $ words x
+
+str :: QuasiQuoter
+str  = QuasiQuoter {
+        quoteExp = stringE,
+        quotePat = unsupported,
+        quoteDec = unsupported,
+        quoteType = unsupported
+       }
+
+glslVertex :: QuasiQuoter
+glslVertex = QuasiQuoter glslE unsupported unsupported unsupported
+ where
+    glslE xs = do
+        let _packUtf8 = VarE $ mkName "packUtf8"
+            _string   = LitE $ StringL xs
+        (code,e) <- runIO $ do
+            (gotvalidator,_,_) <- readCreateProcessWithExitCode (shell "which glslangValidator") ""
+            if gotvalidator == ExitSuccess
+              then do
+                writeFile "/tmp/glsl-shader.vert" xs
+                (code,out,err) <- readCreateProcessWithExitCode (shell "glslangValidator /tmp/glsl-shader.vert") ""
+                return $ (code, out ++ err ++ unlines (zipWith (\n s ->printf "%4d %s" n s ::String) ([1..]::[Int]) (lines xs)))
+              else
+                return (ExitSuccess, "")
+        when (code /= ExitSuccess) $ do
+            fail e
+        return $ AppE _packUtf8 _string
+
+glslFragment :: QuasiQuoter
+glslFragment = QuasiQuoter glslE unsupported unsupported unsupported
+ where
+    glslE xs = do
+        let _packUtf8 = VarE $ mkName "packUtf8"
+            _string   = LitE $ StringL xs
+        (code,e) <- runIO $ do
+            (gotvalidator,_,_) <- readCreateProcessWithExitCode (shell "which glslangValidator") ""
+            if gotvalidator == ExitSuccess
+              then do
+                (pth,h) <-openTempFile "/tmp" "glsl.frag"
+                hPutStr h xs
+                hClose h
+                (code,out,err) <- readCreateProcessWithExitCode (shell $ "glslangValidator "++pth) ""
+                return $ (code, out ++ err ++ unlines (zipWith (\n s ->printf "%4d %s" n s ::String) ([1..]::[Int]) (lines xs)))
+              else
+                return (ExitSuccess, "")
+        when (code /= ExitSuccess) $ do
+            fail e
+        return $ AppE _packUtf8 _string
diff --git a/gix.hs b/gix.hs
new file mode 100644
index 0000000..70d05f5
--- /dev/null
+++ b/gix.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import GI.Gtk as Gtk hiding (main)
+import qualified GI.Gtk as Gtk
+
+import Triangle as R
+
+
+main = do
+    _ <- Gtk.init Nothing
+
+    window <- windowNew WindowTypeToplevel
+    windowSetDefaultSize window 1000 1000
+    windowSetTitle window "GL Area"
+    containerSetBorderWidth window 10
+
+    gl_area <- gLAreaNew
+    containerAdd window gl_area
+
+    st <- R.initState
+
+    _ <- on gl_area #realize   $ R.realize st gl_area
+    _ <- on gl_area #unrealize $ R.unrealize gl_area
+    _ <- on gl_area #render    $ R.render st gl_area
+
+    _ <- on window #deleteEvent $ \_ -> mainQuit >> return True
+    widgetShowAll window
+    Gtk.main
+