module Graphics.GLUtil.ShaderProgram
(
ShaderProgram(..),
simpleShaderProgram, simpleShaderProgramWith, simpleShaderExplicit,
simpleShaderProgramBS, simpleShaderProgramWithBS, simpleShaderExplicitBS,
loadShaderProgram, loadShaderProgramWith,
loadShaderProgramBS, loadShaderProgramWithBS,
getAttrib, enableAttrib, setAttrib, setUniform, getUniform) where
import Prelude hiding (lookup)
import Control.Applicative ((<$>), (<*>))
import qualified Data.ByteString as BS
import Data.List (find, findIndex, isSuffixOf)
import Data.Map.Strict (Map, fromList, lookup)
import Data.Maybe (isJust, isNothing, catMaybes)
import Graphics.GLUtil.Shaders (loadShader, linkShaderProgram,
linkShaderProgramWith, loadShaderBS)
import Graphics.GLUtil.GLError (throwError)
import Graphics.Rendering.OpenGL
data ShaderProgram =
ShaderProgram { attribs :: Map String (AttribLocation, VariableType)
, uniforms :: Map String (UniformLocation, VariableType)
, program :: Program }
simpleShaderExplicit :: FilePath -> FilePath -> ([String],[String])
-> IO ShaderProgram
simpleShaderExplicit = simpleShaderExplicit' loadShader
simpleShaderExplicitBS :: BS.ByteString -> BS.ByteString -> ([String],[String])
-> IO ShaderProgram
simpleShaderExplicitBS = simpleShaderExplicit' (loadShaderBS "ByteString literal")
simpleShaderExplicit' :: (ShaderType -> a -> IO Shader)
-> a -> a -> ([String],[String])
-> IO ShaderProgram
simpleShaderExplicit' load vsrc fsrc names =
do vs <- load VertexShader vsrc
fs <- load FragmentShader fsrc
p <- linkShaderProgram [vs,fs]
throwError
(attrs,unis) <- getExplicits p names
return $ ShaderProgram (fromList attrs) (fromList unis) p
simpleShaderProgram :: FilePath -> FilePath -> IO ShaderProgram
simpleShaderProgram vsrc fsrc =
simpleShaderProgramWith vsrc fsrc (\_ -> return ())
simpleShaderProgramBS :: BS.ByteString -> BS.ByteString -> IO ShaderProgram
simpleShaderProgramBS vsrc fsrc =
simpleShaderProgramWithBS vsrc fsrc (\_ -> return ())
simpleShaderProgramWith :: FilePath -> FilePath -> (Program -> IO ())
-> IO ShaderProgram
simpleShaderProgramWith vsrc fsrc m =
loadShaderProgramWith [(VertexShader, vsrc), (FragmentShader, fsrc)] m
simpleShaderProgramWithBS :: BS.ByteString -> BS.ByteString
-> (Program -> IO ()) -> IO ShaderProgram
simpleShaderProgramWithBS vsrc fsrc m =
loadShaderProgramWithBS [(VertexShader, vsrc), (FragmentShader, fsrc)] m
loadShaderProgramWith :: [(ShaderType, FilePath)] -> (Program -> IO ())
-> IO ShaderProgram
loadShaderProgramWith = loadShaderProgramWith' loadShader
loadShaderProgramWithBS :: [(ShaderType, BS.ByteString)] -> (Program -> IO ())
-> IO ShaderProgram
loadShaderProgramWithBS = loadShaderProgramWith' (loadShaderBS "ByteString literal")
loadShaderProgramWith' :: (ShaderType -> a -> IO Shader)
-> [(ShaderType, a)] -> (Program -> IO ())
-> IO ShaderProgram
loadShaderProgramWith' load sources m =
do p <- mapM (uncurry load) sources >>= flip linkShaderProgramWith m
throwError
(attrs,unis) <- getActives p
return $ ShaderProgram (fromList attrs) (fromList unis) p
loadShaderProgram :: [(ShaderType, FilePath)] -> IO ShaderProgram
loadShaderProgram = flip loadShaderProgramWith (const (return ()))
loadShaderProgramBS :: [(ShaderType, BS.ByteString)] -> IO ShaderProgram
loadShaderProgramBS = flip loadShaderProgramWithBS (const (return ()))
getActives :: Program ->
IO ( [(String, (AttribLocation, VariableType))]
, [(String, (UniformLocation, VariableType))] )
getActives p =
(,) <$> (get (activeAttribs p) >>= mapM (aux (attribLocation p)))
<*> (get (activeUniforms p)
>>= mapM (aux (uniformLocation p) . on3 trimArray))
where aux f (_,t,name) = get (f name) >>= \l -> return (name, (l, t))
on3 f (a,b,c) = (a, b, f c)
trimArray n = if "[0]" `isSuffixOf` n then take (length n 3) n else n
getExplicits :: Program -> ([String], [String]) ->
IO ( [(String, (AttribLocation, VariableType))]
, [(String, (UniformLocation, VariableType))] )
getExplicits p (anames, unames) =
do attrs <- get (activeAttribs p)
attrs' <- mapM (aux (get . (attribLocation p))) . checkJusts $
map (\a -> find (\(_,_,n) -> n == a) attrs) anames
unis <- get (activeUniforms p)
unis' <- mapM (aux (get . (uniformLocation p))) . checkJusts $
map (\u -> find (\(_,_,n) -> n == u) unis) unames
return (attrs', unis')
where aux f (_,t,n) = f n >>= \l -> return (n, (l,t))
checkJusts xs
| all isJust xs = catMaybes xs
| otherwise = let Just i = findIndex isNothing xs
in error $ "Missing GLSL variable: " ++ anames !! i
setUniform :: Uniform a => ShaderProgram -> String -> a -> IO ()
setUniform sp name = maybe (const (putStrLn warn >> return ()))
(\(u,_) -> let u' = uniform u
in \x -> u' $= x)
(lookup name $ uniforms sp)
where warn = "WARNING: uniform "++name++" is not active"
getUniform :: ShaderProgram -> String -> UniformLocation
getUniform sp n = maybe (error msg) fst . lookup n $ uniforms sp
where msg = "Uniform "++show n++" is not active"
setAttrib :: ShaderProgram -> String ->
IntegerHandling -> VertexArrayDescriptor a -> IO ()
setAttrib sp name = maybe (\_ _ -> putStrLn warn >> return ())
(\(a,_) -> let vap = vertexAttribPointer a
in \ih vad -> (($= (ih, vad)) vap))
(lookup name $ attribs sp)
where warn = "WARNING: attrib "++name++" is not active"
getAttrib :: ShaderProgram -> String -> AttribLocation
getAttrib sp n = maybe (error msg) fst . lookup n $ attribs sp
where msg = "Attrib "++show n++" is not active"
enableAttrib :: ShaderProgram -> String -> IO ()
enableAttrib sp name = maybe (return ())
(($= Enabled) . vertexAttribArray . fst)
(lookup name $ attribs sp)