module Graphics.Caramia.Shader
(
newShader
, newShaderB
, newShaderBL
, newPipeline
, newPipelineVF
, Shader()
, Pipeline()
, AttributeBindings
, setUniform
, getUniformLocation
, Uniformable()
, UniformLocation
, ShaderStage(..)
, viewStage
, nopPipeline
, ShaderCompilationError(..)
, ShaderLinkingError(..)
, ShaderBuildingError(..)
)
where
import Control.Lens ( ifor_ )
import Control.Monad.Catch
import Control.Monad.IO.Class
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Lazy as BL
import Data.Data ( Data )
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Foreign as T
import Foreign
import Foreign.C.Types
import GHC.Float ( double2Float )
import GHC.Generics ( Generic )
import Graphics.Caramia.Color
import Graphics.Caramia.Context
import Graphics.Caramia.Internal.OpenGLCApi
import Graphics.Caramia.Resource
import Graphics.Caramia.Prelude
import Graphics.Caramia.Shader.Internal
import Linear.Matrix
import Linear.Quaternion
import Linear.V1
import Linear.V2
import Linear.V3
import Linear.V4
type UniformLocation = Int
toConstant :: ShaderStage -> GLenum
toConstant Vertex = GL_VERTEX_SHADER
toConstant Fragment = GL_FRAGMENT_SHADER
toConstant Geometry = GL_GEOMETRY_SHADER
data ShaderBuildingError = forall e. Exception e => ShaderBuildingError e
deriving ( Typeable )
instance Show ShaderBuildingError where
show (ShaderBuildingError e) = show e
data ShaderCompilationError = ShaderCompilationError !T.Text
deriving ( Eq, Typeable, Show, Data, Generic )
data ShaderLinkingError = ShaderLinkingError !T.Text
deriving ( Eq, Typeable, Show, Data, Generic )
instance Exception ShaderBuildingError
shaderExceptionToException :: Exception e => e -> SomeException
shaderExceptionToException = toException . ShaderBuildingError
shaderExceptionFromException :: Exception e => SomeException -> Maybe e
shaderExceptionFromException exc = do
ShaderBuildingError a <- fromException exc
cast a
instance Exception ShaderCompilationError where
toException = shaderExceptionToException
fromException = shaderExceptionFromException
instance Exception ShaderLinkingError where
toException = shaderExceptionToException
fromException = shaderExceptionFromException
setUniform :: MonadIO m
=> Uniformable a
=> a
-> UniformLocation
-> Pipeline
-> m ()
setUniform uniformable location pipeline =
liftIO $ withResource (resourcePL pipeline) $ \(Pipeline_ program) ->
setUniform_ program (safeFromIntegral location) uniformable
newShaderGeneric :: Ptr CChar
-> Int
-> ShaderStage
-> IO Shader
newShaderGeneric source_code_ptr source_code_len stage = liftIO $ mask_ $ do
res <- newResource create
deleter
(return ())
nid <- newUnique
return Shader { resource = res
, identifier = nid
, viewStage = stage }
where
deleter (CompiledShader shader) =
glDeleteShader shader
create = do
shader_name <- glCreateShader (toConstant stage)
with source_code_ptr $ \cstr_ptr ->
with (fromIntegral source_code_len :: GLint) $ \len_ptr ->
glShaderSource
shader_name
1
cstr_ptr
len_ptr
glCompileShader shader_name
checkCompilationErrors shader_name
return $ CompiledShader shader_name
newShaderB :: MonadIO m
=> B.ByteString
-> ShaderStage
-> m Shader
newShaderB source_code stage =
liftIO $ B.unsafeUseAsCStringLen source_code $ \(cstr, len) ->
newShaderGeneric cstr len stage
newShaderBL :: MonadIO m
=> BL.ByteString
-> ShaderStage
-> m Shader
newShaderBL source_code = newShaderB (BL.toStrict source_code)
newShader :: MonadIO m
=> T.Text
-> ShaderStage
-> m Shader
newShader source_code stage = liftIO $ T.withCStringLen source_code $ \(cstr, len) ->
newShaderGeneric cstr len stage
checkCompilationErrors :: GLuint -> IO ()
checkCompilationErrors shader_name = do
status <- gget $ glGetShaderiv shader_name GL_COMPILE_STATUS
when (status == GL_FALSE) $ do
log_len <- gget $ glGetShaderiv shader_name GL_INFO_LOG_LENGTH
allocaBytes (safeFromIntegral log_len) $ \str -> do
glGetShaderInfoLog shader_name log_len nullPtr str
log <- T.peekCStringLen ( str
, safeFromIntegral $ max 0 $ log_len1 )
glDeleteShader shader_name
throwM $ ShaderCompilationError log
checkLinkingErrors :: GLuint -> IO ()
checkLinkingErrors program_name = do
status <- gget $ glGetProgramiv program_name GL_LINK_STATUS
when (status == GL_FALSE) $ do
log_len <- gget $ glGetProgramiv program_name GL_INFO_LOG_LENGTH
allocaBytes (safeFromIntegral log_len) $ \str -> do
glGetProgramInfoLog program_name log_len nullPtr str
log <- T.peekCStringLen ( str
, safeFromIntegral $ max 0 $ log_len1)
glDeleteProgram program_name
throwM $ ShaderLinkingError log
newPipelineVF :: MonadIO m
=> T.Text
-> T.Text
-> AttributeBindings
-> m Pipeline
newPipelineVF vert_src frag_src bindings = liftIO $ do
vsh <- newShader vert_src Vertex
fsh <- newShader frag_src Fragment
newPipeline [vsh, fsh] bindings
type AttributeBindings = M.Map B.ByteString GLuint
newPipeline :: MonadIO m
=> [Shader]
-> AttributeBindings
-> m Pipeline
newPipeline shaders attribute_bindings = liftIO $ mask_ $ do
res <- newResource creator
deleter
(return ())
nid <- newUnique
return Pipeline { resourcePL = res
, pipelineIdentifier = nid
, shaders = shaders }
where
creator = do
program <- glCreateProgram
for_ shaders $ \shader ->
withResource (resource shader) $ \(CompiledShader sname) ->
glAttachShader program sname
ifor_ attribute_bindings $ \key binding ->
B.useAsCString key $ \key_cstr ->
glBindAttribLocation program binding key_cstr
glLinkProgram program
checkLinkingErrors program
return $ Pipeline_ program
deleter (Pipeline_ program) = glDeleteProgram program
gget :: Storable a => (Ptr a -> IO ()) -> IO a
gget action = alloca $ \ptr -> action ptr >> peek ptr
class Uniformable a where
setUniform_ :: GLuint -> GLint -> a -> IO ()
type USetter1 a = GLuint -> GLint -> a -> IO ()
type USetter2 a = GLuint -> GLint -> (a, a) -> IO ()
type USetter3 a = GLuint -> GLint -> (a, a, a) -> IO ()
type USetter4 a = GLuint -> GLint -> (a, a, a, a) -> IO ()
setUi1 :: Integral a => USetter1 a
setUi1 program loc w =
mglProgramUniform1ui program loc (safeFromIntegral w)
setUi2 :: Integral a => USetter2 a
setUi2 program loc (w1, w2) =
mglProgramUniform2ui program loc (safeFromIntegral w1)
(safeFromIntegral w2)
setUi3 :: Integral a => USetter3 a
setUi3 program loc (w1, w2, w3) =
mglProgramUniform3ui program loc (safeFromIntegral w1)
(safeFromIntegral w2)
(safeFromIntegral w3)
setUi4 :: Integral a => USetter4 a
setUi4 program loc (w1, w2, w3, w4) =
mglProgramUniform4ui program loc (safeFromIntegral w1)
(safeFromIntegral w2)
(safeFromIntegral w3)
(safeFromIntegral w4)
setI1 :: Integral a => USetter1 a
setI1 program loc w =
mglProgramUniform1i program loc (safeFromIntegral w)
setI2 :: Integral a => USetter2 a
setI2 program loc (w1, w2) =
mglProgramUniform2i program loc (safeFromIntegral w1)
(safeFromIntegral w2)
setI3 :: Integral a => USetter3 a
setI3 program loc (w1, w2, w3) =
mglProgramUniform3i program loc (safeFromIntegral w1)
(safeFromIntegral w2)
(safeFromIntegral w3)
setI4 :: Integral a => USetter4 a
setI4 program loc (w1, w2, w3, w4) =
mglProgramUniform4i program loc (safeFromIntegral w1)
(safeFromIntegral w2)
(safeFromIntegral w3)
(safeFromIntegral w4)
instance Uniformable Word8 where
setUniform_ = setUi1
instance Uniformable (Word8, Word8) where
setUniform_ = setUi2
instance Uniformable (Word8, Word8, Word8) where
setUniform_ = setUi3
instance Uniformable (Word8, Word8, Word8, Word8) where
setUniform_ = setUi4
instance Uniformable Word16 where
setUniform_ = setUi1
instance Uniformable (Word16, Word16) where
setUniform_ = setUi2
instance Uniformable (Word16, Word16, Word16) where
setUniform_ = setUi3
instance Uniformable (Word16, Word16, Word16, Word16) where
setUniform_ = setUi4
instance Uniformable Word32 where
setUniform_ = setUi1
instance Uniformable (Word32, Word32) where
setUniform_ = setUi2
instance Uniformable (Word32, Word32, Word32) where
setUniform_ = setUi3
instance Uniformable (Word32, Word32, Word32, Word32) where
setUniform_ = setUi4
instance Uniformable Word64 where
setUniform_ = setUi1
instance Uniformable (Word64, Word64) where
setUniform_ = setUi2
instance Uniformable (Word64, Word64, Word64) where
setUniform_ = setUi3
instance Uniformable (Word64, Word64, Word64, Word64) where
setUniform_ = setUi4
instance Uniformable CUInt where
setUniform_ = setUi1
instance Uniformable (CUInt, CUInt) where
setUniform_ = setUi2
instance Uniformable (CUInt, CUInt, CUInt) where
setUniform_ = setUi3
instance Uniformable (CUInt, CUInt, CUInt, CUInt) where
setUniform_ = setUi4
instance Uniformable CInt where
setUniform_ = setI1
instance Uniformable (CInt, CInt) where
setUniform_ = setI2
instance Uniformable (CInt, CInt, CInt) where
setUniform_ = setI3
instance Uniformable (CInt, CInt, CInt, CInt) where
setUniform_ = setI4
instance Uniformable Int8 where
setUniform_ = setI1
instance Uniformable (Int8, Int8) where
setUniform_ = setI2
instance Uniformable (Int8, Int8, Int8) where
setUniform_ = setI3
instance Uniformable (Int8, Int8, Int8, Int8) where
setUniform_ = setI4
instance Uniformable Int16 where
setUniform_ = setI1
instance Uniformable (Int16, Int16) where
setUniform_ = setI2
instance Uniformable (Int16, Int16, Int16) where
setUniform_ = setI3
instance Uniformable (Int16, Int16, Int16, Int16) where
setUniform_ = setI4
instance Uniformable Int32 where
setUniform_ = setI1
instance Uniformable (Int32, Int32) where
setUniform_ = setI2
instance Uniformable (Int32, Int32, Int32) where
setUniform_ = setI3
instance Uniformable (Int32, Int32, Int32, Int32) where
setUniform_ = setI4
instance Uniformable Int64 where
setUniform_ = setI1
instance Uniformable (Int64, Int64) where
setUniform_ = setI2
instance Uniformable (Int64, Int64, Int64) where
setUniform_ = setI3
instance Uniformable (Int64, Int64, Int64, Int64) where
setUniform_ = setI4
instance Uniformable Int where
setUniform_ = setI1
instance Uniformable (Int, Int) where
setUniform_ = setI2
instance Uniformable (Int, Int, Int) where
setUniform_ = setI3
instance Uniformable (Int, Int, Int, Int) where
setUniform_ = setI4
instance Uniformable Integer where
setUniform_ = setI1
instance Uniformable (Integer, Integer) where
setUniform_ = setI2
instance Uniformable (Integer, Integer, Integer) where
setUniform_ = setI3
instance Uniformable (Integer, Integer, Integer, Integer) where
setUniform_ = setI4
instance Uniformable Float where
setUniform_ program loc f1 =
mglProgramUniform1f program loc f1
instance Uniformable (Float, Float) where
setUniform_ program loc (f1, f2) =
mglProgramUniform2f program loc f1 f2
instance Uniformable (Float, Float, Float) where
setUniform_ program loc (f1, f2, f3) =
mglProgramUniform3f program loc f1 f2 f3
instance Uniformable (Float, Float, Float, Float) where
setUniform_ program loc (f1, f2, f3, f4) =
mglProgramUniform4f program loc f1 f2 f3 f4
instance Uniformable Color where
setUniform_ program loc (viewRgba -> tuple) =
setUniform_ program loc tuple
instance Uniformable CFloat where
setUniform_ program loc (CFloat f1) =
mglProgramUniform1f program loc f1
instance Uniformable (CFloat, CFloat) where
setUniform_ program loc (CFloat f1, CFloat f2) =
mglProgramUniform2f program loc f1 f2
instance Uniformable (CFloat, CFloat, CFloat) where
setUniform_ program loc (CFloat f1, CFloat f2, CFloat f3) =
mglProgramUniform3f program loc f1 f2 f3
instance Uniformable (CFloat, CFloat, CFloat, CFloat) where
setUniform_ program loc (CFloat f1, CFloat f2, CFloat f3, CFloat f4) =
mglProgramUniform4f program loc f1 f2 f3 f4
instance Uniformable Double where
setUniform_ program loc f1 =
mglProgramUniform1f program loc (double2Float f1)
instance Uniformable (Double, Double) where
setUniform_ program loc (f1, f2) =
mglProgramUniform2f program loc (double2Float f1) (double2Float f2)
instance Uniformable (Double, Double, Double) where
setUniform_ program loc (f1, f2, f3) =
mglProgramUniform3f program loc
(double2Float f1)
(double2Float f2)
(double2Float f3)
instance Uniformable (Double, Double, Double, Double) where
setUniform_ program loc (f1, f2, f3, f4) =
mglProgramUniform4f program loc
(double2Float f1)
(double2Float f2)
(double2Float f3)
(double2Float f4)
instance Uniformable CDouble where
setUniform_ program loc f1 =
mglProgramUniform1f program loc (cdouble2Float f1)
instance Uniformable (CDouble, CDouble) where
setUniform_ program loc (f1, f2) =
mglProgramUniform2f program loc (cdouble2Float f1) (cdouble2Float f2)
instance Uniformable (CDouble, CDouble, CDouble) where
setUniform_ program loc (f1, f2, f3) =
mglProgramUniform3f program loc
(cdouble2Float f1)
(cdouble2Float f2)
(cdouble2Float f3)
instance Uniformable (CDouble, CDouble, CDouble, CDouble) where
setUniform_ program loc (f1, f2, f3, f4) =
mglProgramUniform4f program loc
(cdouble2Float f1)
(cdouble2Float f2)
(cdouble2Float f3)
(cdouble2Float f4)
double2FloatMap :: Functor a => a Double -> a Float
double2FloatMap = fmap double2Float
double2FloatMapMap :: (Functor a, Functor b) => a (b Double) -> a (b Float)
double2FloatMapMap = fmap (fmap double2Float)
cfloatToFloatMap :: Functor a => a CFloat -> a Float
cfloatToFloatMap = fmap unwrap where
unwrap (CFloat x) = x
cfloatToFloatMapMap :: (Functor a, Functor b) => a (b CFloat) -> a (b Float)
cfloatToFloatMapMap = fmap (fmap unwrap) where
unwrap (CFloat x) = x
cdoubleToDoubleMap :: Functor a => a CDouble -> a Double
cdoubleToDoubleMap = fmap unwrap where
unwrap (CDouble x) = x
cdoubleToDoubleMapMap :: (Functor a, Functor b) => a (b CDouble) -> a (b Double)
cdoubleToDoubleMapMap = fmap (fmap unwrap) where
unwrap (CDouble x) = x
instance Uniformable (Quaternion Float) where
setUniform_ program loc (Quaternion w (V3 x y z)) =
mglProgramUniform4f program loc x y z w
instance Uniformable (Quaternion Double) where
setUniform_ program loc (double2FloatMap -> Quaternion w (V3 x y z)) =
mglProgramUniform4f program loc x y z w
instance Uniformable (Quaternion CFloat) where
setUniform_ program loc (Quaternion (CFloat w) (V3 (CFloat x) (CFloat y) (CFloat z))) =
mglProgramUniform4f program loc x y z w
instance Uniformable (Quaternion CDouble) where
setUniform_ program loc (cdoubleToDoubleMap -> q) =
setUniform_ program loc q
instance Uniformable (V1 CFloat) where
setUniform_ program loc (cfloatToFloatMap -> vec) =
setUniform_ program loc vec
instance Uniformable (V2 CFloat) where
setUniform_ program loc (cfloatToFloatMap -> vec) =
setUniform_ program loc vec
instance Uniformable (V3 CFloat) where
setUniform_ program loc (cfloatToFloatMap -> vec) =
setUniform_ program loc vec
instance Uniformable (V4 CFloat) where
setUniform_ program loc (cfloatToFloatMap -> vec) =
setUniform_ program loc vec
instance Uniformable (V1 CDouble) where
setUniform_ program loc (cdoubleToDoubleMap -> vec) =
setUniform_ program loc vec
instance Uniformable (V2 CDouble) where
setUniform_ program loc (cdoubleToDoubleMap -> vec) =
setUniform_ program loc vec
instance Uniformable (V3 CDouble) where
setUniform_ program loc (cdoubleToDoubleMap -> vec) =
setUniform_ program loc vec
instance Uniformable (V4 CDouble) where
setUniform_ program loc (cdoubleToDoubleMap -> vec) =
setUniform_ program loc vec
instance Uniformable (M33 CFloat) where
setUniform_ program loc (cfloatToFloatMapMap -> m33) =
setUniform_ program loc m33
instance Uniformable (M44 CFloat) where
setUniform_ program loc (cfloatToFloatMapMap -> m44) =
setUniform_ program loc m44
instance Uniformable (M33 CDouble) where
setUniform_ program loc (cdoubleToDoubleMapMap -> m33) =
setUniform_ program loc m33
instance Uniformable (M44 CDouble) where
setUniform_ program loc (cdoubleToDoubleMapMap -> m44) =
setUniform_ program loc m44
instance Uniformable (V1 Double) where
setUniform_ program loc (double2FloatMap -> V1 f1) =
mglProgramUniform1f program loc f1
instance Uniformable (V2 Double) where
setUniform_ program loc (double2FloatMap -> V2 f1 f2) =
mglProgramUniform2f program loc f1 f2
instance Uniformable (V3 Double) where
setUniform_ program loc (double2FloatMap -> V3 f1 f2 f3) =
mglProgramUniform3f program loc f1 f2 f3
instance Uniformable (V4 Double) where
setUniform_ program loc (double2FloatMap -> V4 f1 f2 f3 f4) =
mglProgramUniform4f program loc f1 f2 f3 f4
instance Uniformable (M33 Double) where
setUniform_ program loc (double2FloatMapMap -> m33) =
with m33 $
mglProgramUniformMatrix3fv program loc 1 GL_FALSE . castPtr
instance Uniformable (M44 Double) where
setUniform_ program loc m44 =
with (fmap (fmap double2Float) m44) $
mglProgramUniformMatrix4fv program loc 1 GL_FALSE . castPtr
instance Uniformable (V1 Float) where
setUniform_ program loc (V1 f1) =
mglProgramUniform1f program loc f1
instance Uniformable (V2 Float) where
setUniform_ program loc (V2 f1 f2) =
mglProgramUniform2f program loc f1 f2
instance Uniformable (V3 Float) where
setUniform_ program loc (V3 f1 f2 f3) =
mglProgramUniform3f program loc f1 f2 f3
instance Uniformable (V4 Float) where
setUniform_ program loc (V4 f1 f2 f3 f4) =
mglProgramUniform4f program loc f1 f2 f3 f4
instance Uniformable (M33 Float) where
setUniform_ program loc m33 =
with m33 $
mglProgramUniformMatrix3fv program loc 1 GL_FALSE . castPtr
instance Uniformable (M44 Float) where
setUniform_ program loc m44 =
with m44 $
mglProgramUniformMatrix4fv program loc 1 GL_FALSE . castPtr
cdouble2Float :: CDouble -> Float
cdouble2Float (CDouble dbl) = double2Float dbl
getUniformLocation :: MonadIO m => T.Text -> Pipeline -> m UniformLocation
getUniformLocation name pipeline = liftIO $ fromIntegral <$>
withResource (resourcePL pipeline) (\(Pipeline_ program) ->
B.useAsCString (T.encodeUtf8 name) $ \cstr ->
glGetUniformLocation program cstr)
newtype CLNopPipeline = CLNopPipeline { unwrapCLNop :: Pipeline }
deriving ( Typeable )
nopPipeline :: MonadIO m => m Pipeline
nopPipeline =
retrieveContextLocalData cr >>= return . unwrapCLNop
where
cr = do
vsh <- newShader vsh_src Vertex
fsh <- newShader fsh_src Fragment
newPipeline [vsh, fsh] mempty >>= return . CLNopPipeline
where
(vsh_src, fsh_src) =
(nopsrc, nopsrc)
where
nopsrc = case openGLVersion of
OpenGLVersion 3 2 -> "#version 150\nvoid main() { }\n"
OpenGLVersion 3 1 -> "#version 140\nvoid main() { }\n"
OpenGLVersion 3 0 -> "#version 130\nvoid main() { }\n"
OpenGLVersion 2 1 -> "#version 120\nvoid main() { }\n"
OpenGLVersion 2 0 -> "#version 110\nvoid main() { }\n"
OpenGLVersion maj min ->
"#version " <> showT maj <> showT min <> "0\n" <>
"void main() { }\n"