Example using GLArea without gtk-declarative.

1 files changed, 138 insertions, 0 deletions

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