gelatin-gl-0.1.0.0: src/Gelatin/GL/Shader.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fprint-explicit-kinds #-}
module Gelatin.GL.Shader (
-- * Compiling and loading shaders
Simple2DShader
, compileOGLShader
, compileOGLProgram
, loadSourcePaths
, compileSources
, compileProgram
, loadSimple2DShader
--loadSumShader,
--loadGLShader,
---- * GLShader types
--GLShaderProgram,
--GLShader,
--GLShaderDef,
---- * GLShader prims
--PrimType(..),
---- * Uniforms
--Simple2DUniform(..),
---- * Updating uniforms for specific kinds of rendering
--updateUniformsForTris,
--updateUniformsForBezs,
--updateUniformsForLines,
--updateUniformsForMask,
--applyAlpha,
--applyMult,
---- * Free form uniform updates
--updateUniform,
--updateUniforms,
---- * Attributes
---- $layout
--Simple2DAttrib(..),
--locToGLuint,
---- * Enabling attribs for specific kinds of rendering
--enableAttribsForTris,
--enableAttribsForBezs,
--enableAttribsForLines,
--enableAttribsForMask,
---- * Enabling and disabling any attribs
--onlyEnableAttribs,
---- * GLShader compilation
--compileShader,
--compileProgram,
) where
import Control.Exception (assert)
import Control.Monad
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString.Char8 as B
import qualified Data.Foldable as F
import Data.Proxy (Proxy (..))
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Storable as S
import Data.Vector.Unboxed (Unbox, Vector)
import qualified Data.Vector.Unboxed as V
import Foreign.C.String
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable
import GHC.TypeLits (KnownNat, KnownSymbol, natVal)
import Graphics.GL.Core33
import Graphics.GL.Types
import Prelude hiding (init)
import Prelude as P
import Gelatin
import Gelatin.Shaders
import Gelatin.GL.TH
type Simple2DShader = GLuint
--------------------------------------------------------------------------------
-- Updating shader uniforms
--------------------------------------------------------------------------------
---- | Updates uniforms for rendering triangles.
--updateUniformsForTris :: GLShader -> M44 Float -> M44 Float -> Bool -> Float
-- -> V4 Float -> Maybe (V4 Float) -> IO ()
--updateUniformsForTris sh pj mv hasUV a m mr =
-- updateUniforms (uniformsForTris pj mv hasUV a m mr) sh
--{-# INLINE updateUniformsForTris #-}
--
---- | Updates uniforms for rendering loop-blinn beziers.
--updateUniformsForBezs :: GLShader -> M44 Float -> M44 Float -> Bool -> Float
-- -> V4 Float -> Maybe (V4 Float) -> IO ()
--updateUniformsForBezs sh pj mv hasUV a m mr =
-- updateUniforms (uniformsForBezs pj mv hasUV a m mr) sh
--{-# INLINE updateUniformsForBezs #-}
--
---- | Updates uniforms for rendering projected polylines.
--updateUniformsForLines :: GLShader -> M44 Float -> M44 Float -> Bool -> Float
-- -> V4 Float -> Maybe (V4 Float) -> Float -> Float -> Float
-- -> (LineCap,LineCap) -> IO ()
--updateUniformsForLines sh pj mv hasUV a m mr thickness feather sumlength caps =
-- let us = uniformsForLines pj mv hasUV a m mr thickness feather sumlength caps
-- in updateUniforms us sh
--{-# INLINE updateUniformsForLines #-}
--
---- | Updates uniforms for rendering alpha masking.
--updateUniformsForMask :: GLShader -> M44 Float -> M44 Float -> Float -> V4 Float
-- -> GLuint -> GLuint -> IO ()
--updateUniformsForMask sh pj mv a m main mask =
-- updateUniforms (uniformsForMask pj mv a m main mask) sh
--{-# INLINE updateUniformsForMask #-}
--
--updateUniforms :: [Simple2DUniform] -> GLShader -> IO ()
--updateUniforms us s = mapM_ (`updateUniform` s) us
--{-# INLINE updateUniforms #-}
--
--updateUniform :: Simple2DUniform -> GLShader -> IO ()
--updateUniform u s = withUniform (simple2DUniformIdentifier u) s $ \p loc -> do
-- glUseProgram p
-- uniformUpdateFunc u loc
--{-# INLINE updateUniform #-}
--
--uniformUpdateFunc :: Simple2DUniform -> GLint -> IO ()
--uniformUpdateFunc (UniformPrimType p) u =
-- glUniform1i u $ fromIntegral $ fromEnum p
--uniformUpdateFunc (UniformProjection m44) u =
-- with m44 $ glUniformMatrix4fv u 1 GL_TRUE . castPtr
--uniformUpdateFunc (UniformModelView m44) u =
-- with m44 $ glUniformMatrix4fv u 1 GL_TRUE . castPtr
--uniformUpdateFunc (UniformThickness t) u = glUniform1f u t
--uniformUpdateFunc (UniformFeather f) u = glUniform1f u f
--uniformUpdateFunc (UniformSumLength l) u = glUniform1f u l
--uniformUpdateFunc (UniformLineCaps (capx, capy)) u =
-- let [x,y] = P.map (fromIntegral . fromEnum) [capx,capy] in glUniform2f u x y
--uniformUpdateFunc (UniformHasUV has) u = glUniform1i u $ if has then 1 else 0
--uniformUpdateFunc (UniformSampler s) u = glUniform1i u $ fromIntegral s
--uniformUpdateFunc (UniformMainTex t) u = glUniform1i u $ fromIntegral t
--uniformUpdateFunc (UniformMaskTex t) u = glUniform1i u $ fromIntegral t
--uniformUpdateFunc (UniformAlpha a) u = glUniform1f u $ realToFrac a
--uniformUpdateFunc (UniformMult v) u =
-- let (V4 r g b a) = realToFrac <$> v in glUniform4f u r g b a
--uniformUpdateFunc (UniformShouldReplaceColor s) u =
-- glUniform1i u $ if s then 1 else 0
--uniformUpdateFunc (UniformReplaceColor c) u =
-- let (V4 r g b a) = realToFrac <$> c in glUniform4f u r g b a
--{-# INLINE uniformUpdateFunc #-}
--
--withUniform :: String -> GLShader -> (GLuint -> GLint -> IO ()) -> IO ()
--withUniform name (Shader p ls) f =
-- case lookup name ls of
-- Nothing -> do P.putStrLn $ "could not find uniform " ++ name
-- exitFailure
-- Just loc -> f p loc
--{-# INLINE withUniform #-}
--------------------------------------------------------------------------------
-- $layout
-- Attributes layout locations are unique and global.
--------------------------------------------------------------------------------
--locToGLuint :: Simple2DAttrib -> GLuint
--locToGLuint = fromIntegral . fromEnum
--
---- | Enables the provided attributes and disables all others.
--onlyEnableAttribs :: [Simple2DAttrib] -> IO ()
--onlyEnableAttribs atts = do
-- mapM_ (glDisableVertexAttribArray . locToGLuint) allAttribs
-- mapM_ (glEnableVertexAttribArray . locToGLuint) atts
--enableAttribsForTris :: Bool -> IO ()
--enableAttribsForTris True = onlyEnableAttribs [PositionLoc,UVLoc]
--enableAttribsForTris False = onlyEnableAttribs [PositionLoc,ColorLoc]
--
--enableAttribsForBezs :: Bool -> IO ()
--enableAttribsForBezs True = onlyEnableAttribs [PositionLoc,UVLoc,BezLoc]
--enableAttribsForBezs False = onlyEnableAttribs [PositionLoc,ColorLoc,BezLoc]
--
--enableAttribsForLines :: Bool -> IO ()
--enableAttribsForLines True =
-- onlyEnableAttribs [PositionLoc,UVLoc,BezUVLoc,NextLoc,PrevLoc]
--enableAttribsForLines False =
-- onlyEnableAttribs [PositionLoc,ColorLoc,BezUVLoc,NextLoc,PrevLoc]
--
--enableAttribsForMask :: IO ()
--enableAttribsForMask = onlyEnableAttribs [PositionLoc,UVLoc]
--------------------------------------------------------------------------------
-- IsShaderType instances
--------------------------------------------------------------------------------
instance IsShaderType VertexShader GLenum where
getShaderType _ = GL_VERTEX_SHADER
instance IsShaderType FragmentShader GLenum where
getShaderType _ = GL_FRAGMENT_SHADER
--------------------------------------------------------------------------------
-- Uniform marshaling functions
--------------------------------------------------------------------------------
$(genUniform [t|Bool|] [| \loc bool ->
glUniform1i loc $ if bool then 1 else 0 |])
$(genUniform [t|Int|] [| \loc enum ->
glUniform1i loc $ fromIntegral $ fromEnum enum |])
$(genUniform [t|PrimType|] [| \loc enum ->
glUniform1i loc $ fromIntegral $ fromEnum enum |])
$(genUniform [t|Float|] [| \loc float ->
glUniform1f loc $ realToFrac float |])
$(genUniform [t|V2 Float|] [| \loc v ->
let V2 x y = fmap realToFrac v
in glUniform2f loc x y |])
$(genUniform [t|V3 Float|] [| \loc v ->
let V3 x y z = fmap realToFrac v
in glUniform3f loc x y z|])
$(genUniform [t|V4 Float|] [| \loc v ->
let (V4 r g b a) = realToFrac <$> v
in glUniform4f loc r g b a |])
$(genUniform [t|M44 Float|] [| \loc val ->
with val $ glUniformMatrix4fv loc 1 GL_TRUE . castPtr |])
$(genUniform [t|(Int,Int)|] [| \loc (a, b) ->
let [x,y] = P.map fromIntegral [a, b]
in glUniform2i loc x y |])
$(genUniform [t|(LineCap,LineCap)|] [| \loc (a, b) ->
let [x,y] = P.map (fromIntegral . fromEnum) [a, b]
in glUniform2f loc x y |])
$(genUniform [t|V2 Int|] [| \loc v ->
let V2 x y = fmap fromIntegral v
in glUniform2i loc x y |])
--------------------------------------------------------------------------------
-- Attribute buffering and toggling
--------------------------------------------------------------------------------
convertVec
:: (Unbox (f Float), Foldable f) => Vector (f Float) -> S.Vector GLfloat
convertVec =
S.convert . V.map realToFrac . V.concatMap (V.fromList . F.toList)
instance
( KnownNat loc, KnownSymbol name
, Foldable f
, Unbox (f Float), Storable (f Float)
) => HasGenFunc (AttributeBuffering (Attribute name (f Float) loc)) where
type GenFunc (AttributeBuffering (Attribute name (f Float) loc)) =
GLint -> GLuint -> Vector (f Float) -> IO ()
genFunction _ n buf as = do
let loc = fromIntegral $ natVal (Proxy :: Proxy loc)
asize = V.length as * sizeOf (V.head as)
glBindBuffer GL_ARRAY_BUFFER buf
S.unsafeWith (convertVec as) $ \ptr ->
glBufferData GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL_STATIC_DRAW
glEnableVertexAttribArray loc
glVertexAttribPointer loc n GL_FLOAT GL_FALSE 0 nullPtr
err <- glGetError
when (err /= 0) $ do
print err
assert False $ return ()
instance (KnownNat loc, KnownSymbol name)
=> HasGenFunc (AttributeToggling (Attribute name val loc)) where
type GenFunc (AttributeToggling (Attribute name val loc)) = (IO (), IO ())
genFunction _ =
let aloc = fromIntegral $ natVal (Proxy :: Proxy loc)
in (glEnableVertexAttribArray aloc, glDisableVertexAttribArray aloc)
--------------------------------------------------------------------------------
-- OpenGL shader only stuff
--------------------------------------------------------------------------------
compileOGLShader :: (MonadIO m, MonadError String m)
=> ByteString
-- ^ The shader source
-> GLenum
-- ^ The shader type (vertex, frag, etc)
-> m GLuint
-- ^ Either an error message or the generated shader handle.
compileOGLShader src shType = do
shader <- liftIO $ glCreateShader shType
if shader == 0
then throwError "Could not create shader"
else do
success <- liftIO $ do
withCString (B.unpack src) $ \ptr ->
with ptr $ \ptrptr -> glShaderSource shader 1 ptrptr nullPtr
glCompileShader shader
with (0 :: GLint) $ \ptr -> do
glGetShaderiv shader GL_COMPILE_STATUS ptr
peek ptr
if success == GL_FALSE
then do
err <- liftIO $ do
infoLog <- with (0 :: GLint) $ \ptr -> do
glGetShaderiv shader GL_INFO_LOG_LENGTH ptr
logsize <- peek ptr
allocaArray (fromIntegral logsize) $ \logptr -> do
glGetShaderInfoLog shader logsize nullPtr logptr
peekArray (fromIntegral logsize) logptr
return $ P.unlines [ "Could not compile shader:"
, B.unpack src
, P.map (toEnum . fromEnum) infoLog
]
throwError err
else return shader
compileOGLProgram :: (MonadIO m, MonadError String m)
=> [(String, Integer)] -> [GLuint] -> m GLuint
compileOGLProgram attribs shaders = do
(program, success) <- liftIO $ do
program <- glCreateProgram
forM_ shaders (glAttachShader program)
forM_ attribs $ \(name, loc) ->
withCString name $ glBindAttribLocation program $ fromIntegral loc
glLinkProgram program
success <- with (0 :: GLint) $ \ptr -> do
glGetProgramiv program GL_LINK_STATUS ptr
peek ptr
return (program, success)
if success == GL_FALSE
then do
err <- liftIO $ with (0 :: GLint) $ \ptr -> do
glGetProgramiv program GL_INFO_LOG_LENGTH ptr
logsize <- peek ptr
infoLog <- allocaArray (fromIntegral logsize) $ \logptr -> do
glGetProgramInfoLog program logsize nullPtr logptr
peekArray (fromIntegral logsize) logptr
return $ P.unlines [ "Could not link program"
, P.map (toEnum . fromEnum) infoLog
]
throwError err
else do
liftIO $ forM_ shaders glDeleteShader
return program
--------------------------------------------------------------------------------
-- Loading shaders and compiling a program.
--------------------------------------------------------------------------------
loadSourcePaths :: MonadIO m
=> ShaderSteps (ts :: [*]) FilePath
-> m (ShaderSteps ts ByteString)
loadSourcePaths = (ShaderSteps <$>) . mapM (liftIO . B.readFile) . unShaderSteps
compileSources
:: forall m ts. (MonadIO m, MonadError String m, IsShaderType ts [GLenum])
=> ShaderSteps (ts :: [*]) ByteString
-> m (ShaderSteps ts GLuint)
compileSources =
(ShaderSteps <$>) . zipWithM (flip compileOGLShader) types . unShaderSteps
where types = getShaderType (Proxy :: Proxy ts)
compileProgram
:: (MonadIO m, MonadError String m, GetLits as [(String, Integer)])
=> Proxy (as :: [*])
-> ShaderSteps (ts :: [*]) GLuint
-> m GLuint
compileProgram p = compileOGLProgram (getSymbols p) . unShaderSteps
-- | Compile all shader programs and return a "sum renderer".
loadSimple2DShader :: (MonadIO m, MonadError String m) => m Simple2DShader
loadSimple2DShader = do
vertName <- liftIO simple2dVertFilePath
fragName <- liftIO simple2dFragFilePath
let paths :: ShaderSteps '[VertexShader, FragmentShader] FilePath
paths = ShaderSteps [vertName, fragName]
sources <- loadSourcePaths paths
shaders <- compileSources sources
compileProgram (Proxy :: Proxy Simple2DAttribs) shaders