content: {-|
  Module      : Main
  Copyright   : (c) 2018 Francisco Vallarino
  License     : BSD-3-Clause (see the LICENSE file)
  Maintainer  : fjvallarino@gmail.com
  Stability   : experimental
  Portability : non-portable
  
  Widget implementing low level rendering for the 'Custom OpenGL' example.
  
  OpenGL code adapted from dmjio's [example](https://github.com/dmjio/LearnOpenGL.hs/blob/master/GettingStarted/ShadersEx2/Main.hs).
  -}
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE FlexibleContexts #-}
  
  module OpenGLWidget (
    openGLWidget
  ) where
  
  import Control.Lens ((&), (^.), (.~))
  import Control.Monad
  import Data.Default
  import Data.Typeable (cast)
  import Data.Vector.Storable (Vector)
  import Foreign.C.String
  import Foreign.Marshal.Alloc
  import Foreign.Ptr
  import Foreign.Storable
  import Graphics.GL
  
  import qualified Data.Vector.Storable as V
  
  import Monomer
  import Monomer.Widgets.Single
  
  import qualified Monomer.Lens as L
  
  data OpenGLWidgetMsg
    = OpenGLWidgetInit GLuint (Ptr GLuint) (Ptr GLuint)
    deriving (Show, Eq)
  
  data OpenGLWidgetState = OpenGLWidgetState {
    _ogsLoaded :: Bool,
    _ogsShaderId :: GLuint,
    _ogsVao :: Ptr GLuint,
    _ogsVbo :: Ptr GLuint
  } deriving (Show, Eq)
  
  openGLWidget :: Color -> WidgetNode s e
  openGLWidget color = defaultWidgetNode "openGLWidget" widget where
    widget = makeOpenGLWidget color state
    state = OpenGLWidgetState False 0 nullPtr nullPtr
  
  makeOpenGLWidget :: Color -> OpenGLWidgetState -> Widget s e
  makeOpenGLWidget color state = widget where
    widget = createSingle state def {
      singleInit = init,
      singleMerge = merge,
      singleDispose = dispose,
      singleHandleMessage = handleMessage,
      singleGetSizeReq = getSizeReq,
      singleRender = render
    }
  
    init wenv node = resultReqs node reqs where
      widgetId = node ^. L.info . L.widgetId
      path = node ^. L.info . L.path
      buffers = 2
  
      initOpenGL = do
        -- This needs to run in render thread
        program <- createShaderProgram
        vaoPtr <- malloc
        vboPtr <- malloc
        glGenVertexArrays buffers vaoPtr
        glGenBuffers buffers vboPtr
  
        return $ OpenGLWidgetInit program vaoPtr vboPtr
  
      reqs = [RunInRenderThread widgetId path initOpenGL]
  
    merge wenv node oldNode oldState = resultNode newNode where
      newNode = node
        & L.widget .~ makeOpenGLWidget color oldState
  
    dispose wenv node = resultReqs node reqs where
      OpenGLWidgetState _ shaderId vaoPtr vboPtr = state
      widgetId = node ^. L.info . L.widgetId
      path = node ^. L.info . L.path
      buffers = 2
  
      disposeOpenGL = do
        -- This needs to run in render thread
        glDeleteProgram shaderId
        glDeleteVertexArrays buffers vaoPtr
        glDeleteBuffers buffers vboPtr
        free vaoPtr
        free vboPtr
  
      reqs = [RunInRenderThread widgetId path disposeOpenGL]
  
    handleMessage wenv node target msg = case cast msg of
      Just (OpenGLWidgetInit shaderId vao vbo) -> Just result where
        newState = OpenGLWidgetState True shaderId vao vbo
        newNode = node
          & L.widget .~ makeOpenGLWidget color newState
        result = resultReqs newNode [RenderOnce]
      _ -> Nothing
  
    getSizeReq wenv node = (sizeReqW, sizeReqH) where
      sizeReqW = expandSize 100 1
      sizeReqH = expandSize 100 1
  
    render wenv node renderer =
      when (_ogsLoaded state) $
        createRawTask renderer $
          doInScissor winSize dpr offset activeVp $
            drawVertices state (toVectorVAO winSize offset color triangle)
      where
        dpr = wenv ^. L.dpr
        winSize = wenv ^. L.windowSize
        activeVp = wenv ^. L.viewport
        offset = wenv ^. L.offset
  
        -- Simple triangle
        style = currentStyle wenv node
        nodeVp = getContentArea node style
  
        Rect rx ry rw rh = nodeVp
        triangle = [(rx + rw, ry + rh), (rx, ry + rh), (rx + rw / 2, ry)]
  
  doInScissor :: Size -> Double -> Point -> Rect -> IO () -> IO ()
  doInScissor winSize dpr offset vp action = do
    glEnable GL_SCISSOR_TEST
    -- OpenGL's Y axis increases from bottom to top
    glScissor (round (rx + ox)) (round $ winH - ry - oy - rh) (round rw) (round rh)
    action
    glDisable GL_SCISSOR_TEST
    where
      winH = winSize ^. L.h * dpr
      Point ox oy = mulPoint dpr offset
      Rect rx ry rw rh = mulRect dpr vp
  
  toVectorVAO :: Size -> Point -> Color -> [(Double, Double)] -> Vector Float
  toVectorVAO (Size w h) (Point ox oy) (Color r g b a) points = vec where
    px x = realToFrac $ (x + ox - w / 2) / (w / 2)
    -- OpenGL's Y axis increases from bottom to top
    py y = realToFrac $ (h / 2 - y - oy) / (h / 2)
    col c = realToFrac (fromIntegral c / 255)
    row (x, y) = [px x, py y, 0, col r, col g, col b]
    vec = V.fromList . concat $ row <$> points
  
  drawVertices
    :: forall a . Storable a
    => OpenGLWidgetState
    -> Vector a
    -> IO ()
  drawVertices state vertices = do
    vao <- peek vaoPtr
    vbo <- peek vboPtr
  
    glBindVertexArray vao
    glBindBuffer GL_ARRAY_BUFFER vbo
  
    -- Copies raw data from vector to OpenGL memory
    V.unsafeWith vertices $ \vertsPtr ->
      glBufferData
        GL_ARRAY_BUFFER
        (fromIntegral (V.length vertices * floatSize))
        (castPtr vertsPtr)
        GL_STATIC_DRAW
  
    -- The vertex shader expects two arguments. Position:
    glVertexAttribPointer 0 3 GL_FLOAT GL_FALSE (fromIntegral (floatSize * 6)) nullPtr
    glEnableVertexAttribArray 0
  
    -- Color:
    glVertexAttribPointer 1 3 GL_FLOAT GL_FALSE (fromIntegral (floatSize * 6)) (nullPtr `plusPtr` (floatSize * 3))
    glEnableVertexAttribArray 1
  
    glUseProgram shaderId
    glBindVertexArray vao
    glDrawArrays GL_TRIANGLES 0 3
  
    where
      floatSize = sizeOf (undefined :: Float)
      OpenGLWidgetState _ shaderId vaoPtr vboPtr = state
  
  createShaderProgram :: IO GLuint
  createShaderProgram = do
    shaderProgram <- glCreateProgram
    vertexShader <- compileShader GL_VERTEX_SHADER "examples/opengl/shaders/vert.glsl"
    fragmentShader <- compileShader GL_FRAGMENT_SHADER "examples/opengl/shaders/frag.glsl"
  
    glAttachShader shaderProgram vertexShader
    glAttachShader shaderProgram fragmentShader
  
    glLinkProgram shaderProgram
    checkProgramLink shaderProgram
  
    glDeleteShader vertexShader
    glDeleteShader fragmentShader
  
    return shaderProgram
  
  compileShader :: GLenum -> FilePath -> IO GLuint
  compileShader shaderType shaderFile = do
    shader <- glCreateShader shaderType
    shaderSource <- readFile shaderFile >>= newCString
  
    alloca $ \shadersStr -> do
      shadersStr `poke` shaderSource
      glShaderSource shader 1 shadersStr nullPtr
      glCompileShader shader
      checkShaderCompile shader
  
    return shader
  
  checkProgramLink :: GLuint -> IO ()
  checkProgramLink programId = do
    alloca $ \successPtr -> do
      alloca $ \infoLogPtr -> do
        glGetProgramiv programId GL_LINK_STATUS successPtr
        success <- peek successPtr
  
        when (success <= 0) $ do
          glGetProgramInfoLog programId 512 nullPtr infoLogPtr
          putStrLn =<< peekCString infoLogPtr
  
  checkShaderCompile :: GLuint -> IO ()
  checkShaderCompile shaderId = do
    alloca $ \successPtr ->
      alloca $ \infoLogPtr -> do
        glGetShaderiv shaderId GL_COMPILE_STATUS successPtr
        success <- peek successPtr
  
        when (success <= 0) $ do
          glGetShaderInfoLog shaderId 512 nullPtr infoLogPtr
          putStrLn "Failed to compile shader "
  