module Graphics.RecordGL.Uniforms (
setAllUniforms, setSomeUniforms, setUniforms,
HasFieldGLTypes(..), UniformFields, SetUniformFields) where
import BasePrelude hiding (Proxy)
import qualified Data.Map as M
import Graphics.GLUtil (AsUniform (..),
HasVariableType (..),
ShaderProgram (..))
import Graphics.Rendering.OpenGL (UniformLocation)
import qualified Graphics.Rendering.OpenGL as GL
import Language.Haskell.TH
import qualified Data.Set as S
import Record.Introspection
import Record.Types
class HasFieldGLTypes a where
fieldGLTypes :: a -> [GL.VariableType]
class SetUniformFields a where
setUniformFields :: [Maybe UniformLocation] -> a -> IO ()
type UniformFields a = (HasFieldNames a, HasFieldGLTypes a, SetUniformFields a)
setAllUniforms :: forall record. UniformFields record
=> ShaderProgram -> record -> IO ()
setAllUniforms s r = case checks of
Left msg -> error msg
Right _ -> setUniformFields locs r
where
fnames = fieldNames r
checks = do
namesCheck "record" (M.keys $ uniforms s) fnames
typesCheck True (snd <$> uniforms s) fieldTypes
fieldTypes = M.fromList $ zip fnames (fieldGLTypes r)
locs = map (fmap fst . (`M.lookup` uniforms s)) fnames
setUniforms :: forall record. UniformFields record => ShaderProgram -> record -> IO ()
setUniforms s r = case checks of
Left msg -> error msg
Right _ -> setUniformFields locs r
where
fnames = fieldNames r
checks = do
namesCheck "GLSL programme" fnames (M.keys $ uniforms s)
typesCheck False fieldTypes (snd <$> uniforms s)
fieldTypes = M.fromList $ zip fnames (fieldGLTypes r)
locs = map (fmap fst . (`M.lookup` uniforms s)) fnames
setSomeUniforms :: forall r. UniformFields r
=> ShaderProgram -> r -> IO ()
setSomeUniforms s r = case typesCheck' True (snd <$> uniforms s) fieldTypes of
Left msg -> error msg
Right _ -> setUniformFields locs r
where
fnames = fieldNames r
fieldTypes = M.fromList . zip fnames $ fieldGLTypes r
locs = map (fmap fst . (`M.lookup` uniforms s)) fnames
namesCheck :: String -> [String] -> [String] -> Either String ()
namesCheck culprit little big = mapM_ go little
where
big' = S.fromList big
go x | x `S.member` big' = Right ()
| otherwise = Left $ "Field " ++ x ++ " not found in " ++ culprit
typesCheck :: Bool
-> M.Map String GL.VariableType -> M.Map String GL.VariableType
-> Either String ()
typesCheck blame little big = mapM_ go $ M.toList little
where
go (n, t) | (glTypeEquiv t <$> M.lookup n big) == Just True = return ()
| otherwise = Left $ msg n (show t) (maybe "" show (M.lookup n big))
msg n t t' = let (expected, actual) = if blame then (t, t') else (t', t)
in "Record and GLSL types disagree on field " ++ n ++
": GLSL expected " ++ expected ++
", record disappointed with " ++ actual
typesCheck' :: Bool
-> M.Map String GL.VariableType -> M.Map String GL.VariableType
-> Either String ()
typesCheck' blame little big = mapM_ go $ M.toList little
where
go (n, t) | fromMaybe True (glTypeEquiv t <$> M.lookup n big) = return ()
| otherwise = Left $ msg n (show t) (maybe "" show (M.lookup n big))
msg n t t' = let (expected, actual) = if blame then (t, t') else (t', t)
in "Record and GLSL types disagree on field " ++ n ++
": GLSL expected " ++ expected ++
", record disappointed with " ++ actual
glTypeEquiv :: GL.VariableType -> GL.VariableType -> Bool
glTypeEquiv x y = glTypeEquiv' x y || glTypeEquiv' y x
glTypeEquiv' :: GL.VariableType -> GL.VariableType -> Bool
glTypeEquiv' GL.Sampler1D GL.Int' = True
glTypeEquiv' GL.Sampler2D GL.Int' = True
glTypeEquiv' GL.Sampler3D GL.Int' = True
glTypeEquiv' x y = x == y
return $ flip map [1..24] $ \arity ->
let typeName = mkName $ "Record" <> show arity
recordType = foldl (\a i -> AppT (AppT a (VarT (mkName ("n" <> show i))))
(VarT (mkName ("v" <> show i))))
(ConT typeName)
[1 .. arity]
vVals = map (\i -> "v" <> show i) [1..arity]
vTVals = map (VarT . mkName) vVals
#if MIN_VERSION_template_haskell(2,10,0)
mkContext c t = AppT (ConT (mkName c)) t
#else
mkContext c t = ClassP (mkName c) [t]
#endif
context = map (\v -> mkContext "HasVariableType" v) vTVals
typesList = ListE $ map (AppE (VarE (mkName "variableType")) .
SigE (VarE (mkName "undefined")))
vTVals
fieldGLTypesFun = FunD (mkName "fieldGLTypes")
[Clause [WildP] (NormalB typesList) []]
in InstanceD context
(AppT (ConT (mkName "HasFieldGLTypes")) recordType)
[fieldGLTypesFun]
return $ flip map [1..24] $ \arity ->
let typeName = mkName $ "Record" <> show arity
recordType = foldl (\a i -> AppT (AppT a (VarT (mkName ("n" <> show i))))
(VarT (mkName ("v" <> show i))))
(ConT typeName)
[1 .. arity]
typePattern = ConP typeName (map (\i -> VarP (mkName ("v" <> show i))) [1..arity])
vNames = map (\i -> mkName $ "v" <> show i) [1..arity]
vTVals = map VarT vNames
#if MIN_VERSION_template_haskell(2,10,0)
mkContext c t = AppT (ConT (mkName c)) t
#else
mkContext c t = ClassP (mkName c) [t]
#endif
context = map (\v -> mkContext "AsUniform" v) vTVals
nameE = VarE . mkName
uniformNames = map (\i -> mkName ("u" <> show i)) [1..arity + 1]
uniformPat = AsP (mkName "us") $ foldr1 (\i a -> InfixP i (mkName ":") a) $ map VarP uniformNames
asUniforms = foldr1 (\i a -> InfixE (Just i) (nameE ">>") (Just a)) $ zipWith go us vs
where
us = map VarE uniformNames
go u v = AppE (AppE (nameE "traverse_")
(AppE (nameE "asUniform") v))
u
vs = map VarE vNames
wrongSizes = NormalG $ InfixE (Just (AppE (nameE "length")
(nameE "us")))
(VarE (mkName "<"))
(Just (LitE (IntegerL arity)))
contrarily = NormalG $ nameE "otherwise"
setUniformFieldsFun =
FunD (mkName "setUniformFields")
[Clause [uniformPat, typePattern]
(GuardedB [(wrongSizes, AppE (nameE "error")
(LitE (StringL "Not enough UniformLocations :(")))
,(contrarily, asUniforms)]) []]
in InstanceD context
(AppT (ConT (mkName "SetUniformFields")) recordType)
[setUniformFieldsFun]