{-# LANGUAGE LambdaCase #-}
module LambdaCubeWidget where

import Control.Monad
import Control.Concurrent
import Data.Function
import Data.Int
import GI.Gdk.Objects
import GI.Gtk.Objects (GLArea,widgetGetWindow)
import GLWidget
import LambdaCube.GL as LC
import LambdaCube.IR as LC
import LambdaCube.Gtk
import qualified Data.Aeson as JSON
import qualified Data.ByteString as SB
import System.IO.Error
import Control.Monad.Writer

data LCRealized x = LCRealized GLStorage GLRenderer x

data LCMethods x = LCMethods
    { lcRealized       :: MVar (LCRealized x)
    , lcUploadState    :: GLStorage -> IO x -- implements realize
    , lcDestroyState   :: x -> IO ()
    , lcSetUniforms    :: GLContext -> GLStorage -> x -> IO () -- implements render
    , lcPipeline       :: DynamicPipeline
    }

data DynamicPipeline = DynamicPipeline
    { dynamicPipeline :: Pipeline
    , dynamicSchema   :: PipelineSchema
    }

loadPipeline :: FilePath -> Writer PipelineSchema a -> IO (Either String DynamicPipeline)
loadPipeline fname schema = do
    pipelineDesc <- do
            maybe (Left $ "Unable to parse " ++ fname) Right . JSON.decodeStrict <$> SB.readFile fname
        `catchIOError` \e -> return $ Left (show e)
    return $ do
        p <- pipelineDesc
        Right DynamicPipeline
            { dynamicPipeline = p
            , dynamicSchema   = makeSchema schema
            }

lambdaRender :: (GLArea -> LCMethods x) -> WidgetMethods GLArea -> WidgetMethods GLArea
lambdaRender f m = m
    { glRender    = lcrender . f
    , glUnrealize = lcunrealize . f
    , glRealize   = lcrealize . f
    , glResize    = \glarea -> lcresize glarea (f glarea)
    }

tryWithMVar :: IO b -> MVar a -> (a -> IO b) -> IO b
tryWithMVar failed mvar f = do
    mr <- tryTakeMVar mvar
    maybe failed f mr

lcrender :: LCMethods x -> GLContext -> IO Bool
lcrender lc gl = do
    mr <- tryTakeMVar (lcRealized lc)
    maybe (\_ -> oops "Not realized!") (&) mr $ \realized-> do
        let LCRealized s r0 x = realized
        r <- fixupRenderTarget r0
        lcSetUniforms lc gl s x
        LC.renderFrame r
        putMVar (lcRealized lc) realized
    return True

lcunrealize :: LCMethods x -> IO ()
lcunrealize lc = do
    m <- tryTakeMVar $ lcRealized lc
    forM_ m $ \(LCRealized storage renderer x) -> do
        LC.disposeStorage storage
        LC.disposeRenderer renderer
        lcDestroyState lc x

lcrealize :: LCMethods x -> IO ()
lcrealize lc = do
    lcunrealize lc
    storage <- LC.allocStorage (dynamicSchema $ lcPipeline lc)
    x <- lcUploadState lc storage
    renderer <- LC.allocRenderer (dynamicPipeline $ lcPipeline lc)
    compat <- LC.setStorage renderer storage -- check schema compatibility
    putMVar (lcRealized lc) $ LCRealized storage renderer x

lcresize :: GLArea -> LCMethods x -> Int32 -> Int32 -> IO ()
lcresize glarea lc w h = do
    tryTakeMVar (lcRealized lc) >>= \case
        Nothing -> return ()
        Just r@(LCRealized storage _ _) -> do
            -- Plenty of options here.  I went with the last one.
            -- 1. gLContextGetWindow :: HasCallStack => GLContext -> IO (Maybe Window)
            -- 2. getGLContextWindow ::                 GLContext -> IO (Maybe Window)
            -- 3. widgetGetWindow    :: HasCallStack => GLArea    -> IO (Maybe Window)
            widgetGetWindow glarea >>= mapM_ (\win -> do
                (wd,ht) <- do wd <- windowGetWidth win
                              ht <- windowGetHeight win
                              return (fromIntegral wd,fromIntegral ht)
                LC.setScreenSize storage wd ht)
            putMVar (lcRealized lc) r