loop/src/Shader/Compile.hs

module Shader.Compile (
    setupVBO,
    setupVBOStatic,
    makeShaderEBO,
    makeShaderVBO,
    makeShaderUsingVBO,
    makeByteStringShaderUsingVAO,
    makeShaderSized,
    makeShaderUsingVAO,
    setupVAO,
    setupVAOUsingVBO,
    setupVAOvbo',
    setupEBO,
    setupVertexAttribPointer,
    makeSourcedShader,
) where

import Control.Lens
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BU
import Foreign
import Foreign.C.String
import GLHelp
import Graphics.GL.Core45
import Shader.Data
import Shader.Parameters

--import Graphics.GL.Core45

{- |
Compiles a full shader found within the shader directory.
The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
-}
makeShaderVBO ::
    -- | First part of the name of the shader
    String ->
    -- | shader types
    [GLenum] ->
    -- | The input vertex sizes
    [Int] ->
    PrimitiveMode ->
    IO (Shader, VBO)
makeShaderVBO s shaderlist sizes pm = do
    prog <- makeSourcedShader s shaderlist
    (vao, vbo) <- setupVAO sizes
    return
        ( Shader
            { _shaderUINT = prog
            , _shaderVAO = vao
            , _shaderPrimitive = pm
            }
        , vbo
        )

makeShaderEBO ::
    -- | First part of the name of the shader
    String ->
    -- | shader types
    [GLenum] ->
    -- | The input vertex sizes
    [Int] ->
    PrimitiveMode ->
    VBO ->
    IO (Shader, EBO)
makeShaderEBO s shaderlist sizes pm vbo = do
    shad <- makeShaderUsingVBO s shaderlist sizes pm vbo
    ebo <- setupEBO (shad ^. shaderVAO)
    glVertexArrayElementBuffer (shad ^. shaderVAO . vaoName) (ebo ^. eboName)
    return
        ( shad
        , ebo
        )

makeShaderUsingVBO ::
    -- | First part of the name of the shader
    String ->
    -- | shader types
    [GLenum] ->
    -- | The input vertex sizes
    [Int] ->
    PrimitiveMode ->
    VBO ->
    IO Shader
makeShaderUsingVBO s shaderlist sizes pm vbo = do
    vao <- setupVAOUsingVBO sizes vbo
    makeShaderUsingVAO s shaderlist pm vao

setupVBO :: Int -> IO VBO
setupVBO vertexsize = do
    vboname <- mglCreate glCreateBuffers
    thePtr <- mallocArray (vertexsize * numDrawableElements)
    -- Allocate space
    glNamedBufferData
        vboname
        (fromIntegral $ floatSize * numDrawableElements * vertexsize)
        nullPtr
        GL_STREAM_DRAW
    return VBO{_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize}

setupVBOStatic :: Int -> IO VBO
setupVBOStatic vertexsize = do
    vboname <- mglCreate glCreateBuffers
    thePtr <- mallocArray (vertexsize * numDrawableElements)
    -- Allocate space
    glNamedBufferData
        vboname
        (fromIntegral $ floatSize * numDrawableElements * vertexsize)
        nullPtr
        GL_STATIC_DRAW
    return VBO{_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize}

makeByteStringShaderUsingVAO ::
    -- | (Arbitrary) name of the shader
    String ->
    -- | Filetype extensions and shader data
    [(GLenum, BS.ByteString)] ->
    PrimitiveMode ->
    VAO ->
    IO Shader
makeByteStringShaderUsingVAO s shaderlist pm vao = do
    prog <- makeShaderProgram s shaderlist
    return
        Shader
            { _shaderUINT = prog
            , _shaderVAO = vao
            , _shaderPrimitive = pm
            }

-- | Takes the VAO from elsewhere
makeShaderUsingVAO ::
    -- | First part of the name of the shader
    String ->
    -- | shader types
    [GLenum] ->
    PrimitiveMode ->
    VAO ->
    IO Shader
makeShaderUsingVAO s shaderlist pm theVAO = do
    prog <- makeSourcedShader s shaderlist
    return
        Shader
            { _shaderUINT = prog
            , _shaderVAO = theVAO
            , _shaderPrimitive = pm
            }

{- |
Compiles a full shader found within the shader directory.
The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
-}
makeShaderSized ::
    -- | First part of the name of the shader
    String ->
    -- | shader types
    [GLenum] ->
    -- | The input vertex sizes
    [Int] ->
    -- | Number of vertexes that can be poked
    Int ->
    PrimitiveMode ->
    IO (Shader, VBO)
makeShaderSized s shaderlist sizes ndraw pm = do
    prog <- makeSourcedShader s shaderlist
    (vao, vbo) <- setupVAOSized ndraw sizes
    return
        ( Shader
            { _shaderUINT = prog
            , _shaderVAO = vao
            , _shaderPrimitive = pm
            }
        , vbo
        )

{- | Compile shader and get its uniform locations.
 supposes the shader code is in the shader folder, with the string names
 followed by .vert/.geom/.frag.
-}
makeSourcedShader :: String -> [GLenum] -> IO GLuint
makeSourcedShader s sts = do
    sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt st)
    makeShaderProgram s $ zip sts sources

shaderTypeExt :: GLenum -> String
shaderTypeExt GL_VERTEX_SHADER = ".vert"
shaderTypeExt GL_GEOMETRY_SHADER = ".geom"
shaderTypeExt GL_FRAGMENT_SHADER = ".frag"
shaderTypeExt GL_COMPUTE_SHADER = ".comp"
shaderTypeExt _ = undefined

-- I think that this requires that the correct shader program is bound?
setupVAO :: [Int] -> IO (VAO, VBO)
setupVAO = setupVAOSized numDrawableElements

setupVAOvbo' :: [Int] -> Int -> GLuint -> IO VAO
setupVAOvbo' sizes strd vbo = do
    vaoname <- mglCreate glCreateVertexArrays
    glBindVertexArray vaoname
    setupVertexAttribs' vbo vaoname sizes strd
    return $
        VAO
            { _vaoName = vaoname
            }

setupVAOUsingVBO :: [Int] -> VBO -> IO VAO
setupVAOUsingVBO sizes vbo = do
    let strd = vbo ^. vboVertexSize
    when (strd < sum sizes) $
        error "Tried to assign vertex attributes to VBO with too small a stride."
    vaoname <- mglCreate glCreateVertexArrays
    glBindVertexArray vaoname
    setupVertexAttribs vbo vaoname sizes strd
    return VAO{_vaoName = vaoname}

setupEBO :: VAO -> IO EBO
setupEBO vao = do
    eboptr <- mallocArray numDrawableElements
    eboname <- mglCreate glCreateBuffers
    glNamedBufferData
        eboname
        (fromIntegral $ glushortSize * numDrawableElements)
        nullPtr
        GL_STREAM_DRAW
    glVertexArrayElementBuffer (vao ^. vaoName) eboname
    return $ EBO eboname eboptr

setupVAOSized :: Int -> [Int] -> IO (VAO, VBO)
setupVAOSized ndraw sizes = do
    vaoname <- mglCreate glCreateVertexArrays
    glBindVertexArray vaoname
    theVBO <- setupVBOSized ndraw vaoname sizes
    return
        ( VAO
            { _vaoName = vaoname
            }
        , theVBO
        )

setupVBOSized :: Int -> GLuint -> [Int] -> IO VBO
setupVBOSized ndraw vao sizes = do
    --vboName <- genObjectName
    --bindBuffer ArrayBuffer $= Just vboName
    vboname <- mglCreate glCreateBuffers
    glVertexArrayVertexBuffer vao 0 vboname 0 (fromIntegral $ floatSize * strd)
    forM_ (zip3 [0 ..] sizes offs) $ \(loc, siz, off) -> do
        setupVertexAttribPointer vao loc siz off
    thePtr <- mallocArray (strd * ndraw)
    -- Allocate space
    glNamedBufferData
        vboname
        (fromIntegral $ floatSize * ndraw * strd)
        nullPtr
        GL_STREAM_DRAW
    return $
        VBO
            { _vboName = vboname
            , _vboPtr = thePtr
            , _vboVertexSize = sum sizes
            }
  where
    strd = sum sizes
    offs = scanl (+) 0 sizes

setupVertexAttribs :: VBO -> GLuint -> [Int] -> Int -> IO ()
setupVertexAttribs vbo vao sizes strd = do
    glVertexArrayVertexBuffer vao 0 (_vboName vbo) 0 (fromIntegral $ floatSize * strd)
    forM_ (zip3 [0 ..] sizes offs) $ \(loc, siz, off) -> do
        setupVertexAttribPointer vao loc siz off
  where
    offs = scanl (+) 0 sizes

setupVertexAttribs' :: GLuint -> GLuint -> [Int] -> Int -> IO ()
setupVertexAttribs' vbo vao sizes strd = do
    glVertexArrayVertexBuffer vao 0 vbo 0 (fromIntegral $ floatSize * strd)
    forM_ (zip3 [0 ..] sizes offs) $ \(loc, siz, off) -> do
        setupVertexAttribPointer vao loc siz off
  where
    offs = scanl (+) 0 sizes

-- | Assumes the correct VBO is bound
setupVertexAttribPointer ::
    GLuint ->
    -- | vao name
    Int ->
    -- | Size
    Int ->
    -- | Offset
    Int ->
    IO ()
setupVertexAttribPointer vao loc siz off = do
    glEnableVertexArrayAttrib vao loc'
    glVertexArrayAttribFormat vao loc' siz' GL_FLOAT GL_FALSE (fromIntegral $ floatSize * off)
    glVertexArrayAttribBinding vao loc' 0
  where
    loc' = fromIntegral loc
    siz' = fromIntegral siz

makeShaderProgram ::
    String ->
    [(GLenum, BS.ByteString)] -> -- list of shaders
    IO GLuint
makeShaderProgram str srcs = do
    theprog <- glCreateProgram
    shaders <- mapM (compileAndCheckShader str) srcs
    mapM_ (glAttachShader theprog) shaders
    glLinkProgram theprog
    checkErrorGL (str ++ " linking ") glGetProgramiv glGetProgramInfoLog theprog GL_LINK_STATUS
    mapM_ (glDetachShader theprog) shaders
    mapM_ glDeleteShader shaders
    return theprog

checkErrorGL ::
    (Storable t1) =>
    [Char] ->
    (t2 -> GLenum -> Ptr t1 -> IO ()) ->
    (t2 -> t1 -> Ptr a3 -> CString -> IO ()) ->
    t2 ->
    GLenum ->
    IO ()
checkErrorGL str f g x statustype =
    alloca $ \statusPtr -> do
        f x statustype statusPtr
        status <- peek $ castPtr statusPtr
        when (status == GL_FALSE) $
            alloca $ \ptr -> do
                f x GL_INFO_LOG_LENGTH ptr
                len <- peek ptr -- we may have to use this length more intelligently
                alloca $ \charPtr -> do
                    g x len nullPtr charPtr
                    char <- peekCString charPtr
                    error $ str ++ show char

-- use glCreateShaderProgramv here
compileAndCheckShader :: String -> (GLenum, BS.ByteString) -> IO GLuint
compileAndCheckShader str (theShaderType, sourceCode) = do
    theShader <- glCreateShader theShaderType
    setShaderSource theShader sourceCode
    glCompileShader theShader
    checkErrorGL
        (str ++ shaderTypeExt theShaderType)
        glGetShaderiv
        glGetShaderInfoLog
        theShader
        GL_COMPILE_STATUS
    return theShader

setShaderSource :: GLuint -> BS.ByteString -> IO ()
setShaderSource si src =
    withByteString src $ \srcPtr srcLength ->
        with srcPtr $ \srcPtrBuf ->
            with srcLength $ \srcLengthBuf ->
                glShaderSource si 1 srcPtrBuf srcLengthBuf

-- https://hackage.haskell.org/package/OpenGL-3.0.3.0/docs/src/Graphics.Rendering.OpenGL.GL.ByteString.html#withByteStringP
withByteString :: Num t => BS.ByteString -> (Ptr b -> t -> IO a) -> IO a
withByteString bs act =
    BU.unsafeUseAsCStringLen bs $ \(ptr, size) ->
        act (castPtr ptr) (fromIntegral size)