loop/src/Shader/Compile.hs

module Shader.Compile (
    makeShader,
    makeByteStringShaderUsingVAO,
    makeShaderSized,
    makeShaderUsingVAO,
    setupVAO,
    setupVertexAttribPointer,
) where

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 Graphics.Rendering.OpenGL (vertexAttribPointer, AttribLocation (..), ($=)
    , IntegerHandling (..)
    , VertexArrayDescriptor (..)
    , DataType (..)
    , vertexAttribArray
    , Capability (..)
    )
import Shader.Data
import Shader.Parameters

{- |
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'
makeShader s shaderlist sizes pm = do
    prog <- makeSourcedShader s shaderlist
    vaob <- setupVAO sizes
    return $
        FullShader'
            { _shadProg' = prog
            , _shadVAO' = vaob
            , _shadPrim' = pm
            , _shadTex' = Nothing
            , _shadUnis' = mempty
            }

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'
            { _shadProg' = 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'
            { _shadProg' = 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'
makeShaderSized s shaderlist sizes ndraw pm = do
    prog <- makeSourcedShader s shaderlist
    vaob <- setupVAOSized ndraw sizes
    return $
        FullShader'
            { _shadProg' = prog
            , _shadVAO' = vaob
            , _shadPrim' = pm
            , _shadTex' = Nothing
            , _shadUnis' = mempty
            }

{- | 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
setupVAO = setupVAOSized numDrawableElements

setupVAOSized :: Int -> [Int] -> IO VAO
setupVAOSized ndraw sizes = do
    vaoname <- mglCreateSingle glCreateVertexArrays
    glBindVertexArray vaoname
    theVBO <- setupVBOSized ndraw vaoname sizes
    return $
        VAO
            { _vaoName = vaoname
            , _vaoVBO = theVBO
            }

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

-- | Assumes the correct VBO is bound
setupVertexAttribPointer ::
    GLuint ->
    -- | vao name
    GLuint ->
    -- | vbo name
    Int ->
    -- | Size
    Int ->
    -- | Stride
    Int ->
    -- | Offset
    Int ->
    IO ()
setupVertexAttribPointer vao vbo loc siz strd off = do
    vertexAttribPointer (AttribLocation (fi loc))
        $= (ToFloat, VertexArrayDescriptor (fi' siz) Float (fi'' $ floatSize * strd) (bufferOffset off))
    vertexAttribArray (AttribLocation (fi loc)) $= Enabled
  where
    fi = fromIntegral
    fi' = fromIntegral
    fi'' = fromIntegral

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)

bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . (* floatSize) . fromIntegral