1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
{-# 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
forM_ m $ \(LCRealized storage renderer x) -> do
LC.disposeStorage storage
LC.disposeRenderer renderer
lcDestroyState lc x
lcrealize :: LCMethods x -> IO ()
lcrealize lc = do
lcunrealize 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
|
