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 Data.Foldable ( traverse_ )
import Foreign.C ( peekCString, withCString )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( allocaArray )
import Foreign.Ptr ( castPtr, nullPtr )
import Foreign.Storable ( peek )
import Graphics.Luminance.Core.Shader.Stage ( Stage(..) )
import Graphics.Luminance.Core.Shader.Uniform ( U, Uniform(..) )
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 -> m (U a)) -> 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
iface <- buildIface $ ifaceWith prog
pure (prog,iface)
| 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)
ifaceWith :: (HasProgramError e,MonadError e m,MonadIO m,Uniform a)
=> Program
-> Either String Natural
-> m (U a)
ifaceWith prog access = case access of
Left name -> do
location <- liftIO . withCString name $ glGetUniformLocation pid
if
| isActive location -> pure $ toU pid location
| otherwise -> throwError . fromProgramError $ InactiveUniform access
Right sem
| isActive sem -> pure $ toU pid (fromIntegral sem)
| otherwise -> throwError . fromProgramError $ InactiveUniform access
where
pid = programID prog
isActive :: (Ord a,Num a) => a -> Bool
isActive = (> 1)
data ProgramError
= LinkFailed String
| InactiveUniform (Either String Natural)
deriving (Eq,Show)
class HasProgramError a where
fromProgramError :: ProgramError -> a