Refactored spinning-logo demo.

1 files changed, 100 insertions, 0 deletions

diff --git a/GLWidget.hs b/GLWidget.hs
new file mode 100644
index 0000000..8a9d23e
--- /dev/null
+++ b/GLWidget.hs
@@ -0,0 +1,100 @@
+{-# 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 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
+    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
+    e <- gLAreaGetError glarea
+    maybe action oopsG e
+
+nullableContext :: IO (Maybe GLContext) -> IO GLContext
+nullableContext mk = mk >>= maybe mknull return
+  where
+    mknull = do
+        oops "createContext: GLArea has no window."
+        fp <- newForeignPtr_ nullPtr
+        disown <- newIORef Nothing
+        return $ GLContext $ ManagedPtr fp disown
+
+oopsG :: GError -> IO ()
+oopsG e = do
+    msg <- gerrorMessage e
+    oops (Text.unpack msg)
+
+oops :: String -> IO ()
+oops s = hPutStrLn stderr s
+
+runGLApp mk methods = do
+    _ <- Gtk.init Nothing
+
+    let mkChild = newGLWidget mk methods
+
+    window <- do
+        w <- windowNew WindowTypeToplevel
+        windowSetDefaultSize    w 760 760
+        windowSetTitle          w (glTitle methods)
+        containerSetBorderWidth w 0
+        _ <- on w #deleteEvent $ \_ -> mainQuit >> return True
+        child <- mkChild
+        containerAdd w child
+        return w
+
+    widgetShowAll window
+    Gtk.main