prepare to make cache size runtime settable
[ruff:gruff.git] / GLUTGtk.hs
1 module GLUTGtk where
2
3 import Control.Monad (join)
4 import Control.Monad.Trans (liftIO)
5 import Data.IORef (IORef, newIORef, readIORef)
6 import Graphics.UI.Gtk hiding (Size)
7 import Graphics.UI.Gtk.OpenGL
8
9 type RealizeCallback = IO ()
10 type ReshapeCallback = Size -> IO ()
11 type DisplayCallback = IO ()
12 type KeyboardMouseCallback = Key -> KeyState -> [Modifier] -> Position -> IO ()
13
14 data Size = Size Int Int
15   deriving (Eq, Ord, Show)
16
17 data Position = Position Double Double
18   deriving (Eq, Ord, Show)
19
20 data KeyState = Down | Up
21   deriving (Eq, Ord, Show)
22
23 data Key = Char Char | MouseButton MouseButton
24   deriving (Eq, Show)
25
26 data GLUTGtk = GLUTGtk
27   { realizeCallback :: IORef RealizeCallback
28   , reshapeCallback :: IORef ReshapeCallback
29   , displayCallback :: IORef DisplayCallback
30   , keyboardMouseCallback :: IORef KeyboardMouseCallback
31   , postRedisplay :: IO ()
32   , widget :: EventBox
33   }
34
35 glut :: Size -> IO GLUTGtk
36 glut (Size width height) = do
37   realizeCallback' <- newIORef $ return ()
38   displayCallback' <- newIORef $ return ()
39   reshapeCallback' <- newIORef $ \_ -> return ()
40   keyboardMouseCallback' <- newIORef $ \_ _ _ _ -> return ()
41   config <- glConfigNew [ GLModeRGBA, GLModeDouble ]
42   canvas <- glDrawingAreaNew config
43   widgetSetSizeRequest canvas width height
44   eventb <- eventBoxNew
45   set eventb [ containerBorderWidth := 0, containerChild := canvas ]
46   _ <- onRealize canvas $ withGLDrawingArea canvas $ \_ -> join (readIORef realizeCallback')
47   _ <- canvas `on` configureEvent $ tryEvent $ do
48     (w, h) <- eventSize
49     liftIO $ do
50       cb <- readIORef reshapeCallback'
51       cb (Size w h)
52   _ <- canvas `on` exposeEvent $ tryEvent $ liftIO $ withGLDrawingArea canvas $ \gl -> do
53     join (readIORef displayCallback')
54     glDrawableSwapBuffers gl
55   let handleButton s = do
56         b <- eventButton
57         (x, y) <- eventCoordinates
58         ms <- eventModifier
59         liftIO $ do
60           cb <- readIORef keyboardMouseCallback'
61           cb (MouseButton b) s ms (Position x y)
62   _ <- eventb `on` buttonPressEvent   $ tryEvent $ handleButton Down
63   _ <- eventb `on` buttonReleaseEvent $ tryEvent $ handleButton Up
64   return $ GLUTGtk
65     { realizeCallback = realizeCallback'
66     , displayCallback = displayCallback'
67     , reshapeCallback = reshapeCallback'
68     , keyboardMouseCallback = keyboardMouseCallback'
69     , postRedisplay = widgetQueueDraw canvas
70     , widget = eventb
71     }