loop/src/Shader/Compile.hs

module Shader.Compile (
    setupVBO,
    makeShader,
    makeShader4,
    makeByteStringShaderUsingVAO,
    makeShaderSized,
    makeShaderUsingVAO,
    setupVAO,
    setupVertexAttribPointer,
) 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.
-}
makeShader ::
    -- | First part of the name of the shader
    String ->
    -- | shader types
    [GLenum] ->
    -- | The input vertex sizes
    [Int] ->
    EPrimitiveMode ->
    IO (FullShader,VBO)
makeShader s shaderlist sizes pm = do
    prog <- makeSourcedShader s shaderlist
    (vao,vbo) <- setupVAO sizes
    return ( FullShader
            { _shadName = prog
            , _shadVAO = vao
            , _shadPrim' = pm
            , _shadTex' = Nothing
            , _shadUnis' = mempty
            }
            , vbo)

makeShader4 ::
    -- | First part of the name of the shader
    String ->
    -- | shader types
    [GLenum] ->
    -- | The input vertex sizes
    [Int] ->
    -- | The stride
    Int ->
    EPrimitiveMode ->
    VBO ->
    IO FullShader
makeShader4 s shaderlist sizes strd pm vbo = do
    prog <- makeSourcedShader s shaderlist
    vao <- setupVAOvbo sizes strd vbo
    return $ FullShader
            { _shadName = prog
            , _shadVAO = vao
            , _shadPrim' = pm
            , _shadTex' = Nothing
            , _shadUnis' = mempty
            }

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}

makeByteStringShaderUsingVAO ::
    -- | (Arbitrary) name of the shader
    String ->
    -- | Filetype extensions and shader data
    [(GLenum, BS.ByteString)] ->
    EPrimitiveMode ->
    VAO ->
    IO FullShader
makeByteStringShaderUsingVAO s shaderlist pm vao = do
    prog <- makeShaderProgram s shaderlist
    return $
        FullShader
            { _shadName = prog
            , _shadVAO = vao
            , _shadPrim' = pm
            , _shadTex' = Nothing
            , _shadUnis' = mempty
            }

-- | Takes the VAO from elsewhere
makeShaderUsingVAO ::
    -- | First part of the name of the shader
    String ->
    -- | shader types
    [GLenum] ->
    EPrimitiveMode ->
    VAO ->
    IO FullShader
makeShaderUsingVAO s shaderlist pm theVAO = do
    prog <- makeSourcedShader s shaderlist
    return $
        FullShader
            { _shadName = prog
            , _shadVAO = theVAO
            , _shadPrim' = pm
            , _shadTex' = Nothing
            , _shadUnis' = mempty
            }

{- |
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 ->
    EPrimitiveMode ->
    IO (FullShader,VBO)
makeShaderSized s shaderlist sizes ndraw pm = do
    prog <- makeSourcedShader s shaderlist
    (vao,vbo) <- setupVAOSized ndraw sizes
    return ( FullShader
            { _shadName = prog
            , _shadVAO = vao
            , _shadPrim' = pm
            , _shadTex' = Nothing
            , _shadUnis' = mempty
            }
        , 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' _ = undefined

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

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

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 (vbo ^. vboName) 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

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)