{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Language.SpirV.Shaderc.TH (
	glslVertexShader, glslFragmentShader, glslComputeShader ) where

import Language.Haskell.TH
import Language.Haskell.TH.Quote

import Data.Default
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

import Language.SpirV.Internal
import Language.SpirV.ShaderKind
import Language.SpirV.Shaderc
import Language.SpirV.Shaderc.CompileOptions qualified as CompileOptions

-- GLSL VERTEX SHADER

glslVertexShader :: QuasiQuoter
glslVertexShader :: QuasiQuoter
glslVertexShader = forall (shtp :: ShaderKind).
IsShaderKind shtp =>
String -> Name -> ByteString -> QuasiQuoter
generalShader @'GlslVertexShader
	String
"glslVertexShaderMain" 'GlslVertexShader ByteString
"glslVertexShader"

-- GLSL FRAGMENT SHADER

glslFragmentShader :: QuasiQuoter
glslFragmentShader :: QuasiQuoter
glslFragmentShader = forall (shtp :: ShaderKind).
IsShaderKind shtp =>
String -> Name -> ByteString -> QuasiQuoter
generalShader @'GlslFragmentShader
	String
"glslFragmentShaderMain" 'GlslFragmentShader ByteString
"glslFragmentShader"

-- GLSL COMPUTE SHADER

glslComputeShader :: QuasiQuoter
glslComputeShader :: QuasiQuoter
glslComputeShader = forall (shtp :: ShaderKind).
IsShaderKind shtp =>
String -> Name -> ByteString -> QuasiQuoter
generalShader @'GlslComputeShader
	String
"glslComputeShaderMain" 'GlslComputeShader ByteString
"glslComputeShader"

-- GENERAL

generalShader :: forall shtp . IsShaderKind shtp => String -> Name -> BS.ByteString -> QuasiQuoter
generalShader :: forall (shtp :: ShaderKind).
IsShaderKind shtp =>
String -> Name -> ByteString -> QuasiQuoter
generalShader String
var Name
shtp ByteString
shnm = QuasiQuoter {
	quoteExp :: String -> Q Exp
quoteExp = forall (shtp :: ShaderKind).
IsShaderKind shtp =>
Name -> ByteString -> String -> Q Exp
generalShaderExp @shtp Name
shtp ByteString
shnm,
	quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"not defined",
	quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"not defined",
	quoteDec :: String -> Q [Dec]
quoteDec = forall (shtp :: ShaderKind).
IsShaderKind shtp =>
String -> Name -> ByteString -> String -> Q [Dec]
generalShaderDec @shtp String
var Name
shtp ByteString
shnm }

generalShaderExp :: forall shtp . IsShaderKind shtp => Name -> BS.ByteString -> String -> ExpQ
generalShaderExp :: forall (shtp :: ShaderKind).
IsShaderKind shtp =>
Name -> ByteString -> String -> Q Exp
generalShaderExp Name
shtp ByteString
shnm =
	Q Type -> (ByteString -> IO ByteString) -> String -> Q Exp
mkShaderExp (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''S Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
shtp) ((ByteString -> IO ByteString) -> String -> Q Exp)
-> (ByteString -> IO ByteString) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ forall (shtp :: ShaderKind).
IsShaderKind shtp =>
ByteString -> ByteString -> IO ByteString
compileGeneralShader @shtp ByteString
shnm

generalShaderDec :: forall shtp . IsShaderKind shtp => String -> Name -> BS.ByteString -> String -> DecsQ
generalShaderDec :: forall (shtp :: ShaderKind).
IsShaderKind shtp =>
String -> Name -> ByteString -> String -> Q [Dec]
generalShaderDec String
var Name
shtp ByteString
shnm =
	String
-> Q Type -> (ByteString -> IO ByteString) -> String -> Q [Dec]
mkShaderDec String
var (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''S Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
shtp) ((ByteString -> IO ByteString) -> String -> Q [Dec])
-> (ByteString -> IO ByteString) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ forall (shtp :: ShaderKind).
IsShaderKind shtp =>
ByteString -> ByteString -> IO ByteString
compileGeneralShader @shtp ByteString
shnm

compileGeneralShader :: forall shtp . IsShaderKind shtp =>  BS.ByteString -> BS.ByteString -> IO BS.ByteString
compileGeneralShader :: forall (shtp :: ShaderKind).
IsShaderKind shtp =>
ByteString -> ByteString -> IO ByteString
compileGeneralShader ByteString
nm ByteString
src = (\(S ByteString
spv :: S shtp) -> ByteString
spv)
	(S shtp -> ByteString) -> IO (S shtp) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> ByteString -> ByteString -> C () -> IO (S shtp)
forall ud (sknd :: ShaderKind).
(Storable ud, IsShaderKind sknd) =>
ByteString -> ByteString -> ByteString -> C ud -> IO (S sknd)
compile ByteString
src ByteString
nm ByteString
"main" (C ()
forall a. Default a => a
def :: CompileOptions.C ())

-- BASE

mkShaderExp :: TypeQ -> (BS.ByteString -> IO BS.ByteString) -> String -> ExpQ
mkShaderExp :: Q Type -> (ByteString -> IO ByteString) -> String -> Q Exp
mkShaderExp Q Type
typ ByteString -> IO ByteString
cmp String
src =
	(Q Exp -> Q Type -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`sigE` Q Type
typ) (Q Exp -> Q Exp) -> (ByteString -> Q Exp) -> ByteString -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (ByteString -> Lit) -> ByteString -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL (String -> Lit) -> (ByteString -> String) -> ByteString -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack (ByteString -> Q Exp) -> Q ByteString -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString -> Q ByteString
forall a. IO a -> Q a
runIO (ByteString -> IO ByteString
cmp (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSC.pack String
src)

mkShaderDec ::
	String -> TypeQ -> (BS.ByteString -> IO BS.ByteString) -> String -> DecsQ
mkShaderDec :: String
-> Q Type -> (ByteString -> IO ByteString) -> String -> Q [Dec]
mkShaderDec String
nm Q Type
tp ByteString -> IO ByteString
cmp String
src = [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [
	Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD (String -> Name
mkName String
nm) Q Type
tp,
	Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name -> Q Pat) -> Name -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
nm) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Q Type -> (ByteString -> IO ByteString) -> String -> Q Exp
mkShaderExp Q Type
tp ByteString -> IO ByteString
cmp String
src) [] ]