Refactored spinning-logo demo.

1 files changed, 98 insertions, 0 deletions

diff --git a/LambdaCubeWidget.hs b/LambdaCubeWidget.hs
new file mode 100644
index 0000000..17bb361
--- /dev/null
+++ b/LambdaCubeWidget.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE LambdaCase #-}
+module LambdaCubeWidget where
+
+import Control.Monad
+import Control.Concurrent
+import Data.Function
+import Data.Int
+import GI.Gdk.Objects
+import GI.Gtk.Objects (GLArea,widgetGetWindow)
+import GLWidget
+import LambdaCube.GL as LC
+import LambdaCube.IR as LC
+import LambdaCube.Gtk
+import qualified Data.Aeson as JSON
+import qualified Data.ByteString as SB
+import System.IO.Error
+import Control.Monad.Writer
+
+data LCRealized x = LCRealized GLStorage GLRenderer x
+
+data LCMethods x = LCMethods
+    { lcRealized       :: MVar (LCRealized x)
+    , lcUploadState    :: GLStorage -> IO x -- implements realize
+    , lcDestroyState   :: x -> IO ()
+    , lcSetUniforms    :: GLContext -> GLStorage -> x -> IO () -- implements render
+    , lcPipeline       :: DynamicPipeline
+    }
+
+data DynamicPipeline = DynamicPipeline
+    { dynamicPipeline :: Pipeline
+    , dynamicSchema   :: PipelineSchema
+    }
+
+loadPipeline :: FilePath -> Writer PipelineSchema a -> IO (Either String DynamicPipeline)
+loadPipeline fname schema = do
+    pipelineDesc <- do
+            maybe (Left $ "Unable to parse " ++ fname) Right . JSON.decodeStrict <$> SB.readFile fname
+        `catchIOError` \e -> return $ Left (show e)
+    return $ do
+        p <- pipelineDesc
+        Right DynamicPipeline
+            { dynamicPipeline = p
+            , dynamicSchema   = makeSchema schema
+            }
+
+lambdaRender :: (GLArea -> LCMethods x) -> WidgetMethods GLArea -> WidgetMethods GLArea
+lambdaRender f m = m
+    { glRender    = lcrender . f
+    , glUnrealize = lcunrealize . f
+    , glRealize   = lcrealize . f
+    , glResize    = \glarea -> lcresize glarea (f glarea)
+    }
+
+tryWithMVar :: IO b -> MVar a -> (a -> IO b) -> IO b
+tryWithMVar failed mvar f = do
+    mr <- tryTakeMVar mvar
+    maybe failed f mr
+
+lcrender :: LCMethods x -> GLContext -> IO Bool
+lcrender lc gl = do
+    mr <- tryTakeMVar (lcRealized lc)
+    maybe (\_ -> oops "Not realized!") (&) mr $ \realized-> do
+        let LCRealized s r0 x = realized
+        r <- fixupRenderTarget r0
+        lcSetUniforms lc gl s x
+        LC.renderFrame r
+        putMVar (lcRealized lc) realized
+    return True
+
+lcunrealize :: LCMethods x -> IO ()
+lcunrealize lc = do
+    m <- tryTakeMVar $ lcRealized lc
+    mapM_ (\(LCRealized _ _ x) -> lcDestroyState lc x) m
+
+lcrealize :: LCMethods x -> IO ()
+lcrealize lc = do
+    _ <- tryTakeMVar (lcRealized lc)
+    storage <- LC.allocStorage (dynamicSchema $ lcPipeline lc)
+    x <- lcUploadState lc storage
+    renderer <- LC.allocRenderer (dynamicPipeline $ lcPipeline lc)
+    compat <- LC.setStorage renderer storage -- check schema compatibility
+    putMVar (lcRealized lc) $ LCRealized storage renderer x
+
+lcresize :: GLArea -> LCMethods x -> Int32 -> Int32 -> IO ()
+lcresize glarea lc w h = do
+    tryTakeMVar (lcRealized lc) >>= \case
+        Nothing -> return ()
+        Just r@(LCRealized storage _ _) -> do
+            -- Plenty of options here.  I went with the last one.
+            -- 1. gLContextGetWindow :: HasCallStack => GLContext -> IO (Maybe Window)
+            -- 2. getGLContextWindow ::                 GLContext -> IO (Maybe Window)
+            -- 3. widgetGetWindow    :: HasCallStack => GLArea    -> IO (Maybe Window)
+            widgetGetWindow glarea >>= mapM_ (\win -> do
+                (wd,ht) <- do wd <- windowGetWidth win
+                              ht <- windowGetHeight win
+                              return (fromIntegral wd,fromIntegral ht)
+                LC.setScreenSize storage wd ht)
+            putMVar (lcRealized lc) r