{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}
module Language.Del.Glsl (glsl, GLSL) where
import Control.Monad.Trans.Writer
import Data.List
import qualified Data.Text as T
import Language.Del.CompileDefs
import qualified Language.Del.InRep as IR
import Language.Del.TypeTable
import Numeric
newtype GLSL = GLSL T.Text
instance Show GLSL where
show (GLSL t) = T.unpack t
glslType :: Type -> T.Text
glslType t
= case findType t of
Just (TypeInfo _ _ n) -> n
Nothing -> case t of
NamedType n -> n
_ -> undefined
glslName :: T.Text -> T.Text
glslName = T.replace "/" "__"
glsl :: IR.Program -> Artifact GLSL
glsl prog = execWriterT (glslRoot prog) >>= return . GLSL . T.concat
type Ctx a = WriterT [T.Text] Artifact a
emit :: (Monad m) => w -> WriterT [w] m ()
emit x = tell [x]
emitShow :: (Monad m, Show s) => s -> WriterT [T.Text] m ()
emitShow = emit . T.pack . show
glslRoot :: IR.Program -> Ctx ()
glslRoot (IR.Program args ret stmts)
= do
emit "void shader_entry(out "
emit $ glslType ret
emit " __ret"
mapM (\(n, t) -> tell [", ", glslType t, " ", glslName n]) args
emit ") {\n"
mapM glslStmt stmts
emit "\n}"
return ()
glslStmt :: IR.Stmt -> Ctx ()
glslStmt (IR.Store n t e) = do
emit $ glslType t
emit " "
emit n
emit " = "
glslExpr e
emit ";\n"
glslStmt (IR.Return e) = do
emit "__ret = "
glslExpr e
emit ";\n"
glslArith :: T.Text -> IR.IExpr -> IR.IExpr -> Ctx ()
glslArith op x y =
emit "(" >> glslExpr x >> emit ") " >> emit op >>
emit " (" >> glslExpr y >> emit ")"
glslExpr :: IR.IExpr -> Ctx ()
glslExpr (IR.Add x y) = glslArith "+" x y
glslExpr (IR.Mul x y) = glslArith "*" x y
glslExpr (IR.Sub x y) = glslArith "-" x y
glslExpr (IR.Div x y) = glslArith "/" x y
glslExpr (IR.Lt x y) = glslArith "<" x y
glslExpr (IR.Gt x y) = glslArith ">" x y
glslExpr (IR.LtE x y) = glslArith "<=" x y
glslExpr (IR.GtE x y) = glslArith ">=" x y
glslExpr (IR.Negate x) = emit "-(" >> glslExpr x >> emit ")"
glslExpr (IR.Boolean b) = emit (if b then "true" else "false")
glslExpr (IR.Atomic (IR.Name n)) = emit $ glslName n
glslExpr (IR.Atomic (IR.InFloat f)) = emit . T.pack $ showGFloatAlt Nothing f ""
glslExpr (IR.Atomic (IR.InInt i)) = emitShow i
glslExpr (IR.Builtin f args) = do
emit f
emit "("
sequence $ intersperse (emit ", ") (map glslExpr args)
emit ")"
glslExpr (IR.Ternary c t f) = do
emit "("
glslExpr c
emit " ? "
glslExpr t
emit " : "
glslExpr f
emit ")"
glslExpr (IR.Index e i) = do
emit "("
glslExpr e
emit ")["
emitShow i
emit "]"