module FWGL.Shader.GLSL (
vertexToGLSLAttr,
vertexToGLSL,
fragmentToGLSL,
shaderToGLSL,
exprToGLSL,
globalName,
attributeName
) where
import Data.Typeable
import FWGL.Shader.Shader
import FWGL.Shader.Language (Expr(..), ShaderType(..))
import FWGL.Shader.Stages (VertexShader, FragmentShader, ValidVertex)
type ShaderVars = ( [(String, String)]
, [(String, String, Int)]
, [(String, String, Expr)])
vertexToGLSLAttr :: ValidVertex g i o => VertexShader g i o
-> (String, [(String, Int)])
vertexToGLSLAttr v =
let r@(_, is, _) = vars False v
in ( shaderToGLSL "#version 100\n" "attribute" "varying"
r [("hvVertexShaderOutput", "gl_Position")]
, map (\(t, n, s) -> (n, s)) is)
vertexToGLSL :: ValidVertex g i o => VertexShader g i o -> String
vertexToGLSL = fst . vertexToGLSLAttr
fragmentToGLSL :: Valid g i '[] => FragmentShader g i -> String
fragmentToGLSL v = shaderToGLSL "#version 100\nprecision mediump float;"
"varying" ""
(vars True v)
[("hvFragmentShaderOutput", "gl_FragColor")]
shaderToGLSL :: String -> String -> String -> ShaderVars -> [(String, String)] -> String
shaderToGLSL header ins outs (gs, is, os) predec =
header ++
concatMap (var "uniform") gs ++
concatMap (\(t, n, _) -> var ins (t, n)) is ++
concatMap (\(t, n, _) -> if any ((== n) . fst) predec
then []
else var outs (t, n)
) os ++
"void main(){" ++
concatMap (\(_, n, e) -> replace n predec ++ "=" ++
exprToGLSL e ++ ";") os ++ "}"
where var qual (ty, nm) = qual ++ " " ++ ty ++ " " ++ nm ++ ";"
replace x xs = case filter ((== x) . fst) xs of
((_, y) : []) -> y
_ -> x
vars :: Valid gs is os => Bool -> Shader gs is os -> ShaderVars
vars isFragment (shader :: Shader gs is os) =
( staticList (undefined :: Proxy gs) globalTypeAndName
, staticList (undefined :: Proxy is) inputVar
, stFold (\acc x -> outputVar x : acc) [] outputs)
where outputs = shader (staticSTList (undefined :: Proxy gs) globalExpr)
(staticSTList (undefined :: Proxy is) inputExpr)
globalExpr, inputExpr :: (Typeable x, ShaderType y) => x -> y
globalExpr x = fromExpr . Read $ globalName x
inputExpr x = fromExpr . Read $ if isFragment then varyingName x
else attributeName x
inputVar :: (Typeable x, ShaderType x)
=> x -> (String, String, Int)
inputVar x = let (ty, nm) = if isFragment
then varyingTypeAndName x
else attributeTypeAndName x
in (ty, nm, size x)
outputVar :: (Typeable x, ShaderType x)
=> x -> (String, String, Expr)
outputVar x = let (ty, nm) = varyingTypeAndName x
in (ty, nm, toExpr x)
exprToGLSL :: Expr -> String
exprToGLSL Empty = ""
exprToGLSL (Read s) = s
exprToGLSL (Op1 s e) = "(" ++ s ++ exprToGLSL e ++ ")"
exprToGLSL (Op2 s x y) = "(" ++ exprToGLSL x ++ s ++ exprToGLSL y ++ ")"
exprToGLSL (Apply s es) = s ++ "(" ++ tail (es >>= (',' :) . exprToGLSL) ++ ")"
exprToGLSL (X x) = exprToGLSL x ++ ".x"
exprToGLSL (Y x) = exprToGLSL x ++ ".y"
exprToGLSL (Z x) = exprToGLSL x ++ ".z"
exprToGLSL (W x) = exprToGLSL x ++ ".w"
exprToGLSL (Literal s) = s
globalTypeAndName :: (Typeable t, ShaderType t) => t -> (String, String)
globalTypeAndName t = (typeName t, globalName t)
varyingTypeAndName :: (Typeable t, ShaderType t) => t -> (String, String)
varyingTypeAndName t = (typeName t, varyingName t)
attributeTypeAndName :: (Typeable t, ShaderType t) => t -> (String, String)
attributeTypeAndName t = (typeName t, attributeName t)
variableName :: Typeable t => t -> String
variableName = tyConName . typeRepTyCon . typeOf
globalName :: Typeable t => t -> String
globalName = ("hg" ++) . variableName
varyingName :: Typeable t => t -> String
varyingName = ("hv" ++) . variableName
attributeName :: Typeable t => t -> String
attributeName = ("ha" ++) . variableName