{-# 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 "]"