gruff-0.2: src/GLUTGtk.hs

module GLUTGtk where

import Control.Monad (join)
import Control.Monad.Trans (liftIO)
import Data.IORef (IORef, newIORef, readIORef)
import Graphics.UI.Gtk hiding (Size)
import Graphics.UI.Gtk.OpenGL

type RealizeCallback = IO ()
type ReshapeCallback = Size -> IO ()
type DisplayCallback = IO ()
type KeyboardMouseCallback = Key -> KeyState -> [Modifier] -> Position -> IO ()

data Size = Size Int Int
  deriving (Eq, Ord, Show)

data Position = Position Double Double
  deriving (Eq, Ord, Show)

data KeyState = Down | Up
  deriving (Eq, Ord, Show)

data Key = Char Char | MouseButton MouseButton
  deriving (Eq, Show)

data GLUTGtk = GLUTGtk
  { realizeCallback :: IORef RealizeCallback
  , reshapeCallback :: IORef ReshapeCallback
  , displayCallback :: IORef DisplayCallback
  , keyboardMouseCallback :: IORef KeyboardMouseCallback
  , postRedisplay :: IO ()
  , widget :: EventBox
  }

glut :: Size -> IO GLUTGtk
glut (Size width height) = do
  realizeCallback' <- newIORef $ return ()
  displayCallback' <- newIORef $ return ()
  reshapeCallback' <- newIORef $ \_ -> return ()
  keyboardMouseCallback' <- newIORef $ \_ _ _ _ -> return ()
  config <- glConfigNew [ GLModeRGBA, GLModeDouble ]
  canvas <- glDrawingAreaNew config
  widgetSetSizeRequest canvas width height
  eventb <- eventBoxNew
  set eventb [ containerBorderWidth := 0, containerChild := canvas ]
  _ <- onRealize canvas $ withGLDrawingArea canvas $ \_ -> join (readIORef realizeCallback')
  _ <- canvas `on` configureEvent $ tryEvent $ do
    (w, h) <- eventSize
    liftIO $ do
      cb <- readIORef reshapeCallback'
      cb (Size w h)
  _ <- canvas `on` exposeEvent $ tryEvent $ liftIO $ withGLDrawingArea canvas $ \gl -> do
    join (readIORef displayCallback')
    glDrawableSwapBuffers gl
  let handleButton s = do
        b <- eventButton
        (x, y) <- eventCoordinates
        ms <- eventModifier
        liftIO $ do
          cb <- readIORef keyboardMouseCallback'
          cb (MouseButton b) s ms (Position x y)
  _ <- eventb `on` buttonPressEvent   $ tryEvent $ handleButton Down
  _ <- eventb `on` buttonReleaseEvent $ tryEvent $ handleButton Up
  return $ GLUTGtk
    { realizeCallback = realizeCallback'
    , displayCallback = displayCallback'
    , reshapeCallback = reshapeCallback'
    , keyboardMouseCallback = keyboardMouseCallback'
    , postRedisplay = widgetQueueDraw canvas
    , widget = eventb
    }