{-# LANGUAGE Arrows                     #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE ScopedTypeVariables        #-}

{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# OPTIONS_GHC -Wno-unused-foralls #-}
module Graphics.GPipe.Internal.TransformFeedback where

import           Control.Monad.Trans.State               (evalState)
import           Data.IORef                              (readIORef, writeIORef)
import           Data.IntMap.Polymorphic.Lazy            (insert)
import qualified Data.Text.Lazy                          as LT
import           Foreign.C.String                        (newCString)
import           Foreign.Marshal                         (alloca, free,
                                                          withArray)
import           Foreign.Storable                        (Storable (peek))
import           Graphics.GL.Core45
import           Graphics.GL.Types                       (GLuint)
import           Graphics.GPipe.Internal.Buffer          (Buffer (bufName, bufTransformFeedback))
import           Graphics.GPipe.Internal.Compiler        (Drawcall (Drawcall),
                                                          RenderIOState (transformFeedbackToRenderIO))
import           Graphics.GPipe.Internal.Context         (Window (getWinName))
import           Graphics.GPipe.Internal.Expr            (ExprM,
                                                          ExprResult (ExprResult),
                                                          GGenerativeGeometry,
                                                          GlobDeclM, S (..),
                                                          declareGeometryLayout,
                                                          runExprM)
import           Graphics.GPipe.Internal.GeometryStream  (GeometryExplosive (declareGeometry, enumerateVaryings),
                                                          GeometryStream (..),
                                                          GeometryStreamData (..))
import           Graphics.GPipe.Internal.PrimitiveArray  (PrimitiveTopology (toGeometryShaderOutputTopology, toLayoutOut))
import           Graphics.GPipe.Internal.PrimitiveStream (PrimitiveStreamData (PrimitiveStreamData),
                                                          VertexInput (VertexFormat))
import           Graphics.GPipe.Internal.Shader          (Shader (..), ShaderM,
                                                          modifyRenderIO,
                                                          tellDrawcall)

drawNothing :: forall p a s c ds os f. (PrimitiveTopology p, VertexInput a, GeometryExplosive (VertexFormat a))
    => Window os c ds
    -- Output feedback buffers should remain black boxes until synchronized
    -- which won't be necessary when using glDrawTransformFeedback (add a flag
    -- for it?).
    -> (s -> Buffer os a)
    -- maxVertices
    -> Int
    -- We should use a primitive (vertex) stream too, but the way we deal
    -- currently with modular stages is not flexible enough and we stick with
    -- geometry stream.
    -> GeometryStream (GGenerativeGeometry p (VertexFormat a))
    -> Shader os s ()
drawNothing :: Window os c ds
-> (s -> Buffer os a)
-> Int
-> GeometryStream (GGenerativeGeometry p (VertexFormat a))
-> Shader os s ()
drawNothing Window os c ds
w s -> Buffer os a
getTransformFeedbackBuffer Int
maxVertices GeometryStream (GGenerativeGeometry p (VertexFormat a))
gs = ShaderM s () -> Shader os s ()
forall os s a. ShaderM s a -> Shader os s a
Shader (ShaderM s () -> Shader os s ()) -> ShaderM s () -> Shader os s ()
forall a b. (a -> b) -> a -> b
$ Window os c ds
-> GeometryStream (GGenerativeGeometry p (VertexFormat a))
-> (s -> Buffer os a)
-> Int
-> ShaderM s ()
forall p a s c ds os.
(PrimitiveTopology p, VertexInput a,
 GeometryExplosive (VertexFormat a)) =>
Window os c ds
-> GeometryStream (GGenerativeGeometry p (VertexFormat a))
-> (s -> Buffer os a)
-> Int
-> ShaderM s ()
tellDrawcalls Window os c ds
w GeometryStream (GGenerativeGeometry p (VertexFormat a))
gs s -> Buffer os a
getTransformFeedbackBuffer Int
maxVertices

tellDrawcalls :: forall p a s c ds os. (PrimitiveTopology p, VertexInput a, GeometryExplosive (VertexFormat a))
    => Window os c ds
    -> GeometryStream (GGenerativeGeometry p (VertexFormat a))
    -> (s -> Buffer os a)
    -> Int
    -> ShaderM s ()
tellDrawcalls :: Window os c ds
-> GeometryStream (GGenerativeGeometry p (VertexFormat a))
-> (s -> Buffer os a)
-> Int
-> ShaderM s ()
tellDrawcalls Window os c ds
w (GeometryStream [(GGenerativeGeometry p (VertexFormat a), GeometryStreamData)]
xs) s -> Buffer os a
getTransformFeedbackBuffer Int
maxVertices =  ((GGenerativeGeometry p (VertexFormat a), GeometryStreamData)
 -> ShaderM s ())
-> [(GGenerativeGeometry p (VertexFormat a), GeometryStreamData)]
-> ShaderM s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (GGenerativeGeometry p (VertexFormat a), GeometryStreamData)
-> ShaderM s ()
f [(GGenerativeGeometry p (VertexFormat a), GeometryStreamData)]
xs where
    f :: (GGenerativeGeometry p (VertexFormat a), GeometryStreamData)
-> ShaderM s ()
f (GGenerativeGeometry p (VertexFormat a)
x, gsd :: GeometryStreamData
gsd@(GeometryStreamData Int
n LayoutName
layoutName PrimitiveStreamData
_)) = do

        let shaderDeclarations :: GlobDeclM ()
shaderDeclarations = State Int (GlobDeclM ()) -> Int -> GlobDeclM ()
forall s a. State s a -> s -> a
evalState (VertexFormat a -> State Int (GlobDeclM ())
forall a. GeometryExplosive a => a -> State Int (GlobDeclM ())
declareGeometry (VertexFormat a
forall a. HasCallStack => a
undefined :: VertexFormat a)) Int
0
            varyings :: [LayoutName]
varyings = State Int [LayoutName] -> Int -> [LayoutName]
forall s a. State s a -> s -> a
evalState (VertexFormat a -> State Int [LayoutName]
forall a. GeometryExplosive a => a -> State Int [LayoutName]
enumerateVaryings (VertexFormat a
forall a. HasCallStack => a
undefined :: VertexFormat a)) Int
0
            varyingCount :: Int
varyingCount = [LayoutName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LayoutName]
varyings
            bufferMode :: GLenum
bufferMode = GLenum
forall a. (Eq a, Num a) => a
GL_INTERLEAVED_ATTRIBS
            io :: s -> GLenum -> IO ()
io s
s GLenum
pName = do
                [CString]
names <- (LayoutName -> IO CString) -> [LayoutName] -> IO [CString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO CString
newCString (String -> IO CString)
-> (LayoutName -> String) -> LayoutName -> IO CString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutName -> String
LT.unpack) [LayoutName]
varyings
                [CString] -> (Ptr CString -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [CString]
names ((Ptr CString -> IO ()) -> IO ())
-> (Ptr CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CString
a -> do
                    GLenum -> GLsizei -> Ptr CString -> GLenum -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLsizei -> Ptr CString -> GLenum -> m ()
glTransformFeedbackVaryings GLenum
pName (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
varyingCount) Ptr CString
a GLenum
bufferMode
                (CString -> IO ()) -> [CString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CString -> IO ()
forall a. Ptr a -> IO ()
free [CString]
names
            topology :: GLenum
topology = p -> GLenum
forall p. PrimitiveTopology p => p -> GLenum
toGeometryShaderOutputTopology (p
forall a. HasCallStack => a
undefined :: p)

        IO (Drawcall s) -> ShaderM s ()
forall s. IO (Drawcall s) -> ShaderM s ()
tellDrawcall (IO (Drawcall s) -> ShaderM s ())
-> IO (Drawcall s) -> ShaderM s ()
forall a b. (a -> b) -> a -> b
$ Window os c ds
-> (s -> Buffer os a)
-> GLenum
-> GeometryStreamData
-> GlobDeclM ()
-> ExprM ()
-> IO (Drawcall s)
forall a s c ds os.
VertexInput a =>
Window os c ds
-> (s -> Buffer os a)
-> GLenum
-> GeometryStreamData
-> GlobDeclM ()
-> ExprM ()
-> IO (Drawcall s)
makeDrawcall Window os c ds
w s -> Buffer os a
getTransformFeedbackBuffer GLenum
topology GeometryStreamData
gsd GlobDeclM ()
shaderDeclarations (ExprM () -> IO (Drawcall s)) -> ExprM () -> IO (Drawcall s)
forall a b. (a -> b) -> a -> b
$ do
            LayoutName -> LayoutName -> Int -> ExprM ()
declareGeometryLayout LayoutName
layoutName (p -> LayoutName
forall p. PrimitiveTopology p => p -> LayoutName
toLayoutOut (p
forall a. HasCallStack => a
undefined :: p)) Int
maxVertices
            LayoutName
x' <- GGenerativeGeometry p (VertexFormat a) -> ExprM LayoutName
forall x a. S x a -> ExprM LayoutName
unS GGenerativeGeometry p (VertexFormat a)
x
            () -> ExprM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        (RenderIOState s -> RenderIOState s) -> ShaderM s ()
forall s. (RenderIOState s -> RenderIOState s) -> ShaderM s ()
modifyRenderIO (\RenderIOState s
s -> RenderIOState s
s { transformFeedbackToRenderIO :: IntMap Int (s -> GLenum -> IO ())
transformFeedbackToRenderIO = Int
-> (s -> GLenum -> IO ())
-> IntMap Int (s -> GLenum -> IO ())
-> IntMap Int (s -> GLenum -> IO ())
forall k v. Integral k => k -> v -> IntMap k v -> IntMap k v
insert Int
n s -> GLenum -> IO ()
io (RenderIOState s -> IntMap Int (s -> GLenum -> IO ())
forall s. RenderIOState s -> IntMap Int (s -> GLenum -> IO ())
transformFeedbackToRenderIO RenderIOState s
s) } )

makeDrawcall :: forall a s c ds os. (VertexInput a)
    => Window os c ds
    -> (s -> Buffer os a)
    -> GLuint
    -> GeometryStreamData
    -> GlobDeclM ()
    -> ExprM ()
    -> IO (Drawcall s)
makeDrawcall :: Window os c ds
-> (s -> Buffer os a)
-> GLenum
-> GeometryStreamData
-> GlobDeclM ()
-> ExprM ()
-> IO (Drawcall s)
makeDrawcall Window os c ds
w s -> Buffer os a
getTransformFeedbackBuffer GLenum
topology (GeometryStreamData Int
geoN LayoutName
_ (PrimitiveStreamData Int
primN Int
ubuff)) GlobDeclM ()
shaderDeclarations ExprM ()
shader = do
    ExprResult LayoutName
gsource [UniformId]
gunis [SamplerId]
gsamps [Int]
_ GlobDeclM ()
prevShaderDeclarations ExprM ()
prevShader <- GlobDeclM () -> ExprM () -> IO ExprResult
runExprM GlobDeclM ()
shaderDeclarations ExprM ()
shader
    ExprResult LayoutName
vsource [UniformId]
vunis [SamplerId]
vsamps [Int]
vinps GlobDeclM ()
_ ExprM ()
_ <- GlobDeclM () -> ExprM () -> IO ExprResult
runExprM GlobDeclM ()
prevShaderDeclarations ExprM ()
prevShader

    let getTransformFeedbackBufferName :: s -> IO (GLenum, GLenum, GLenum, GLenum)
getTransformFeedbackBufferName = \s
s -> do
            let buffer :: Buffer os a
buffer = s -> Buffer os a
getTransformFeedbackBuffer s
s
            GLenum
bName <- IORef GLenum -> IO GLenum
forall a. IORef a -> IO a
readIORef (Buffer os a -> IORef GLenum
forall os b. Buffer os b -> IORef GLenum
bufName Buffer os a
buffer)
            let tfRef :: IORef (Maybe (GLenum, GLenum))
tfRef = Buffer os a -> IORef (Maybe (GLenum, GLenum))
forall os b. Buffer os b -> IORef (Maybe (GLenum, GLenum))
bufTransformFeedback Buffer os a
buffer
            Maybe (GLenum, GLenum)
tf <- IORef (Maybe (GLenum, GLenum)) -> IO (Maybe (GLenum, GLenum))
forall a. IORef a -> IO a
readIORef IORef (Maybe (GLenum, GLenum))
tfRef
            (GLenum
tfName, GLenum
tfqName) <- case Maybe (GLenum, GLenum)
tf of
                Just (GLenum, GLenum)
names -> (GLenum, GLenum) -> IO (GLenum, GLenum)
forall (m :: * -> *) a. Monad m => a -> m a
return (GLenum, GLenum)
names
                Maybe (GLenum, GLenum)
Nothing -> do
                    GLenum
tfName <- (Ptr GLenum -> IO GLenum) -> IO GLenum
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLenum -> IO GLenum) -> IO GLenum)
-> (Ptr GLenum -> IO GLenum) -> IO GLenum
forall a b. (a -> b) -> a -> b
$ \Ptr GLenum
ptr -> do
                        GLsizei -> Ptr GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLsizei -> Ptr GLenum -> m ()
glGenTransformFeedbacks GLsizei
1 Ptr GLenum
ptr
                        Ptr GLenum -> IO GLenum
forall a. Storable a => Ptr a -> IO a
peek Ptr GLenum
ptr
                    GLenum
tfqName <- (Ptr GLenum -> IO GLenum) -> IO GLenum
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLenum -> IO GLenum) -> IO GLenum)
-> (Ptr GLenum -> IO GLenum) -> IO GLenum
forall a b. (a -> b) -> a -> b
$ \Ptr GLenum
ptr -> do
                        GLsizei -> Ptr GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLsizei -> Ptr GLenum -> m ()
glGenQueries GLsizei
1 Ptr GLenum
ptr
                        Ptr GLenum -> IO GLenum
forall a. Storable a => Ptr a -> IO a
peek Ptr GLenum
ptr
                    IORef (Maybe (GLenum, GLenum)) -> Maybe (GLenum, GLenum) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (GLenum, GLenum))
tfRef ((GLenum, GLenum) -> Maybe (GLenum, GLenum)
forall a. a -> Maybe a
Just (GLenum
tfName, GLenum
tfqName))
                    --liftNonWinContextIO $ (addContextFinalizer tfRef $ with name (glDeleteTransformFeedbacks 1))
                    (GLenum, GLenum) -> IO (GLenum, GLenum)
forall (m :: * -> *) a. Monad m => a -> m a
return (GLenum
tfName, GLenum
tfqName)
            (GLenum, GLenum, GLenum, GLenum)
-> IO (GLenum, GLenum, GLenum, GLenum)
forall (m :: * -> *) a. Monad m => a -> m a
return (GLenum
bName, GLenum
tfName, GLenum
tfqName, GLenum
topology)

    Drawcall s -> IO (Drawcall s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Drawcall s -> IO (Drawcall s)) -> Drawcall s -> IO (Drawcall s)
forall a b. (a -> b) -> a -> b
$ (s -> (Either WinId (IO FBOKeys, IO ()), IO ()))
-> Maybe (s -> IO (GLenum, GLenum, GLenum, GLenum))
-> Int
-> Maybe Int
-> LayoutName
-> Maybe LayoutName
-> Maybe LayoutName
-> [Int]
-> [UniformId]
-> [SamplerId]
-> [UniformId]
-> [SamplerId]
-> [UniformId]
-> [SamplerId]
-> Int
-> Drawcall s
forall s.
(s -> (Either WinId (IO FBOKeys, IO ()), IO ()))
-> Maybe (s -> IO (GLenum, GLenum, GLenum, GLenum))
-> Int
-> Maybe Int
-> LayoutName
-> Maybe LayoutName
-> Maybe LayoutName
-> [Int]
-> [UniformId]
-> [SamplerId]
-> [UniformId]
-> [SamplerId]
-> [UniformId]
-> [SamplerId]
-> Int
-> Drawcall s
Drawcall
        ((Either WinId (IO FBOKeys, IO ()), IO ())
-> s -> (Either WinId (IO FBOKeys, IO ()), IO ())
forall a b. a -> b -> a
const (WinId -> Either WinId (IO FBOKeys, IO ())
forall a b. a -> Either a b
Left (Window os c ds -> WinId
forall os c ds. Window os c ds -> WinId
getWinName Window os c ds
w), () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
        ((s -> IO (GLenum, GLenum, GLenum, GLenum))
-> Maybe (s -> IO (GLenum, GLenum, GLenum, GLenum))
forall a. a -> Maybe a
Just s -> IO (GLenum, GLenum, GLenum, GLenum)
getTransformFeedbackBufferName)
        Int
primN
        (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
geoN)
        LayoutName
vsource (LayoutName -> Maybe LayoutName
forall a. a -> Maybe a
Just LayoutName
gsource) Maybe LayoutName
forall a. Maybe a
Nothing
        [Int]
vinps
        [UniformId]
vunis [SamplerId]
vsamps
        [UniformId]
gunis [SamplerId]
gsamps
        [] []
        Int
ubuff