module Graphics.Luminance.Core.Shader.Program where
import Control.Applicative ( liftA2 )
import Control.Monad.Except ( MonadError(throwError) )
import Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad.Trans.Resource ( MonadResource, register )
import Control.Monad.Trans.State ( StateT, evalStateT, gets, modify )
import Data.Foldable ( traverse_ )
import Data.Proxy ( Proxy(..) )
import Foreign.C ( peekCString, withCString )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( allocaArray )
import Foreign.Ptr ( castPtr, nullPtr )
import Foreign.Storable ( Storable(peek) )
import Graphics.Luminance.Core.Buffer ( Region(..), bufferID )
import Graphics.Luminance.Core.Shader.Stage ( Stage(..) )
import Graphics.Luminance.Core.Shader.Uniform ( U(..), Uniform(..) )
import Graphics.Luminance.Core.Shader.UniformBlock ( UB, UniformBlock(sizeOfSTD140) )
import Graphics.GL
import Numeric.Natural ( Natural )
newtype Program = Program { programID :: GLuint }
createProgram :: (HasProgramError e,MonadError e m,MonadIO m,MonadResource m)
=> [Stage]
-> ((forall a. (Uniform a) => Either String Natural -> UniformInterface m (U a)) -> (forall a. (UniformBlock a) => String -> UniformInterface m (U (Region rw (UB a)))) -> UniformInterface m i)
-> m (Program,i)
createProgram stages buildIface = do
(pid,linked,cl) <- liftIO $ do
pid <- glCreateProgram
traverse_ (glAttachShader pid . stageID) stages
glLinkProgram pid
linked <- isLinked pid
ll <- clogLength pid
cl <- clog ll pid
pure (pid,linked,cl)
if
| linked -> do
_ <- register $ glDeleteProgram pid
let prog = Program pid
a <- runUniformInterface $ buildIface (uniformize prog) (uniformizeBlock prog)
pure (prog,a)
| otherwise -> throwError . fromProgramError $ LinkFailed cl
createProgram_ :: (HasProgramError e,MonadError e m,MonadIO m,MonadResource m)
=> [Stage]
-> m Program
createProgram_ stages = fmap fst $ createProgram stages (\_ _ -> pure ())
isLinked :: GLuint -> IO Bool
isLinked pid = do
ok <- alloca $ liftA2 (*>) (glGetProgramiv pid GL_LINK_STATUS) peek
pure $ ok == GL_TRUE
clogLength :: GLuint -> IO Int
clogLength pid =
fmap fromIntegral .
alloca $ liftA2 (*>) (glGetProgramiv pid GL_INFO_LOG_LENGTH) peek
clog :: Int -> GLuint -> IO String
clog l pid =
allocaArray l $
liftA2 (*>) (glGetProgramInfoLog pid (fromIntegral l) nullPtr)
(peekCString . castPtr)
newtype UniformInterface m a = UniformInterface {
runUniformInterface' :: StateT UniformInterfaceCtxt m a
} deriving (Applicative,Functor,Monad)
runUniformInterface :: (Monad m) => UniformInterface m a -> m a
runUniformInterface ui = evalStateT (runUniformInterface' ui) emptyUniformInterfaceCtxt
newtype UniformInterfaceCtxt = UniformInterfaceCtxt {
uniformInterfaceBufferBinding :: GLuint
} deriving (Eq,Show)
emptyUniformInterfaceCtxt :: UniformInterfaceCtxt
emptyUniformInterfaceCtxt = UniformInterfaceCtxt {
uniformInterfaceBufferBinding = 0
}
uniformize :: (HasProgramError e,MonadError e m,MonadIO m,Uniform a)
=> Program
-> Either String Natural
-> UniformInterface m (U a)
uniformize Program{programID = pid} access = UniformInterface $ case access of
Left name -> do
location <- liftIO . withCString name $ glGetUniformLocation pid
if
| location /= 1 -> pure $ toU pid location
| otherwise -> throwError . fromProgramError $ InactiveUniform access
Right sem
| sem /= 1 -> pure $ toU pid (fromIntegral sem)
| otherwise -> throwError . fromProgramError $ InactiveUniform access
uniformizeBlock :: forall a e m rw. (HasProgramError e,MonadError e m,MonadIO m,UniformBlock a)
=> Program
-> String
-> UniformInterface m (U (Region rw (UB a)))
uniformizeBlock Program{programID = pid} name = UniformInterface $ do
index <- liftIO . withCString name $ glGetUniformBlockIndex pid
if
| index /= GL_INVALID_INDEX -> do
binding <- gets uniformInterfaceBufferBinding
modify $ \ctxt -> ctxt { uniformInterfaceBufferBinding = succ $ uniformInterfaceBufferBinding ctxt }
liftIO (glUniformBlockBinding pid index binding)
pure . U $ \r -> do
glBindBufferRange
GL_UNIFORM_BUFFER
binding
(bufferID $ regionBuffer r)
(fromIntegral $ regionOffset r)
(fromIntegral $ regionSize r * sizeOfSTD140 (Proxy :: Proxy a))
| otherwise -> throwError . fromProgramError $ InactiveUniformBlock name
data ProgramError
= LinkFailed String
| InactiveUniform (Either String Natural)
| InactiveUniformBlock String
deriving (Eq,Show)
class HasProgramError a where
fromProgramError :: ProgramError -> a