module Graphics.Luminance.Core.Shader.Stage where
import Control.Applicative ( liftA2 )
import Control.Monad ( unless )
import Control.Monad.Except ( MonadError(throwError) )
import Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad.Trans.Resource ( MonadResource, register )
import Graphics.GL
import Graphics.Luminance.Core.Debug
import Graphics.Luminance.Core.Query ( getGLExtensions )
import Foreign.C.String ( peekCString, withCString )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( allocaArray )
import Foreign.Marshal.Utils ( with )
import Foreign.Ptr ( castPtr, nullPtr )
import Foreign.Storable ( peek )
newtype Stage = Stage { stageID :: GLuint }
data StageType
= TessControlShader
| TessEvaluationShader
| VertexShader
| GeometryShader
| FragmentShader
deriving (Eq,Show)
createTessCtrlShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage
createTessCtrlShader = mkShader GL_TESS_CONTROL_SHADER
createStage :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m)
=> StageType
-> String
-> m Stage
createStage t src = case t of
TessControlShader -> checkTessSupport t >> mkShader GL_TESS_CONTROL_SHADER src
TessEvaluationShader -> checkTessSupport t >> mkShader GL_TESS_EVALUATION_SHADER src
VertexShader -> mkShader GL_VERTEX_SHADER src
GeometryShader -> mkShader GL_GEOMETRY_SHADER src
FragmentShader -> mkShader GL_FRAGMENT_SHADER src
where
checkTessSupport stage = do
exts <- getGLExtensions
unless ("GL_ARB_tessellation_shader" `elem` exts) $
throwError $ fromStageError (UnsupportedStage stage)
mkShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m)
=> GLenum
-> String
-> m Stage
mkShader target src = do
(sid,compiled,cl) <- liftIO $ do
sid <- debugGL $ glCreateShader target
withCString (prependGLSLPragma src) $ \cstr -> do
with cstr $ \pcstr -> debugGL $ glShaderSource sid 1 pcstr nullPtr
debugGL $ glCompileShader sid
compiled <- isCompiled sid
ll <- clogLength sid
cl <- clog ll sid
pure (sid,compiled,cl)
unless compiled $ do
liftIO (glDeleteShader sid)
throwError . fromStageError $ CompilationFailed cl
_ <- register $ glDeleteShader sid
pure $ Stage sid
isCompiled :: GLuint -> IO Bool
isCompiled sid = do
ok <- debugGL . alloca $ liftA2 (*>) (glGetShaderiv sid GL_COMPILE_STATUS) peek
pure $ ok == GL_TRUE
clogLength :: GLuint -> IO Int
clogLength sid =
fmap fromIntegral . debugGL . alloca $
liftA2 (*>) (glGetShaderiv sid GL_INFO_LOG_LENGTH) peek
clog :: Int -> GLuint -> IO String
clog l sid =
debugGL . allocaArray l $
liftA2 (*>) (glGetShaderInfoLog sid (fromIntegral l) nullPtr)
(peekCString . castPtr)
prependGLSLPragma :: String -> String
prependGLSLPragma src =
#if defined(__GL45)
"#version 450 core\n"
#elif defined(__GL32)
"#version 150 core\n"
#endif
#if defined(__GL_BINDLESS_TEXTURES)
++ "#extension GL_ARB_bindless_texture : require\n"
++ "layout (bindless_sampler) uniform;"
#endif
++ src
data StageError
= CompilationFailed String
| UnsupportedStage StageType
deriving (Eq,Show)
class HasStageError a where
fromStageError :: StageError -> a