{-# 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