{-# LANGUAGE
    ScopedTypeVariables,
    TypeFamilies,
    FlexibleInstances
  #-}

{-| Facility for drawing OpenGL graphics into the QML scenegraph.

To use this facility, you must place a @HaskellCanvas@ item into your
QML scene. This item can be imported from the @HsQML.Canvas 1.0@ module using
an @import@ statement in your QML script. It has several properties which can
be set from QML:

[@displayMode@] Specifies how the canvas is rendered with respect to the
rest of the scene. Possible values are:

    [@HaskellCanvas.Above@] The canvas shares a buffer with the scenegraph
    and is painted top of other items.
    [@HaskellCanvas.Inline@] The canvas has its own framebuffer object and the
    contents of this buffer are painted inline with other items (default).
    [@HaskellCanvas.Below@] The canvas shares a buffer with the scenegraph
    and is painted underneath other items.

[@canvasWidth@] Width of the framebuffer object in pixels. Defaults to the
item width.
[@canvasHeight@] Height of the framebuffer object in pixels. Defaults to the
item height.
[@delegate@] A marshalled 'OpenGLDelegate' value which specifies the Haskell
functions used to render the canvas.
[@model@] A value passed to delegate's paint function. The canvas is
repainted whenever this value changes.
[@status@] Either @HaskellCanvas.Okay@ or an error code (read only).

The @HsQML.Canvas 1.0@ module also contains another type of item called
@OpenGLConextControl@ which can be used to configure the OpenGL context used by
your windows. When placed inside a QML window, it has several properties which
when read return the current state of that window's OpenGL context, and when
written to cause the window's context to be reconfigured with a request for the
supplied setting. Note that as reconfiguring the context may cause a visible
window to dis- and re-appear, it's recommended to supply the desired settings
at startup or otherwise before the corresponding window is made visible.
Available properties are as below:

[@majorVersion@] Major component of the OpenGL version.
[@minorVersion@] Minor component of the OpenGL version.
[@contextType@] The type of OpenGL context. One of:
@OpenGLContextControl.UnknownType@, @OpenGLContextControl.OpenGL@, or
@OpenGLContextControl.OpenGLES@.
[@contextProfile@] The OpenGL context's profile. One of:
@OpenGLContextControl.NoProfile@, @OpenGLContextControl.CoreProfile@, or
@OpenGLContextControl.CompatibilityProfile@.
[@deprecatedFunctions@] True if deprecated functions are available.
[@depthBufferSize@] Depth buffer size in bits.
[@stencilBufferSize@] Stencil buffer size in bits.
[@when@] Any changes to the OpenGL context while this property is set to false
will be deferred until it is true again. The default value is true.
-}
module Graphics.QML.Canvas (
    OpenGLDelegate,
    newOpenGLDelegate,
    OpenGLType (
        OpenGLDesktop,
        OpenGLES),
    OpenGLSetup,
    openGLType,
    openGLMajor,
    openGLMinor,
    OpenGLPaint,
    OpenGLPaint',
    setupData,
    modelData,
    matrixPtr,
    itemWidth,
    itemHeight
) where

import Graphics.QML.Internal.BindCanvas
import Graphics.QML.Internal.BindPrim
import Graphics.QML.Internal.Marshal
import Graphics.QML.Internal.Types
import Graphics.QML.Marshal

import Data.IORef
import Data.Maybe
import Data.Tagged
import Control.Monad.Trans.Maybe
import Foreign.Ptr (Ptr)
import Foreign.C.Types (CFloat)

-- | Delegate for painting OpenGL graphics.
newtype OpenGLDelegate = OpenGLDelegate HsQMLGLDelegateHandle

instance Marshal OpenGLDelegate where
    type MarshalMode OpenGLDelegate c d = ModeBidi c
    marshaller :: MarshallerFor OpenGLDelegate
marshaller = Marshaller {
        mTypeCVal_ :: MTypeCValFunc OpenGLDelegate
mTypeCVal_ = TypeId -> MTypeCValFunc OpenGLDelegate
forall {k} (s :: k) b. b -> Tagged s b
Tagged TypeId
tyJSValue,
        mFromCVal_ :: MFromCValFunc OpenGLDelegate
mFromCVal_ = MFromCValFunc OpenGLDelegate
forall t. Marshal t => MFromCValFunc t
jvalFromCVal,
        mToCVal_ :: MToCValFunc OpenGLDelegate
mToCVal_ = MToCValFunc OpenGLDelegate
forall t. Marshal t => MToCValFunc t
jvalToCVal,
        mWithCVal_ :: MWithCValFunc OpenGLDelegate
mWithCVal_ = OpenGLDelegate -> (Ptr () -> IO b) -> IO b
forall t. Marshal t => MWithCValFunc t
MWithCValFunc OpenGLDelegate
jvalWithCVal,
        mFromJVal_ :: MFromJValFunc OpenGLDelegate
mFromJVal_ = \Strength
_ HsQMLJValHandle
ptr -> IO (Maybe OpenGLDelegate) -> MaybeT IO OpenGLDelegate
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe OpenGLDelegate) -> MaybeT IO OpenGLDelegate)
-> IO (Maybe OpenGLDelegate) -> MaybeT IO OpenGLDelegate
forall a b. (a -> b) -> a -> b
$ do
            HsQMLGLDelegateHandle
hndl <- IO HsQMLGLDelegateHandle
hsqmlCreateGldelegate
            Strength
-> (HsQMLJValHandle -> IO Bool)
-> (HsQMLJValHandle -> IO OpenGLDelegate)
-> HsQMLJValHandle
-> IO (Maybe OpenGLDelegate)
forall a.
Strength
-> (HsQMLJValHandle -> IO Bool)
-> (HsQMLJValHandle -> IO a)
-> HsQMLJValHandle
-> IO (Maybe a)
fromJVal Strength
Weak (HsQMLGLDelegateHandle -> HsQMLJValHandle -> IO Bool
hsqmlGldelegateFromJval HsQMLGLDelegateHandle
hndl)
                (IO OpenGLDelegate -> HsQMLJValHandle -> IO OpenGLDelegate
forall a b. a -> b -> a
const (IO OpenGLDelegate -> HsQMLJValHandle -> IO OpenGLDelegate)
-> (OpenGLDelegate -> IO OpenGLDelegate)
-> OpenGLDelegate
-> HsQMLJValHandle
-> IO OpenGLDelegate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpenGLDelegate -> IO OpenGLDelegate
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OpenGLDelegate -> HsQMLJValHandle -> IO OpenGLDelegate)
-> OpenGLDelegate -> HsQMLJValHandle -> IO OpenGLDelegate
forall a b. (a -> b) -> a -> b
$ HsQMLGLDelegateHandle -> OpenGLDelegate
OpenGLDelegate HsQMLGLDelegateHandle
hndl) HsQMLJValHandle
ptr,
        mWithJVal_ :: MWithJValFunc OpenGLDelegate
mWithJVal_ = \(OpenGLDelegate HsQMLGLDelegateHandle
hndl) HsQMLJValHandle -> IO b
f ->
            (HsQMLJValHandle -> HsQMLGLDelegateHandle -> IO ())
-> HsQMLGLDelegateHandle -> (HsQMLJValHandle -> IO b) -> IO b
forall a b.
(HsQMLJValHandle -> a -> IO ())
-> a -> (HsQMLJValHandle -> IO b) -> IO b
withJVal ((HsQMLGLDelegateHandle -> HsQMLJValHandle -> IO ())
-> HsQMLJValHandle -> HsQMLGLDelegateHandle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip HsQMLGLDelegateHandle -> HsQMLJValHandle -> IO ()
hsqmlGldelegateToJval) HsQMLGLDelegateHandle
hndl HsQMLJValHandle -> IO b
f,
        mFromHndl_ :: MFromHndlFunc OpenGLDelegate
mFromHndl_ = MFromHndlFunc OpenGLDelegate
forall t. MFromHndlFunc t
unimplFromHndl,
        mToHndl_ :: MToHndlFunc OpenGLDelegate
mToHndl_ = MToHndlFunc OpenGLDelegate
forall t. MToHndlFunc t
unimplToHndl}

-- | Represents the type of an OpenGL context.
data OpenGLType
    -- | Desktop OpenGL context.
    = OpenGLDesktop
    -- | OpenGL ES context.
    | OpenGLES
    deriving (OpenGLType -> OpenGLType -> Bool
(OpenGLType -> OpenGLType -> Bool)
-> (OpenGLType -> OpenGLType -> Bool) -> Eq OpenGLType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpenGLType -> OpenGLType -> Bool
== :: OpenGLType -> OpenGLType -> Bool
$c/= :: OpenGLType -> OpenGLType -> Bool
/= :: OpenGLType -> OpenGLType -> Bool
Eq, Int -> OpenGLType -> ShowS
[OpenGLType] -> ShowS
OpenGLType -> String
(Int -> OpenGLType -> ShowS)
-> (OpenGLType -> String)
-> ([OpenGLType] -> ShowS)
-> Show OpenGLType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpenGLType -> ShowS
showsPrec :: Int -> OpenGLType -> ShowS
$cshow :: OpenGLType -> String
show :: OpenGLType -> String
$cshowList :: [OpenGLType] -> ShowS
showList :: [OpenGLType] -> ShowS
Show)

mapGLType :: HsQMLGLCanvasType -> OpenGLType
mapGLType :: HsQMLGLCanvasType -> OpenGLType
mapGLType HsQMLGLCanvasType
HsqmlGlDesktop = OpenGLType
OpenGLDesktop
mapGLType HsQMLGLCanvasType
HsqmlGlEs      = OpenGLType
OpenGLES

-- | Encapsulates parameters for OpenGL setup.
data OpenGLSetup = OpenGLSetup {
    -- | Type of OpenGL context.
    OpenGLSetup -> OpenGLType
openGLType :: OpenGLType,
    -- | Major version number of OpenGL context.
    OpenGLSetup -> Int
openGLMajor :: Int,
    -- | Minor version number of OpenGL context.
    OpenGLSetup -> Int
openGLMinor :: Int
}

-- | Encapsulates parameters for OpenGL paint.
data OpenGLPaint s m = OpenGLPaint {
    -- | Gets the setup state.
    forall s m. OpenGLPaint s m -> s
setupData  :: s,
    -- | Gets the active model.
    forall s m. OpenGLPaint s m -> m
modelData :: m,
    -- | Pointer to a 4 by 4 matrix which transform coordinates in the range
    -- (-1, -1) to (1, 1) on to the target rectangle in the scene.
    forall s m. OpenGLPaint s m -> Ptr CFloat
matrixPtr :: Ptr CFloat,
    -- | Width of the canvas item in its local coordinate system.
    forall s m. OpenGLPaint s m -> Float
itemWidth :: Float,
    -- | Height of the canvas item in its local coordinate system.
    forall s m. OpenGLPaint s m -> Float
itemHeight :: Float
}

-- | Specialised version of `OpenGLPaint` with no model.
type OpenGLPaint' s = OpenGLPaint s Ignored

newOpenGLCallbacks :: (Marshal m, CanGetFrom m ~ Yes) =>
    (OpenGLSetup -> IO i) -> (OpenGLPaint i m -> IO ()) -> (i -> IO ()) ->
    CallbacksFactory
newOpenGLCallbacks :: forall m i.
(Marshal m, CanGetFrom m ~ Yes) =>
(OpenGLSetup -> IO i)
-> (OpenGLPaint i m -> IO ()) -> (i -> IO ()) -> CallbacksFactory
newOpenGLCallbacks OpenGLSetup -> IO i
setupFn OpenGLPaint i m -> IO ()
paintFn i -> IO ()
cleanupFn = do
    IORef (Maybe i)
iRef <- Maybe i -> IO (IORef (Maybe i))
forall a. a -> IO (IORef a)
newIORef Maybe i
forall a. Maybe a
Nothing
    IORef (Maybe m)
mRef <- Maybe m -> IO (IORef (Maybe m))
forall a. a -> IO (IORef a)
newIORef Maybe m
forall a. Maybe a
Nothing
    let setupCb :: CInt -> CInt -> CInt -> IO ()
setupCb CInt
ctype CInt
major CInt
minor = do
            i
iVal <- OpenGLSetup -> IO i
setupFn (OpenGLSetup -> IO i) -> OpenGLSetup -> IO i
forall a b. (a -> b) -> a -> b
$ OpenGLType -> Int -> Int -> OpenGLSetup
OpenGLSetup
                (HsQMLGLCanvasType -> OpenGLType
mapGLType (HsQMLGLCanvasType -> OpenGLType)
-> HsQMLGLCanvasType -> OpenGLType
forall a b. (a -> b) -> a -> b
$ CInt -> HsQMLGLCanvasType
forall a. Enum a => CInt -> a
cIntToEnum CInt
ctype)
                (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
major) (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
minor)
            IORef (Maybe i) -> Maybe i -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe i)
iRef (Maybe i -> IO ()) -> Maybe i -> IO ()
forall a b. (a -> b) -> a -> b
$ i -> Maybe i
forall a. a -> Maybe a
Just i
iVal
        cleanupCb :: IO ()
cleanupCb = do
            Maybe i
iVal <- IORef (Maybe i) -> IO (Maybe i)
forall a. IORef a -> IO a
readIORef IORef (Maybe i)
iRef
            i -> IO ()
cleanupFn (i -> IO ()) -> i -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe i -> i
forall a. HasCallStack => Maybe a -> a
fromJust Maybe i
iVal
        syncCb :: HsQMLJValHandle -> IO CInt
syncCb HsQMLJValHandle
ptr = do
             Maybe m
mVal <- MaybeT IO m -> IO (Maybe m)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO m -> IO (Maybe m)) -> MaybeT IO m -> IO (Maybe m)
forall a b. (a -> b) -> a -> b
$ MFromJValFunc m
forall t. Marshal t => MFromJValFunc t
mFromJVal Strength
Strong HsQMLJValHandle
ptr
             IORef (Maybe m) -> Maybe m -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe m)
mRef Maybe m
mVal
             CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> IO CInt) -> CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ if Maybe m -> Bool
forall a. Maybe a -> Bool
isJust Maybe m
mVal then CInt
1 else CInt
0
        paintCb :: Ptr CFloat -> CFloat -> CFloat -> IO ()
paintCb Ptr CFloat
mPtr CFloat
w CFloat
h = do
            Maybe i
iVal <- IORef (Maybe i) -> IO (Maybe i)
forall a. IORef a -> IO a
readIORef IORef (Maybe i)
iRef
            Maybe m
mVal <- IORef (Maybe m) -> IO (Maybe m)
forall a. IORef a -> IO a
readIORef IORef (Maybe m)
mRef
            OpenGLPaint i m -> IO ()
paintFn (OpenGLPaint i m -> IO ()) -> OpenGLPaint i m -> IO ()
forall a b. (a -> b) -> a -> b
$ i -> m -> Ptr CFloat -> Float -> Float -> OpenGLPaint i m
forall s m.
s -> m -> Ptr CFloat -> Float -> Float -> OpenGLPaint s m
OpenGLPaint
                (Maybe i -> i
forall a. HasCallStack => Maybe a -> a
fromJust Maybe i
iVal) (Maybe m -> m
forall a. HasCallStack => Maybe a -> a
fromJust Maybe m
mVal)
                Ptr CFloat
mPtr (CFloat -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac CFloat
w) (CFloat -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac CFloat
h)
    (CInt -> CInt -> CInt -> IO (), IO (), HsQMLJValHandle -> IO CInt,
 Ptr CFloat -> CFloat -> CFloat -> IO ())
-> CallbacksFactory
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> CInt -> CInt -> IO ()
setupCb, IO ()
cleanupCb, HsQMLJValHandle -> IO CInt
syncCb, Ptr CFloat -> CFloat -> CFloat -> IO ()
paintCb)

-- | Creates a new 'OpenGLDelegate' from setup, paint, and cleanup functions.
newOpenGLDelegate :: (Marshal m, CanGetFrom m ~ Yes) =>
    (OpenGLSetup -> IO i) -> (OpenGLPaint i m -> IO ()) -> (i -> IO ()) ->
    IO OpenGLDelegate
newOpenGLDelegate :: forall m i.
(Marshal m, CanGetFrom m ~ Yes) =>
(OpenGLSetup -> IO i)
-> (OpenGLPaint i m -> IO ()) -> (i -> IO ()) -> IO OpenGLDelegate
newOpenGLDelegate OpenGLSetup -> IO i
setupFn OpenGLPaint i m -> IO ()
paintFn i -> IO ()
cleanupFn = do
    HsQMLGLDelegateHandle
hndl <- IO HsQMLGLDelegateHandle
hsqmlCreateGldelegate
    HsQMLGLDelegateHandle -> CallbacksFactory -> IO ()
hsqmlGldelegateSetup HsQMLGLDelegateHandle
hndl ((OpenGLSetup -> IO i)
-> (OpenGLPaint i m -> IO ()) -> (i -> IO ()) -> CallbacksFactory
forall m i.
(Marshal m, CanGetFrom m ~ Yes) =>
(OpenGLSetup -> IO i)
-> (OpenGLPaint i m -> IO ()) -> (i -> IO ()) -> CallbacksFactory
newOpenGLCallbacks OpenGLSetup -> IO i
setupFn OpenGLPaint i m -> IO ()
paintFn i -> IO ()
cleanupFn)
    OpenGLDelegate -> IO OpenGLDelegate
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OpenGLDelegate -> IO OpenGLDelegate)
-> OpenGLDelegate -> IO OpenGLDelegate
forall a b. (a -> b) -> a -> b
$ HsQMLGLDelegateHandle -> OpenGLDelegate
OpenGLDelegate HsQMLGLDelegateHandle
hndl