flaw-gl/Flaw/Graphics/WebGL.hs

Summary

Maintainability
Test Coverage
{-|
Module: Flaw.Graphics.WebGL
Description: WebGL graphics implementation.
License: MIT
-}

{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}

module Flaw.Graphics.WebGL
  ( WebGLSystem()
  , WebGLDevice
  , WebGLContext
  , WebGLPresenter()
  , webglInit
  ) where

import Control.Exception
import Control.Concurrent.MVar
import Control.Monad
import Data.IORef
import Data.String
import GHCJS.Foreign
import GHCJS.Foreign.Callback

import Flaw.BinaryCache
import Flaw.Exception
import Flaw.Graphics
import Flaw.Graphics.GlContext
import Flaw.Graphics.GLSL
import Flaw.Graphics.WebGL.FFI
import Flaw.Math
import Flaw.Window
import Flaw.Window.Web.Canvas

-- | Graphics system.
data WebGLSystem = WebGLSystem

instance System WebGLSystem where
  data DeviceId WebGLSystem
  data DisplayId WebGLSystem
  data DisplayModeId WebGLSystem
  getInstalledDevices _ = throwIO $ DescribeFirstException "not implemented"
  createDisplayMode _system _displayId _width _height = throwIO $ DescribeFirstException "not implemented"

type WebGLDevice = GlContext
type WebGLContext = GlContext

data WebGLPresenter = WebGLPresenter
  { webglPresenterCanvas :: !Canvas
  , webglPresenterContext :: !JS_WebGLContext
  }

instance Presenter WebGLPresenter WebGLSystem GlContext GlContext where
  setPresenterMode _presenter _maybeDisplayMode = throwIO $ DescribeFirstException "not implemented"

  presenterRender WebGLPresenter
    { webglPresenterCanvas = canvas
    , webglPresenterContext = context
    } GlContext
    { glContextDesiredState = desiredContextState@GlContextState
      { glContextStateFrameBuffer = frameBufferRef
      , glContextStateViewport = viewportRef
      }
    } f = do
    -- create sync var
    syncVar <- newEmptyMVar

    -- create sync callback
    callback <- syncCallback ThrowWouldBlock $ do
      -- clear state
      glSetDefaultContextState desiredContextState

      -- get client size
      (width, height) <- getWindowClientSize canvas
      -- set current context
      js_setContext context
      -- setup state
      writeIORef frameBufferRef GlFrameBufferId
        { glFrameBufferName = glNullFramebufferName
        , glFrameBufferWidth = width
        , glFrameBufferHeight = height
        }
      writeIORef viewportRef $ Vec4 0 0 width height

      -- perform render
      putMVar syncVar =<< f

    -- perform rendering
    js_requestAnimationFrame callback

    -- wait for the end
    r <- takeMVar syncVar

    -- release data associated with callback
    releaseCallback callback

    return r

webglInit :: Canvas -> Bool -> IO ((WebGLSystem, WebGLDevice, WebGLContext, WebGLPresenter), IO ())
webglInit canvas@Canvas
  { canvasElement = jsCanvas
  } needDepth = do
  -- get context
  jsContext@(JS_WebGLContext jsContextVal) <- js_getCanvasContext jsCanvas needDepth
  when (isNull jsContextVal) $ throwIO $ DescribeFirstException "cannot get WebGL context"
  -- create context
  context <- newGlContext id id GlCaps
    { glCapsUniformBufferObject = False
    , glCapsSamplerObjects = False
    , glCapsVertexArrayObject = False
    , glCapsVertexAttribBinding = False
    , glCapsFramebufferObject = True
    , glCapsTextureStorage = False
    , glCapsInstancedArrays = False
    , glCapsClearBuffer = False
    , glCapsDebugOutput = False
    , glCapsGetProgramBinary = False
    } GlslConfig
    { glslConfigVersion = Nothing
    , glslConfigForceFloatAttributes = True
    , glslConfigUnsignedUnsupported = True
    , glslConfigUniformBlocks = False
    , glslConfigInOutSyntax = False
    , glslConfigTextureSampleDimensionSpecifier = True
    } (SomeBinaryCache NullBinaryCache)
  let device = context

  -- set context as current
  js_setContext jsContext

  -- set some defaults
  -- set front face mode
  glFrontFace GL_CW
  -- enable culling
  glEnable GL_CULL_FACE
  glCullFace GL_BACK
  -- enable depth test
  glEnable GL_DEPTH_TEST

  -- enable extensions
  let extensions =
    [ "ANGLE_instanced_arrays"
    , "EXT_color_buffer_half_float"
    , "EXT_frag_depth"
    , "EXT_shader_texture_lod"
    , "EXT_sRGB"
    , "EXT_texture_filter_anisotropic"
    , "OES_element_index_uint"
    , "OES_standard_derivatives"
    , "OES_texture_float"
    , "OES_texture_float_linear"
    , "OES_texture_half_float"
    , "OES_texture_half_float_linear"
    --, "OES_vertex_array_object" -- better to not enable it, as we don't really support it right now in WebGL
    , "WEBGL_color_buffer_float"
    , "WEBGL_compressed_texture_atc"
    , "WEBGL_compressed_texture_pvrtc"
    , "WEBGL_compressed_texture_s3tc"
    , "WEBGL_compressed_texture_s3tc_srgb"
    , "WEBGL_depth_texture"
    , "WEBGL_draw_buffers"
    , "WEBGL_shared_resources"
    ]
  forM_ extensions $ glGetExtension . fromString

  -- create presenter
  let presenter = WebGLPresenter
    { webglPresenterCanvas = canvas
    , webglPresenterContext = jsContext
    }

  -- return
  return ((WebGLSystem, device, context, presenter), return ())