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

module Gpu.Vulkan.PhysicalDevice.Struct.Th (
	vkPhysicalDeviceLimits, vkPhysicalDeviceFeatures,
	DeviceSize(..), Size(..),

	vkPhysicalDeviceData, vkPhysicalDeviceFromFunBody ) where

import Language.Haskell.TH
import Control.Arrow
import Control.Monad
import Data.Foldable
import Data.Maybe
import Data.List.Length
import Data.Word
import Data.Int
import Data.Char

import Gpu.Vulkan.Middle.Types
import Gpu.Vulkan.Base.Middle.Internal

import qualified Gpu.Vulkan.Sample.Enum as Sample

import qualified Gpu.Vulkan.Device.Middle.Types as Device

newtype DeviceSize = DeviceSize { DeviceSize -> Word64
unDeviceSize :: Word64 }
	deriving (Int -> DeviceSize -> ShowS
[DeviceSize] -> ShowS
DeviceSize -> String
(Int -> DeviceSize -> ShowS)
-> (DeviceSize -> String)
-> ([DeviceSize] -> ShowS)
-> Show DeviceSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeviceSize -> ShowS
showsPrec :: Int -> DeviceSize -> ShowS
$cshow :: DeviceSize -> String
show :: DeviceSize -> String
$cshowList :: [DeviceSize] -> ShowS
showList :: [DeviceSize] -> ShowS
Show, DeviceSize -> DeviceSize -> Bool
(DeviceSize -> DeviceSize -> Bool)
-> (DeviceSize -> DeviceSize -> Bool) -> Eq DeviceSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DeviceSize -> DeviceSize -> Bool
== :: DeviceSize -> DeviceSize -> Bool
$c/= :: DeviceSize -> DeviceSize -> Bool
/= :: DeviceSize -> DeviceSize -> Bool
Eq, Eq DeviceSize
Eq DeviceSize =>
(DeviceSize -> DeviceSize -> Ordering)
-> (DeviceSize -> DeviceSize -> Bool)
-> (DeviceSize -> DeviceSize -> Bool)
-> (DeviceSize -> DeviceSize -> Bool)
-> (DeviceSize -> DeviceSize -> Bool)
-> (DeviceSize -> DeviceSize -> DeviceSize)
-> (DeviceSize -> DeviceSize -> DeviceSize)
-> Ord DeviceSize
DeviceSize -> DeviceSize -> Bool
DeviceSize -> DeviceSize -> Ordering
DeviceSize -> DeviceSize -> DeviceSize
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DeviceSize -> DeviceSize -> Ordering
compare :: DeviceSize -> DeviceSize -> Ordering
$c< :: DeviceSize -> DeviceSize -> Bool
< :: DeviceSize -> DeviceSize -> Bool
$c<= :: DeviceSize -> DeviceSize -> Bool
<= :: DeviceSize -> DeviceSize -> Bool
$c> :: DeviceSize -> DeviceSize -> Bool
> :: DeviceSize -> DeviceSize -> Bool
$c>= :: DeviceSize -> DeviceSize -> Bool
>= :: DeviceSize -> DeviceSize -> Bool
$cmax :: DeviceSize -> DeviceSize -> DeviceSize
max :: DeviceSize -> DeviceSize -> DeviceSize
$cmin :: DeviceSize -> DeviceSize -> DeviceSize
min :: DeviceSize -> DeviceSize -> DeviceSize
Ord, Int -> DeviceSize
DeviceSize -> Int
DeviceSize -> [DeviceSize]
DeviceSize -> DeviceSize
DeviceSize -> DeviceSize -> [DeviceSize]
DeviceSize -> DeviceSize -> DeviceSize -> [DeviceSize]
(DeviceSize -> DeviceSize)
-> (DeviceSize -> DeviceSize)
-> (Int -> DeviceSize)
-> (DeviceSize -> Int)
-> (DeviceSize -> [DeviceSize])
-> (DeviceSize -> DeviceSize -> [DeviceSize])
-> (DeviceSize -> DeviceSize -> [DeviceSize])
-> (DeviceSize -> DeviceSize -> DeviceSize -> [DeviceSize])
-> Enum DeviceSize
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: DeviceSize -> DeviceSize
succ :: DeviceSize -> DeviceSize
$cpred :: DeviceSize -> DeviceSize
pred :: DeviceSize -> DeviceSize
$ctoEnum :: Int -> DeviceSize
toEnum :: Int -> DeviceSize
$cfromEnum :: DeviceSize -> Int
fromEnum :: DeviceSize -> Int
$cenumFrom :: DeviceSize -> [DeviceSize]
enumFrom :: DeviceSize -> [DeviceSize]
$cenumFromThen :: DeviceSize -> DeviceSize -> [DeviceSize]
enumFromThen :: DeviceSize -> DeviceSize -> [DeviceSize]
$cenumFromTo :: DeviceSize -> DeviceSize -> [DeviceSize]
enumFromTo :: DeviceSize -> DeviceSize -> [DeviceSize]
$cenumFromThenTo :: DeviceSize -> DeviceSize -> DeviceSize -> [DeviceSize]
enumFromThenTo :: DeviceSize -> DeviceSize -> DeviceSize -> [DeviceSize]
Enum, Integer -> DeviceSize
DeviceSize -> DeviceSize
DeviceSize -> DeviceSize -> DeviceSize
(DeviceSize -> DeviceSize -> DeviceSize)
-> (DeviceSize -> DeviceSize -> DeviceSize)
-> (DeviceSize -> DeviceSize -> DeviceSize)
-> (DeviceSize -> DeviceSize)
-> (DeviceSize -> DeviceSize)
-> (DeviceSize -> DeviceSize)
-> (Integer -> DeviceSize)
-> Num DeviceSize
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: DeviceSize -> DeviceSize -> DeviceSize
+ :: DeviceSize -> DeviceSize -> DeviceSize
$c- :: DeviceSize -> DeviceSize -> DeviceSize
- :: DeviceSize -> DeviceSize -> DeviceSize
$c* :: DeviceSize -> DeviceSize -> DeviceSize
* :: DeviceSize -> DeviceSize -> DeviceSize
$cnegate :: DeviceSize -> DeviceSize
negate :: DeviceSize -> DeviceSize
$cabs :: DeviceSize -> DeviceSize
abs :: DeviceSize -> DeviceSize
$csignum :: DeviceSize -> DeviceSize
signum :: DeviceSize -> DeviceSize
$cfromInteger :: Integer -> DeviceSize
fromInteger :: Integer -> DeviceSize
Num, Num DeviceSize
Ord DeviceSize
(Num DeviceSize, Ord DeviceSize) =>
(DeviceSize -> Rational) -> Real DeviceSize
DeviceSize -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: DeviceSize -> Rational
toRational :: DeviceSize -> Rational
Real, Enum DeviceSize
Real DeviceSize
(Real DeviceSize, Enum DeviceSize) =>
(DeviceSize -> DeviceSize -> DeviceSize)
-> (DeviceSize -> DeviceSize -> DeviceSize)
-> (DeviceSize -> DeviceSize -> DeviceSize)
-> (DeviceSize -> DeviceSize -> DeviceSize)
-> (DeviceSize -> DeviceSize -> (DeviceSize, DeviceSize))
-> (DeviceSize -> DeviceSize -> (DeviceSize, DeviceSize))
-> (DeviceSize -> Integer)
-> Integral DeviceSize
DeviceSize -> Integer
DeviceSize -> DeviceSize -> (DeviceSize, DeviceSize)
DeviceSize -> DeviceSize -> DeviceSize
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
$cquot :: DeviceSize -> DeviceSize -> DeviceSize
quot :: DeviceSize -> DeviceSize -> DeviceSize
$crem :: DeviceSize -> DeviceSize -> DeviceSize
rem :: DeviceSize -> DeviceSize -> DeviceSize
$cdiv :: DeviceSize -> DeviceSize -> DeviceSize
div :: DeviceSize -> DeviceSize -> DeviceSize
$cmod :: DeviceSize -> DeviceSize -> DeviceSize
mod :: DeviceSize -> DeviceSize -> DeviceSize
$cquotRem :: DeviceSize -> DeviceSize -> (DeviceSize, DeviceSize)
quotRem :: DeviceSize -> DeviceSize -> (DeviceSize, DeviceSize)
$cdivMod :: DeviceSize -> DeviceSize -> (DeviceSize, DeviceSize)
divMod :: DeviceSize -> DeviceSize -> (DeviceSize, DeviceSize)
$ctoInteger :: DeviceSize -> Integer
toInteger :: DeviceSize -> Integer
Integral)

vkPhysicalDeviceLimits :: DecsQ
vkPhysicalDeviceLimits :: DecsQ
vkPhysicalDeviceLimits = String -> DecsQ
makeData String
"Limits"

vkPhysicalDeviceFeatures :: DecsQ
vkPhysicalDeviceFeatures :: DecsQ
vkPhysicalDeviceFeatures = String -> DecsQ
makeData String
"Features"

makeData :: String -> DecsQ
makeData :: String -> DecsQ
makeData String
dtnm = (\Dec
dt Dec
sg Dec
bd Dec
tsg Dec
tbd -> [Dec
dt, Dec
sg, Dec
bd, Dec
tsg, Dec
tbd])
	(Dec -> Dec -> Dec -> Dec -> Dec -> [Dec])
-> Q Dec -> Q (Dec -> Dec -> Dec -> Dec -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Dec
vkPhysicalDeviceData String
dtnm
	Q (Dec -> Dec -> Dec -> Dec -> [Dec])
-> Q Dec -> Q (Dec -> Dec -> 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
<*> String -> Q Dec
vkPhysicalDeviceFromFunSig String
dtnm
	Q (Dec -> Dec -> Dec -> [Dec]) -> Q Dec -> Q (Dec -> 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
<*> String -> Q Dec
vkPhysicalDeviceFromFunBody String
dtnm
	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
<*> String -> Q Dec
vkPhysicalDeviceToFunSig String
dtnm
	Q (Dec -> [Dec]) -> Q Dec -> DecsQ
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Q Dec
vkPhysicalDeviceToFunBody String
dtnm

vkPhysicalDeviceData :: String -> DecQ
vkPhysicalDeviceData :: String -> Q Dec
vkPhysicalDeviceData String
dtnm = do
	ds <- IO [(String, FieldName)] -> Q [(String, FieldName)]
forall a. IO a -> Q a
runIO (IO [(String, FieldName)] -> Q [(String, FieldName)])
-> IO [(String, FieldName)] -> Q [(String, FieldName)]
forall a b. (a -> b) -> a -> b
$ String -> IO [(String, FieldName)]
readStructData String
dtnm
	dataD (cxt []) (mkName dtnm) [] Nothing [recC (mkName dtnm)
		(uncurry (member dtnm) <$> ds)] [derivClause Nothing [conT ''Show]]

dict :: Dict
dict :: Dict
dict = DictGen -> Dict
dictGenToDict DictGen
dictGen

dictGenToDict :: DictGen -> Dict
dictGenToDict :: DictGen -> Dict
dictGenToDict = ((String, (Q Kind, Name -> ExpQ), (Name -> PatQ, Name -> ExpQ))
 -> (String, (Q Kind, Name -> ExpQ)))
-> DictGen -> Dict
forall a b. (a -> b) -> [a] -> [b]
map \(String
tp, (Q Kind, Name -> ExpQ)
tfr, (Name -> PatQ, Name -> ExpQ)
_to) -> (String
tp, (Q Kind, Name -> ExpQ)
tfr)

dict2 :: Dict2
dict2 :: Dict2
dict2 = DictGen -> Dict2
dictGenToDict2 DictGen
dictGen

dictGenToDict2 :: DictGen -> Dict2
dictGenToDict2 :: DictGen -> Dict2
dictGenToDict2 = ((String, (Q Kind, Name -> ExpQ), (Name -> PatQ, Name -> ExpQ))
 -> (String, (Name -> PatQ, Name -> ExpQ)))
-> DictGen -> Dict2
forall a b. (a -> b) -> [a] -> [b]
map \(String
tp, (Q Kind, Name -> ExpQ)
_tfr, (Name -> PatQ, Name -> ExpQ)
to) -> (String
tp, (Name -> PatQ, Name -> ExpQ)
to)

type Dict = [(String, (TypeQ, Name -> ExpQ))]
type Dict2 = [(String, (Name -> PatQ, Name -> ExpQ))]
type DictGen = [(String, (TypeQ, Name -> ExpQ), (Name -> PatQ, Name -> ExpQ))]

dictGen :: [(String, (TypeQ, Name -> ExpQ), (Name -> PatQ, Name -> ExpQ))]
dictGen :: DictGen
dictGen = [
	(String
"uint32_t", (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Word32, Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE), (Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP, Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE)),
	(String
"int32_t", (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Int32, Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE), (Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP, Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE)),
	(String
"float", (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Float, Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE), (Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP, Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE)),
	(String
"VkBool32", (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Bool, ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'bool32ToBool) (ExpQ -> ExpQ) -> (Name -> ExpQ) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE),
		(Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP, ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'boolToBool32) (ExpQ -> ExpQ) -> (Name -> ExpQ) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE)),
	(String
"size_t", (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Size, ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Size) (ExpQ -> ExpQ) -> (Name -> ExpQ) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE),
		(Name -> [PatQ] -> PatQ
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Size ([PatQ] -> PatQ) -> (Name -> [PatQ]) -> Name -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: []) (PatQ -> [PatQ]) -> (Name -> PatQ) -> Name -> [PatQ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP, Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE)),
	(String
"VkDeviceSize", (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Device.Size, ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Device.Size) (ExpQ -> ExpQ) -> (Name -> ExpQ) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE),
		(Name -> [PatQ] -> PatQ
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Device.Size ([PatQ] -> PatQ) -> (Name -> [PatQ]) -> Name -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: []) (PatQ -> [PatQ]) -> (Name -> PatQ) -> Name -> [PatQ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP, Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE)),
	(String
"VkSampleCountFlags",
		(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Sample.CountFlags,
			ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Sample.CountFlagBits) (ExpQ -> ExpQ) -> (Name -> ExpQ) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE),
		(Name -> [PatQ] -> PatQ
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Sample.CountFlagBits ([PatQ] -> PatQ) -> (Name -> [PatQ]) -> Name -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: []) (PatQ -> [PatQ]) -> (Name -> PatQ) -> Name -> [PatQ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP, Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE)) ]

noBang :: BangQ
noBang :: BangQ
noBang = Q SourceUnpackedness -> Q SourceStrictness -> BangQ
forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang Q SourceUnpackedness
forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness Q SourceStrictness
forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness

member :: String -> String -> FieldName -> VarBangTypeQ
member :: String -> String -> FieldName -> Q VarBangType
member String
dtnm String
tp_ FieldName
fn = Name -> Q BangType -> Q VarBangType
forall (m :: * -> *).
Quote m =>
Name -> m BangType -> m VarBangType
varBangType (String -> Name
mkName String
nm) (Q BangType -> Q VarBangType) -> Q BangType -> Q VarBangType
forall a b. (a -> b) -> a -> b
$ BangQ -> Q Kind -> Q BangType
forall (m :: * -> *). Quote m => m Bang -> m Kind -> m BangType
bangType BangQ
noBang Q Kind
tp
	where
	pfx :: String
pfx = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
dtnm
	(String
nm, Q Kind
tp) = String -> String -> FieldName -> (String, Q Kind)
getNameType String
pfx String
tp_ FieldName
fn

getNameType :: String -> String -> FieldName -> (String, TypeQ)
getNameType :: String -> String -> FieldName -> (String, Q Kind)
getNameType String
pfx String
tp (Atom String
fn) = (String
pfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
fn, (Q Kind, Name -> ExpQ) -> Q Kind
forall a b. (a, b) -> a
fst ((Q Kind, Name -> ExpQ) -> Q Kind)
-> (Q Kind, Name -> ExpQ) -> Q Kind
forall a b. (a -> b) -> a -> b
$ String -> Dict -> (Q Kind, Name -> ExpQ)
forall a b. (Show a, Eq a) => a -> [(a, b)] -> b
lookup' String
tp Dict
dict)
getNameType String
pfx String
tp (List String
fn Integer
nb) = (String
pfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
fn,
	Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''LengthL Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` Q TyLit -> Q Kind
forall (m :: * -> *). Quote m => m TyLit -> m Kind
litT (Integer -> Q TyLit
forall (m :: * -> *). Quote m => Integer -> m TyLit
numTyLit Integer
nb) Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
`appT` (Q Kind, Name -> ExpQ) -> Q Kind
forall a b. (a, b) -> a
fst (String -> Dict -> (Q Kind, Name -> ExpQ)
forall a b. (Show a, Eq a) => a -> [(a, b)] -> b
lookup' String
tp Dict
dict))

lookup' :: (Show a, Eq a) => a -> [(a, b)] -> b
lookup' :: forall a b. (Show a, Eq a) => a -> [(a, b)] -> b
lookup' a
x [(a, b)]
d = case a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
x [(a, b)]
d of
	Maybe b
Nothing -> String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ String
"no such key: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
	Just b
y -> b
y

capitalize :: String -> String
capitalize :: ShowS
capitalize String
"" = String
""
capitalize (Char
c : String
cs) = Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs

readStructData :: String -> IO [(String, FieldName)]
readStructData :: String -> IO [(String, FieldName)]
readStructData String
dtnm = (String -> (String, FieldName))
-> [String] -> [(String, FieldName)]
forall a b. (a -> b) -> [a] -> [b]
map ((ShowS
forall a. a -> a
id ShowS
-> (String -> FieldName) -> (String, String) -> (String, FieldName)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> FieldName
readName) ((String, String) -> (String, FieldName))
-> (String -> (String, String)) -> String -> (String, FieldName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> (String, String)
forall a. Eq a => a -> [a] -> ([a], [a])
separate Char
'|')) ([String] -> [(String, FieldName)])
-> (String -> [String]) -> String -> [(String, FieldName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [(String, FieldName)])
-> IO String -> IO [(String, FieldName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
	(String -> IO String
readFile (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"th/vkPhysicalDevice" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dtnm String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".txt")

data FieldName = Atom String | List String Integer deriving Int -> FieldName -> ShowS
[FieldName] -> ShowS
FieldName -> String
(Int -> FieldName -> ShowS)
-> (FieldName -> String)
-> ([FieldName] -> ShowS)
-> Show FieldName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldName -> ShowS
showsPrec :: Int -> FieldName -> ShowS
$cshow :: FieldName -> String
show :: FieldName -> String
$cshowList :: [FieldName] -> ShowS
showList :: [FieldName] -> ShowS
Show

readName :: String -> FieldName
readName :: String -> FieldName
readName (Char
'A' : Char
' ' : String
nm) = String -> FieldName
Atom String
nm
readName (Char
'L' : Char
' ' : String
nmnb) = let [String
nm, String
nb] = String -> [String]
words String
nmnb in String -> Integer -> FieldName
List String
nm (String -> Integer
forall a. Read a => String -> a
read String
nb)
readName String
_ = String -> FieldName
forall a. HasCallStack => String -> a
error String
"bad"

separate :: Eq a => a -> [a] -> ([a], [a])
separate :: forall a. Eq a => a -> [a] -> ([a], [a])
separate a
c [a]
str = case (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
c) [a]
str of
	([a]
pre, a
_ : [a]
pst) -> ([a]
pre, [a]
pst)
	([a], [a])
_ -> String -> ([a], [a])
forall a. HasCallStack => String -> a
error String
"no separater"

vkPhysicalDeviceFromFunSig :: String -> DecQ
vkPhysicalDeviceFromFunSig :: String -> Q Dec
vkPhysicalDeviceFromFunSig String
dtnm = 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) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
dtnm String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"FromCore")
	(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 (Name -> Q Kind) -> Q Name -> Q Kind
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> Maybe Name -> Name
forall a. String -> Maybe a -> a
fromJustMsg String
"vkPhysicalDeviceFromFunSig" (Maybe Name -> Name) -> Q (Maybe Name) -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Maybe Name)
lookupTypeName (String
"C." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dtnm))) Q Kind -> Q Kind -> Q Kind
`arrT` Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT (String -> Name
mkName String
dtnm)

vkPhysicalDeviceToFunSig :: String -> DecQ
vkPhysicalDeviceToFunSig :: String -> Q Dec
vkPhysicalDeviceToFunSig String
dtnm = 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) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
dtnm String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"ToCore")
	(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
dtnm) Q Kind -> Q Kind -> Q Kind
`arrT` (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT (Name -> Q Kind) -> Q Name -> Q Kind
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> Maybe Name -> Name
forall a. String -> Maybe a -> a
fromJustMsg String
"vkPhysicalDeviceToFunSig" (Maybe Name -> Name) -> Q (Maybe Name) -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Maybe Name)
lookupTypeName (String
"C." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dtnm)))

arrT :: TypeQ -> TypeQ -> TypeQ
arrT :: Q Kind -> Q Kind -> Q Kind
arrT Q Kind
t1 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

vkPhysicalDeviceFromFunBody :: String -> DecQ
vkPhysicalDeviceFromFunBody :: String -> Q Dec
vkPhysicalDeviceFromFunBody String
dtnm = do
	ds <- IO [(String, FieldName)] -> Q [(String, FieldName)]
forall a. IO a -> Q a
runIO (IO [(String, FieldName)] -> Q [(String, FieldName)])
-> IO [(String, FieldName)] -> Q [(String, FieldName)]
forall a b. (a -> b) -> a -> b
$ String -> IO [(String, FieldName)]
readStructData String
dtnm
	xs <- replicateM (length ds) $ newName "x"
	let	fs = (\(String
tp, FieldName
_) -> String -> Name -> ExpQ
typeToFun String
tp) ((String, FieldName) -> Name -> ExpQ)
-> [(String, FieldName)] -> [Name -> ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, FieldName)]
ds
		nvs = [FieldName] -> [Name] -> [(FieldName, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((String, FieldName) -> FieldName)
-> [(String, FieldName)] -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map (String, FieldName) -> FieldName
forall a b. (a, b) -> b
snd [(String, FieldName)]
ds) [Name]
xs
		nws = [(FieldName, Name)]
-> [Name -> ExpQ] -> [((FieldName, Name), Name -> ExpQ)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([FieldName] -> [Name] -> [(FieldName, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((String, FieldName) -> FieldName)
-> [(String, FieldName)] -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map (String, FieldName) -> FieldName
forall a b. (a, b) -> b
snd [(String, FieldName)]
ds) [Name]
xs) [Name -> ExpQ]
fs
	funD (mkName $ map toLower dtnm ++ "FromCore") [
		clause [(`recP` exFieldPats dtnm nvs) =<< fromJustMsg "vkPhysicalDeviceFromFunBody" <$> lookupValueName' ("C." ++ dtnm)]
			(normalB $ recConE (mkName dtnm) (exFieldExps dtnm nws)) []
		]

vkPhysicalDeviceToFunBody :: String -> DecQ
vkPhysicalDeviceToFunBody :: String -> Q Dec
vkPhysicalDeviceToFunBody String
dtnm = do
	ds <- IO [(String, FieldName)] -> Q [(String, FieldName)]
forall a. IO a -> Q a
runIO (IO [(String, FieldName)] -> Q [(String, FieldName)])
-> IO [(String, FieldName)] -> Q [(String, FieldName)]
forall a b. (a -> b) -> a -> b
$ String -> IO [(String, FieldName)]
readStructData String
dtnm
	xs <- replicateM (length ds) $ newName "x"
	let	pes = (\(String
tp, FieldName
_) -> String -> (Name -> PatQ, Name -> ExpQ)
typeToPatExp String
tp) ((String, FieldName) -> (Name -> PatQ, Name -> ExpQ))
-> [(String, FieldName)] -> [(Name -> PatQ, Name -> ExpQ)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, FieldName)]
ds
		nvs = [(FieldName, Name)]
-> [(Name -> PatQ, Name -> ExpQ)]
-> [((FieldName, Name), (Name -> PatQ, Name -> ExpQ))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([FieldName] -> [Name] -> [(FieldName, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((String, FieldName) -> FieldName)
-> [(String, FieldName)] -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map (String, FieldName) -> FieldName
forall a b. (a, b) -> b
snd [(String, FieldName)]
ds) [Name]
xs) [(Name -> PatQ, Name -> ExpQ)]
pes
	funD (mkName $ map toLower dtnm ++ "ToCore") [
		clause [(recP (mkName dtnm) $ toFieldPats dtnm nvs)]
			(normalB $ (`recConE` toFieldExps dtnm nvs) =<< fromJustMsg "vkPhysicalDeviceToFunBody" <$> lookupValueName' ("C." ++ dtnm)) []]

typeToFun :: String -> (Name -> ExpQ)
typeToFun :: String -> Name -> ExpQ
typeToFun String
nm = let Just (Q Kind
_, Name -> ExpQ
f) = String -> Dict -> Maybe (Q Kind, Name -> ExpQ)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
nm Dict
dict in Name -> ExpQ
f

exFieldPats :: String -> [(FieldName, Name)] -> [Q FieldPat]
exFieldPats :: String -> [(FieldName, Name)] -> [Q FieldPat]
exFieldPats String
dtnm = ((FieldName, Name) -> Q FieldPat)
-> [(FieldName, Name)] -> [Q FieldPat]
forall a b. (a -> b) -> [a] -> [b]
map (((FieldName, Name) -> Q FieldPat)
 -> [(FieldName, Name)] -> [Q FieldPat])
-> ((FieldName, Name) -> Q FieldPat)
-> [(FieldName, Name)]
-> [Q FieldPat]
forall a b. (a -> b) -> a -> b
$ (FieldName -> Name -> Q FieldPat)
-> (FieldName, Name) -> Q FieldPat
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> FieldName -> Name -> Q FieldPat
exFieldPat1 (String -> FieldName -> Name -> Q FieldPat)
-> String -> FieldName -> Name -> Q FieldPat
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
dtnm)

exFieldPat1 :: String -> FieldName -> Name -> Q FieldPat
exFieldPat1 :: String -> FieldName -> Name -> Q FieldPat
exFieldPat1 String
pfx FieldName
fn Name
x = do
	let	nm :: String
nm = case FieldName
fn of
			Atom String
n -> String
n
			List String
n Integer
_ -> String
n
	n <- String -> Maybe Name -> Name
forall a. String -> Maybe a -> a
fromJustMsg (String -> ShowS
forall {a} {a}. (Show a, Show a) => a -> a -> String
mkMsg String
pfx String
nm) (Maybe Name -> Name) -> Q (Maybe Name) -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Maybe Name)
lookupValueName' (String
"C." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
nm)
	fieldPat n (varP x)
	where
	mkMsg :: a -> a -> String
mkMsg a
p a
n = String
"exFieldPat1: pfx = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" nm = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n

exFieldExps :: String -> [((FieldName, Name), Name -> ExpQ)] -> [Q (Name, Exp)]
exFieldExps :: String -> [((FieldName, Name), Name -> ExpQ)] -> [Q (Name, Exp)]
exFieldExps String
dtnm = (((FieldName, Name), Name -> ExpQ) -> Q (Name, Exp))
-> [((FieldName, Name), Name -> ExpQ)] -> [Q (Name, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ((((FieldName, Name), Name -> ExpQ) -> Q (Name, Exp))
 -> [((FieldName, Name), Name -> ExpQ)] -> [Q (Name, Exp)])
-> (((FieldName, Name) -> (Name -> ExpQ) -> Q (Name, Exp))
    -> ((FieldName, Name), Name -> ExpQ) -> Q (Name, Exp))
-> ((FieldName, Name) -> (Name -> ExpQ) -> Q (Name, Exp))
-> [((FieldName, Name), Name -> ExpQ)]
-> [Q (Name, Exp)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldName, Name) -> (Name -> ExpQ) -> Q (Name, Exp))
-> ((FieldName, Name), Name -> ExpQ) -> Q (Name, Exp)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (((FieldName, Name) -> (Name -> ExpQ) -> Q (Name, Exp))
 -> [((FieldName, Name), Name -> ExpQ)] -> [Q (Name, Exp)])
-> ((FieldName, Name) -> (Name -> ExpQ) -> Q (Name, Exp))
-> [((FieldName, Name), Name -> ExpQ)]
-> [Q (Name, Exp)]
forall a b. (a -> b) -> a -> b
$ (FieldName -> Name -> (Name -> ExpQ) -> Q (Name, Exp))
-> (FieldName, Name) -> (Name -> ExpQ) -> Q (Name, Exp)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> FieldName -> Name -> (Name -> ExpQ) -> Q (Name, Exp)
exFieldExp1 (String -> FieldName -> Name -> (Name -> ExpQ) -> Q (Name, Exp))
-> String -> FieldName -> Name -> (Name -> ExpQ) -> Q (Name, Exp)
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
dtnm)

listToLengthL :: ListToLengthL n => [a] -> LengthL n a
listToLengthL :: forall (n :: Natural) a. ListToLengthL n => [a] -> LengthL n a
listToLengthL [a]
xs = case [a] -> Either (RangeL 0 (n - 1) a) (LengthL n a, [a])
forall (n :: Natural) a.
ListToLengthL n =>
[a] -> Either (RangeL 0 (n - 1) a) (LengthL n a, [a])
forall a. [a] -> Either (RangeL 0 (n - 1) a) (LengthL n a, [a])
splitL [a]
xs of
	Right (LengthL n a
ln, []) -> LengthL n a
ln
	Either (RangeL 0 (n - 1) a) (LengthL n a, [a])
_ -> String -> LengthL n a
forall a. HasCallStack => String -> a
error String
"bad"

exFieldExp1 :: String -> FieldName -> Name -> (Name -> ExpQ) -> Q (Name, Exp)
exFieldExp1 :: String -> FieldName -> Name -> (Name -> ExpQ) -> Q (Name, Exp)
exFieldExp1 String
pfx (Atom String
nm) Name
x Name -> ExpQ
f = Name -> ExpQ -> Q (Name, Exp)
forall (m :: * -> *). Quote m => Name -> m Exp -> m (Name, Exp)
fieldExp (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
pfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
nm) (Name -> ExpQ
f Name
x)
exFieldExp1 String
pfx (List String
nm Integer
_) Name
x Name -> ExpQ
f = do
	y <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
	fieldExp (mkName $ pfx ++ capitalize nm)
		. appE (varE 'listToLengthL) $ lam1E (varP y) (f y) .<$> varE x

(.<$>) :: ExpQ -> ExpQ -> ExpQ
ExpQ
f .<$> :: ExpQ -> ExpQ -> ExpQ
.<$> ExpQ
x = ExpQ -> ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp ExpQ
f (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(<$>)) ExpQ
x

typeToPatExp :: String -> (Name -> PatQ, Name -> ExpQ)
typeToPatExp :: String -> (Name -> PatQ, Name -> ExpQ)
typeToPatExp = String
-> Maybe (Name -> PatQ, Name -> ExpQ)
-> (Name -> PatQ, Name -> ExpQ)
forall a. String -> Maybe a -> a
fromJustMsg String
"typeToPatExp" (Maybe (Name -> PatQ, Name -> ExpQ)
 -> (Name -> PatQ, Name -> ExpQ))
-> (String -> Maybe (Name -> PatQ, Name -> ExpQ))
-> String
-> (Name -> PatQ, Name -> ExpQ)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Dict2 -> Maybe (Name -> PatQ, Name -> ExpQ)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` Dict2
dict2)

toFieldPats :: String -> [((FieldName, Name), (Name -> PatQ, a))] -> [Q FieldPat]
toFieldPats :: forall a.
String -> [((FieldName, Name), (Name -> PatQ, a))] -> [Q FieldPat]
toFieldPats String
dtnm = (((FieldName, Name), (Name -> PatQ, a)) -> Q FieldPat)
-> [((FieldName, Name), (Name -> PatQ, a))] -> [Q FieldPat]
forall a b. (a -> b) -> [a] -> [b]
map ((((FieldName, Name), (Name -> PatQ, a)) -> Q FieldPat)
 -> [((FieldName, Name), (Name -> PatQ, a))] -> [Q FieldPat])
-> (((FieldName, Name) -> (Name -> PatQ, a) -> Q FieldPat)
    -> ((FieldName, Name), (Name -> PatQ, a)) -> Q FieldPat)
-> ((FieldName, Name) -> (Name -> PatQ, a) -> Q FieldPat)
-> [((FieldName, Name), (Name -> PatQ, a))]
-> [Q FieldPat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldName, Name) -> (Name -> PatQ, a) -> Q FieldPat)
-> ((FieldName, Name), (Name -> PatQ, a)) -> Q FieldPat
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (((FieldName, Name) -> (Name -> PatQ, a) -> Q FieldPat)
 -> [((FieldName, Name), (Name -> PatQ, a))] -> [Q FieldPat])
-> ((FieldName, Name) -> (Name -> PatQ, a) -> Q FieldPat)
-> [((FieldName, Name), (Name -> PatQ, a))]
-> [Q FieldPat]
forall a b. (a -> b) -> a -> b
$ (FieldName -> Name -> (Name -> PatQ, a) -> Q FieldPat)
-> (FieldName, Name) -> (Name -> PatQ, a) -> Q FieldPat
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> FieldName -> Name -> (Name -> PatQ, a) -> Q FieldPat
forall a.
String -> FieldName -> Name -> (Name -> PatQ, a) -> Q FieldPat
toFieldPat1 (String -> FieldName -> Name -> (Name -> PatQ, a) -> Q FieldPat)
-> String -> FieldName -> Name -> (Name -> PatQ, a) -> Q FieldPat
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
dtnm)

toFieldPat1 :: String -> FieldName -> Name -> ((Name -> PatQ), a) -> Q FieldPat
toFieldPat1 :: forall a.
String -> FieldName -> Name -> (Name -> PatQ, a) -> Q FieldPat
toFieldPat1 String
pfx (Atom String
nm) Name
x (Name -> PatQ
f, a
_) = Name -> PatQ -> Q FieldPat
forall (m :: * -> *). Quote m => Name -> m Pat -> m FieldPat
fieldPat (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
pfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
nm) (Name -> PatQ
f Name
x)
toFieldPat1 String
pfx (List String
nm Integer
_) Name
x (Name -> PatQ, a)
_ = Name -> PatQ -> Q FieldPat
forall (m :: * -> *). Quote m => Name -> m Pat -> m FieldPat
fieldPat (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
pfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
nm) (Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x)

toFieldExps :: String -> [((FieldName, Name), (Name -> PatQ, Name -> ExpQ))] -> [Q (Name, Exp)]
toFieldExps :: String
-> [((FieldName, Name), (Name -> PatQ, Name -> ExpQ))]
-> [Q (Name, Exp)]
toFieldExps String
dtnm = (((FieldName, Name), (Name -> PatQ, Name -> ExpQ))
 -> Q (Name, Exp))
-> [((FieldName, Name), (Name -> PatQ, Name -> ExpQ))]
-> [Q (Name, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ((((FieldName, Name), (Name -> PatQ, Name -> ExpQ))
  -> Q (Name, Exp))
 -> [((FieldName, Name), (Name -> PatQ, Name -> ExpQ))]
 -> [Q (Name, Exp)])
-> (((FieldName, Name)
     -> (Name -> PatQ, Name -> ExpQ) -> Q (Name, Exp))
    -> ((FieldName, Name), (Name -> PatQ, Name -> ExpQ))
    -> Q (Name, Exp))
-> ((FieldName, Name)
    -> (Name -> PatQ, Name -> ExpQ) -> Q (Name, Exp))
-> [((FieldName, Name), (Name -> PatQ, Name -> ExpQ))]
-> [Q (Name, Exp)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldName, Name)
 -> (Name -> PatQ, Name -> ExpQ) -> Q (Name, Exp))
-> ((FieldName, Name), (Name -> PatQ, Name -> ExpQ))
-> Q (Name, Exp)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (((FieldName, Name)
  -> (Name -> PatQ, Name -> ExpQ) -> Q (Name, Exp))
 -> [((FieldName, Name), (Name -> PatQ, Name -> ExpQ))]
 -> [Q (Name, Exp)])
-> ((FieldName, Name)
    -> (Name -> PatQ, Name -> ExpQ) -> Q (Name, Exp))
-> [((FieldName, Name), (Name -> PatQ, Name -> ExpQ))]
-> [Q (Name, Exp)]
forall a b. (a -> b) -> a -> b
$ (FieldName
 -> Name -> (Name -> PatQ, Name -> ExpQ) -> Q (Name, Exp))
-> (FieldName, Name)
-> (Name -> PatQ, Name -> ExpQ)
-> Q (Name, Exp)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String
-> FieldName
-> Name
-> (Name -> PatQ, Name -> ExpQ)
-> Q (Name, Exp)
toFieldExp1 (String
 -> FieldName
 -> Name
 -> (Name -> PatQ, Name -> ExpQ)
 -> Q (Name, Exp))
-> String
-> FieldName
-> Name
-> (Name -> PatQ, Name -> ExpQ)
-> Q (Name, Exp)
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
dtnm)

toFieldExp1 :: String -> FieldName -> Name -> (Name -> PatQ, Name -> ExpQ) -> Q (Name, Exp)
toFieldExp1 :: String
-> FieldName
-> Name
-> (Name -> PatQ, Name -> ExpQ)
-> Q (Name, Exp)
toFieldExp1 String
pfx (Atom String
nm) Name
x (Name -> PatQ
_, Name -> ExpQ
f) = do
	n <- String -> Maybe Name -> Name
forall a. String -> Maybe a -> a
fromJustMsg String
"toFieldExp1" (Maybe Name -> Name) -> Q (Maybe Name) -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Maybe Name)
lookupValueName' (String
"C." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
nm)
	fieldExp n (f x)
toFieldExp1 String
pfx (List String
nm Integer
_) Name
x (Name -> PatQ
pf, Name -> ExpQ
f) = do
	n <- String -> Maybe Name -> Name
forall a. String -> Maybe a -> a
fromJustMsg String
"toFieldExp1" (Maybe Name -> Name) -> Q (Maybe Name) -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Maybe Name)
lookupValueName' (String
"C." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pfx String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
capitalize String
nm)
	y <- newName "y"
	fieldExp n $ lam1E (pf y) (f y) .<$> (varE 'toList `appE` varE x)

fromJustMsg :: String -> Maybe a -> a
fromJustMsg :: forall a. String -> Maybe a -> a
fromJustMsg String
msg Maybe a
Nothing = String -> a
forall a. HasCallStack => String -> a
error String
msg
fromJustMsg String
_ (Just a
x) = a
x

lookupValueName' :: String -> Q (Maybe Name)
lookupValueName' :: String -> Q (Maybe Name)
lookupValueName' = Maybe Name -> Q (Maybe Name)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Name -> Q (Maybe Name))
-> (String -> Maybe Name) -> String -> Q (Maybe Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> (String -> Name) -> String -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName