loop/src/Shader/Compile.hs

module Shader.Compile (
    setupVBO,
    setupVBOStatic,
    makeShaderEBO,
    makeShaderVBO,
    makeShaderUsingVBO,
    makeByteStringShaderUsingVAO,
    makeStaticShader,
    makeShaderUsingVAO,
    setupVAOUsingVBO,
    setupVAOvbo,
    setupEBO,
    setupVertexAttribPointer,
    makeSourcedShader,
    toFloatVAs,
    setupStaticVBOVAO
) where

import Foreign.C.Types
import Graphics.GL.Types
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
    [VertexAttribute] ->
    PrimitiveMode ->
    IO (Shader, VBO)
makeShaderVBO s shaderlist sizes pm = do
    prog <- makeSourcedShader s shaderlist
    (vao, vbo) <- setupVBOVAO 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
    [VertexAttribute] ->
    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
    [VertexAttribute] ->
    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 <- mallocBytes (vertexsize * numDrawableElements)
    -- Allocate space
    glNamedBufferData
        vboname
        (fromIntegral $ numDrawableElements * vertexsize)
        nullPtr
        GL_STREAM_DRAW
    return VBO{_vboName = vboname, _vboPtr = thePtr, _vboVertexBytes = vertexsize}

-- the input ptr is assumed to contain the correct amount of data according to
-- the specified number and type of vertices
-- note the VBO here does not have a sensible ptr value
setupStaticVBOVAO :: Storable a => [VertexAttribute] -> [a] -> IO (VBO,VAO)
setupStaticVBOVAO vas vdata = withArrayLen vdata $ \i ptr -> do
    vboname <- mglCreate glCreateBuffers
    glNamedBufferStorage
        vboname
        (CPtrdiff (fromIntegral (i * sizeOf (head vdata))))
        ptr
        0
    let vbo = VBO 
            { _vboName = vboname 
            , _vboPtr = nullPtr
            , _vboVertexBytes = vasTightStride vas
            }
    vao <- setupVAOUsingVBO vas vbo
    return (vbo,vao)
    
    

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, _vboVertexBytes = floatSize * 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
            }

-- this should be changed to some FIXED STORAGE SHADER
-- I cannot think of any other reason to have it
{- |
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.
-}
makeStaticShader ::
    Storable a =>
    -- | First part of the name of the shader
    String ->
    -- | shader types
    [GLenum] ->
    [VertexAttribute] ->
    [a] ->
    PrimitiveMode ->
    IO Shader
makeStaticShader s shaderlist vas vdata pm = do
    prog <- makeSourcedShader s shaderlist
    (_, vao) <- setupStaticVBOVAO vas vdata
    return
        ( Shader
            { _shaderUINT = prog
            , _shaderVAO = vao
            , _shaderPrimitive = pm
            }
        )

{- | 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

setupVAOvbo :: [VertexAttribute] -> Int -> GLuint -> IO VAO
setupVAOvbo sizes strd vbo = do
    vaoname <- mglCreate glCreateVertexArrays
    glBindVertexArray vaoname
    setupVertexAttribs vbo vaoname sizes (fromIntegral strd * fromIntegral floatSize)
    return $
        VAO
            { _vaoName = vaoname
            }

setupVAOUsingVBO :: [VertexAttribute] -> VBO -> IO VAO
setupVAOUsingVBO vas vbo = do
    let strd = vbo ^. vboVertexBytes
    vaoname <- mglCreate glCreateVertexArrays
    glBindVertexArray vaoname
    setupVertexAttribs (vbo ^. vboName) vaoname vas 
        (fromIntegral strd)
    return VAO{_vaoName = vaoname}

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

setupVBOVAO :: [VertexAttribute] -> IO (VAO, VBO)
setupVBOVAO vas = do
    vaoname <- mglCreate glCreateVertexArrays
    glBindVertexArray vaoname
    vbo <- setupVBO strd
    --vao <- setupVAOvbo (toFloatVAs sizes) (sum sizes) (vbo ^. vboName)
    vao <- setupVAOUsingVBO vas vbo
    return (vao,vbo)
  where
    strd = vasTightStride vas

toFloatVAs :: [Int] -> [VertexAttribute]
toFloatVAs = go 0
  where
    go _ [] = []
    go x (i:is) = VertexAttribute (fromIntegral i) GL_FLOAT GL_FALSE x 
        : go (x + fromIntegral floatSize*fromIntegral i) is

setupVertexAttribs :: GLuint -> GLuint -> [VertexAttribute] -> GLsizei -> IO ()
setupVertexAttribs vbo vao vas strd = do
    glVertexArrayVertexBuffer vao 0 vbo 0 strd
    zipWithM_ (setupVertexAttribPointer vao) [0..] vas

-- | Assumes the correct VBO is bound
setupVertexAttribPointer ::
    GLuint ->
    -- | Location (in shader)
    Int ->
    VertexAttribute ->
    IO ()
setupVertexAttribPointer vao loc va = do
    glEnableVertexArrayAttrib vao loc'
    glVertexArrayAttribFormat vao loc' 
        (va ^. vaCount)
        (va ^. vaType)
        (va ^. vaNormalize)
        (va ^. vaOffset)
    glVertexArrayAttribBinding vao loc' 0
  where
    loc' = fromIntegral loc

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

vasTightStride :: [VertexAttribute] -> Int
vasTightStride = go 0
  where
    go x [] = x
    go x (v:vs)
        | x /= fromIntegral (v ^. vaOffset) = error "vasTightStride: vertex offset incorrect"
        | otherwise = go (x + fromIntegral (v ^. vaCount * fromIntegral (attribSize (v ^. vaType))))
            vs

attribSize :: GLenum -> Int
attribSize x = case x of
    GL_BYTE                               -> sizeOf (0 ::  GLbyte                         )
    GL_SHORT                              -> sizeOf (0 ::  GLshort)
    GL_INT                                -> sizeOf (0 ::  GLint)
    GL_FIXED                              -> sizeOf (0 ::  GLfixed)
    GL_FLOAT                              -> sizeOf (0 ::  GLfloat)
    GL_HALF_FLOAT                         -> sizeOf (0 ::  GLhalf)
    GL_DOUBLE                             -> sizeOf (0 ::  GLdouble)
    GL_UNSIGNED_BYTE                      -> sizeOf (0 ::  GLubyte)
    GL_UNSIGNED_SHORT                     -> sizeOf (0 ::  GLushort)
    GL_UNSIGNED_INT                       -> sizeOf (0 ::  GLuint)
--    GL_INT_2_10_10_10_REV                 -> sizeOf (0 ::  GL_INT_2_10_10_10_REV)
--    GL_UNSIGNED_INT_2_10_10_10_REV        -> sizeOf (0 ::  GL_UNSIGNED_INT_2_10_10_10_REV)
--    GL_UNSIGNED_INT_10F_11F_11F_REV       -> sizeOf (0 ::  GL_UNSIGNED_INT_10F_11F_11F_REV)
    _ -> error "attribSize : unkown GLenum attribute size"

-- 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)