{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.TypeEnum.TypeValues (typeValues) where

import Language.Haskell.TH
import Data.Proxy
import Data.Char

typeValues :: String -> String -> [String] -> Q [Dec]
typeValues :: String -> String -> [String] -> Q [Dec]
typeValues String
mdl String
tp [String]
elms =
	(\[Dec]
a [Dec]
b [Dec]
c -> [Dec]
a [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
b [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
c)	
		([Dec] -> [Dec] -> [Dec] -> [Dec])
-> Q [Dec] -> Q ([Dec] -> [Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: []) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> Q Dec
mkType String
tp [String]
elms)
		Q ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((:)	(Dec -> [Dec] -> [Dec]) -> Q Dec -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> Q Dec
mkClass String
mdl String
tp
				Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [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 (String -> String -> String -> Q Dec
mkInstance String
mdl String
tp (String -> Q Dec) -> [String] -> [Q Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
elms))
		Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [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 [
			String -> String -> Q Dec
sigFoo String
mdl String
tp,
			Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
hd Char -> Char
toLower String
tp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ToType") (String -> Q Clause
foo (String -> Q Clause) -> [String] -> [Q Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
elms) ]

mkType :: String -> [String] -> Q Dec
mkType :: String -> [String] -> Q Dec
mkType String
tp [String]
elms = Q Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Kind
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Kind
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD (Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (String -> Name
mkName String
tp) [] Maybe Kind
forall a. Maybe a
Nothing
	((Name -> [Q BangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
`normalC` []) (Name -> Q Con) -> (String -> Name) -> String -> Q Con
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Con) -> [String] -> [Q Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
elms) [Maybe DerivStrategy -> [Q Kind] -> Q DerivClause
forall (m :: * -> *).
Quote m =>
Maybe DerivStrategy -> [m Kind] -> m DerivClause
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Show]]

mkClass :: String -> String -> Q Dec
mkClass :: String -> String -> Q Dec
mkClass String
mdl String
tp = do
	Name
t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
	Q Cxt
-> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [m Dec] -> m Dec
classD ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
tp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ToValue")
		[Name -> Kind -> TyVarBndr BndrVis
forall flag. DefaultBndrFlag flag => Name -> Kind -> TyVarBndr flag
kindedTV Name
t (Name -> Kind
ConT (Name -> Kind) -> Name -> Kind
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
tp)]
		[]
		[Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
hd Char -> Char
toLower String
tp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ToValue") (Q Kind -> Q Dec) -> (String -> Q Kind) -> String -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT (Name -> Q Kind) -> (String -> Name) -> String -> Q Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Dec) -> String -> Q Dec
forall a b. (a -> b) -> a -> b
$ String
mdl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tp]

hd :: (a -> a) -> [a] -> [a]
hd :: forall a. (a -> a) -> [a] -> [a]
hd a -> a
_ [] = []
hd a -> a
f (a
x : [a]
xs) = a -> a
f a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs

mkInstance :: String -> String -> String -> Q Dec
mkInstance :: String -> String -> String -> Q Dec
mkInstance String
mdl String
tp String
ss =
	Q Cxt -> Q Kind -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD (Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
tp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ToValue") Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
promotedT (String -> Name
mkName String
ss)) [
		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) -> (String -> Name) -> String -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Pat) -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
hd Char -> Char
toLower String
tp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ToValue")
			(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> (String -> Q Exp) -> String -> Q Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Body) -> String -> Q Body
forall a b. (a -> b) -> a -> b
$ String
mdl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ss) []
		]

sigFoo :: String -> String -> Q Dec
sigFoo :: String -> String -> Q Dec
sigFoo String
mdl String
tp = do
	Name
t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
	Name
a <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
	TyVarBndr Specificity
tv <- Name -> Specificity -> Q Kind -> Q (TyVarBndr Specificity)
forall (m :: * -> *).
Quote m =>
Name -> Specificity -> m Kind -> m (TyVarBndr Specificity)
kindedInvisTV Name
t Specificity
SpecifiedSpec (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT (Name -> Q Kind) -> Name -> Q Kind
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
tp)
	Name -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
hd Char -> Char
toLower String
tp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ToType")
		(Q Kind -> Q Dec) -> Q Kind -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
mdl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tp)
			Q Kind -> Q Kind -> Q Kind
`arrT` (([TyVarBndr Specificity] -> Q Cxt -> Q Kind -> Q Kind
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT [TyVarBndr Specificity
tv]
				([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt [Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
tp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ToValue") Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t])
				((Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Proxy Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
t) Q Kind -> Q Kind -> Q Kind
`arrT` Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
a))
		Q Kind -> Q Kind -> Q Kind
`arrT` Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
varT Name
a)

foo :: String -> Q Clause
foo :: String -> Q Clause
foo String
nm = do
	Name
f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
	[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
		[Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"E." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm) [], Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f]
		(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
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
			(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Proxy Q Exp -> Q Kind -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Kind -> m Exp
`appTypeE` Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
promotedT (String -> Name
mkName String
nm)))
		[]

arrT :: Q Type -> Q Type -> Q Type
Q Kind
t1 arrT :: Q Kind -> Q Kind -> Q Kind
`arrT` Q Kind
t2 = Q Kind
forall (m :: * -> *). Quote m => m Kind
arrowT Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` Q Kind
t1 Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` Q Kind
t2