{-# 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
	t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
	classD (cxt []) (mkName $ tp ++ "ToValue")
		[kindedTV t (ConT $ mkName tp)]
		[]
		[sigD (mkName $ hd toLower tp ++ "ToValue") . conT . mkName $ mdl ++ "." ++ 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
	t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
	a <- newName "a"
	tv <- kindedInvisTV t SpecifiedSpec (conT $ mkName tp)
	sigD (mkName $ hd toLower tp ++ "ToType")
		$ conT (mkName $ mdl ++ "." ++ tp)
			`arrT` ((forallT [tv]
				(cxt [conT (mkName $ tp ++ "ToValue") `appT` varT t])
				((conT ''Proxy `appT` varT t) `arrT` varT a))
		`arrT` varT a)

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