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
102
103
104
105
106
107
108
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
module GLWidget where
import Control.Concurrent
import Data.Functor.Contravariant
import Data.Int
import Data.IORef
import qualified Data.Text as Text
;import Data.Text (Text)
import Foreign.ForeignPtr
import Foreign.Ptr
import GI.Gdk.Objects (GLContext(..),windowCreateGlContext)
import qualified GI.Gtk as Gtk
;import GI.Gtk as Gtk hiding (main)
import Data.GI.Base.ManagedPtr (newManagedPtr)
import System.IO
data WidgetMethods st = WidgetMethods
{ glUnrealize :: st -> IO ()
, glRealize :: st -> IO ()
, glResize :: st -> Int32 -> Int32 -> IO ()
, glRender :: st -> GLContext -> IO Bool
, glCreateContext :: st -> IO (Maybe GLContext)
, glTitle :: Text
}
instance Contravariant WidgetMethods where
contramap f w = w
{ glUnrealize = glUnrealize w . f
, glRealize = glRealize w . f
, glResize = glResize w . f
, glRender = glRender w . f
, glCreateContext = glCreateContext w . f
}
glmethods :: WidgetMethods GLArea
glmethods = WidgetMethods
{ glUnrealize = \_ -> return ()
, glRealize = \_ -> return ()
, glRender = \_ gl -> return True
, glResize = \_ w h -> return ()
, glCreateContext =
\st -> widgetGetWindow (st::GLArea)
>>= maybe (return Nothing)
(fmap Just . windowCreateGlContext)
, glTitle = "GL Area"
}
newGLWidget :: (GLArea -> IO st) -> WidgetMethods st -> IO st
newGLWidget mk w = do
g <- gLAreaNew
gLAreaSetHasDepthBuffer g True
st <- mk g
_ <- on g #render $ glRender w st
_ <- on g #resize $ glResize w st
_ <- on g #realize $ withCurrentGL g (glRealize w st)
_ <- on g #unrealize $ glUnrealize w st
_ <- on g #createContext $ nullableContext (glCreateContext w st)
return st
withCurrentGL :: GLArea -> IO () -> IO ()
withCurrentGL glarea action = do
gLAreaMakeCurrent glarea
gLAreaGetError glarea >>= maybe action oopsG
-- -- The following causes realize and resize to each be triggered
-- -- twice before the first render signal.
-- gLAreaAttachBuffers glarea
-- gLAreaGetError glarea >>= maybe action oopsG
nullableContext :: IO (Maybe GLContext) -> IO GLContext
nullableContext mk = mk >>= maybe mknull return
where
mknull = do
oops "createContext: GLArea has no window."
mptr <- newManagedPtr nullPtr (return ())
return $ GLContext mptr
oopsG :: GError -> IO ()
oopsG e = do
msg <- gerrorMessage e
oops (Text.unpack msg)
oops :: String -> IO ()
oops s = hPutStrLn stderr s
runGLApp :: IsWidget b => (GLArea -> IO b) -- ^ Initialize a state object that will be passed
-- to all the event handlers.
-> WidgetMethods b
-> IO ()
runGLApp mk methods = do
_ <- Gtk.init Nothing
let mkChild = newGLWidget mk methods
window <- do
w <- windowNew WindowTypeToplevel
windowSetDefaultSize w 720 720
windowSetTitle w (glTitle methods)
containerSetBorderWidth w 0
_ <- on w #deleteEvent $ \_ -> mainQuit >> return True
child <- mkChild
containerAdd w child
return w
widgetShowAll window
Gtk.main
|
