{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-}
{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.PhysicalDevice.Struct.ThTest where

import Language.Haskell.TH

import Foreign.Ptr
import Foreign.Storable.PeekPoke

import Data.TypeLevel.Maybe qualified as TMaybe
-- import Gpu.Vulkan.PhysicalDevice.Struct.Core qualified as C

import Gpu.Vulkan.Base.Middle.Internal

import qualified Gpu.Vulkan.Sample.Enum as Sample
import Data.Word
import Data.Int
import Data.List.Length
import Data.Char
import Control.Arrow
-- import Data.Maybe
import Data.Foldable
import Control.Monad

fromJust' :: String -> Maybe a -> a
fromJust' :: forall a. String -> Maybe a -> a
fromJust' String
msg = \case Maybe a
Nothing -> String -> a
forall a. HasCallStack => String -> a
error String
msg; Just a
x -> a
x

makeStructure :: String -> DecsQ
makeStructure :: String -> DecsQ
makeStructure String
nm = do
	dct <- String -> Q DictFieldName
readStructData String
nm
	sequence [
		mkData nm dct, mkDataShow nm, mkDataNoNext nm dct,
		mkFromCoreType Production nm, mkFromCoreBody Production nm dct,
		mkToCoreType Production nm, mkToCoreBody Production nm dct,
		mkFromNoNextType nm, mkFromNoNextBody nm dct ]

mkData :: String -> DictFieldName -> DecQ
mkData :: String -> DictFieldName -> Q Dec
mkData String
nm DictFieldName
dct = do
	mn <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"mn"
	let	varBangTypes = String -> String -> DictFieldName -> [VarBangTypeQ]
getVarBangTypes String
"" String
nm DictFieldName
dct
	dataD (cxt [])
		(mkName nm)
		[plainTV mn] Nothing
		[recC (mkName nm) $
			(varBangType (mkName $ nm' ++ "Next")
				(bangType noBang
					(conT ''TMaybe.M `appT` varT mn))) :
			(drop 2 varBangTypes)] []
	where nm' :: String
nm' = (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
appHead Char -> Char
toLower String
nm

mkDataShow :: String -> DecQ
mkDataShow :: String -> Q Dec
mkDataShow String
nm = Q Cxt -> Q Kind -> Q Dec
forall (m :: * -> *). Quote m => m Cxt -> m Kind -> m Dec
standaloneDerivD
	([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt [Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Show 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
conT ''TMaybe.M 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 (String -> Name
mkName String
"mn"))])
	(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''Show 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
conT (String -> Name
mkName String
nm) 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 (String -> Name
mkName String
"mn")))

mkDataNoNext :: String -> DictFieldName -> DecQ
mkDataNoNext :: String -> DictFieldName -> Q Dec
mkDataNoNext String
nm DictFieldName
dct = do
	let	varBangTypes :: [VarBangTypeQ]
varBangTypes = String -> String -> DictFieldName -> [VarBangTypeQ]
getVarBangTypes String
"NoNext" String
nm DictFieldName
dct
	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 ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) (String -> Name
mkName String
nmnnx) [] Maybe Kind
forall a. Maybe a
Nothing
		[Name -> [VarBangTypeQ] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m VarBangType] -> m Con
recC (String -> Name
mkName String
nmnnx) ([VarBangTypeQ] -> Q Con) -> [VarBangTypeQ] -> Q Con
forall a b. (a -> b) -> a -> b
$ Int -> [VarBangTypeQ] -> [VarBangTypeQ]
forall a. Int -> [a] -> [a]
drop Int
2 [VarBangTypeQ]
varBangTypes]
		[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]]
	where nmnnx :: String
nmnnx = String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"NoNext"

getVarBangTypes :: String -> String -> DictFieldName -> [VarBangTypeQ]
getVarBangTypes :: String -> String -> DictFieldName -> [VarBangTypeQ]
getVarBangTypes String
sfx String
dtnm DictFieldName
ds = (String -> FieldName -> VarBangTypeQ)
-> (String, FieldName) -> VarBangTypeQ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> String -> FieldName -> VarBangTypeQ
member (String -> String -> FieldName -> VarBangTypeQ)
-> String -> String -> FieldName -> VarBangTypeQ
forall a b. (a -> b) -> a -> b
$ String
dtnm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sfx) ((String, FieldName) -> VarBangTypeQ)
-> DictFieldName -> [VarBangTypeQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DictFieldName
ds

mkFromCoreType :: Debug -> String -> DecQ
mkFromCoreType :: Debug -> String -> Q Dec
mkFromCoreType Debug
dbg String
nm = do
	cnm <- String -> Maybe Name -> Name
forall a. String -> Maybe a -> a
fromJust' String
"foo" (Maybe Name -> Name) -> Q (Maybe Name) -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debug -> String -> Q (Maybe Name)
lookupTypeName' Debug
dbg (String
"C." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm)
	sigD (mkName $ nm' ++ "FromCore")
		(conT cnm `arrT` conT (mkName $ nm ++ "NoNext"))
	where nm' :: String
nm' = (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
appHead Char -> Char
toLower String
nm

mkFromCoreBody :: Debug -> String -> DictFieldName -> DecQ
mkFromCoreBody :: Debug -> String -> DictFieldName -> Q Dec
mkFromCoreBody Debug
dbg String
nm DictFieldName
dct = do
	let	ds :: DictFieldName
ds = Int -> DictFieldName -> DictFieldName
forall a. Int -> [a] -> [a]
drop Int
2 DictFieldName
dct
	xs <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (DictFieldName -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DictFieldName
ds) (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
	let	fs = (\(String
tp, FieldName
_) -> String -> Name -> ExpQ
typeToFun String
tp) ((String, FieldName) -> Name -> ExpQ)
-> DictFieldName -> [Name -> ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DictFieldName
ds
		nvs = [FieldName] -> [Name] -> [(FieldName, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((String, FieldName) -> FieldName) -> DictFieldName -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map (String, FieldName) -> FieldName
forall a b. (a, b) -> b
snd DictFieldName
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) -> DictFieldName -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map (String, FieldName) -> FieldName
forall a b. (a, b) -> b
snd DictFieldName
ds) [Name]
xs) [Name -> ExpQ]
fs
	cnm <- fromJust' "bar" <$> lookupValueName' dbg ("C." ++ nm)
	funD (mkName $ nm' ++ "FromCore") . (: []) . ($ [])
		. clause [mkFromCorePat cnm nvs] . normalB
		$ recConE (mkName $ nm ++ "NoNext") (exFieldExps "NoNext" nm nws)
	where
	nm' :: String
nm' = (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
appHead Char -> Char
toLower String
nm
	mkFromCorePat :: Name -> [(FieldName, Name)] -> Q Pat
mkFromCorePat Name
cnm [(FieldName, Name)]
nvs = Name -> [Q FieldPat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
cnm ([Q FieldPat] -> Q Pat) -> [Q FieldPat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ Debug -> String -> [(FieldName, Name)] -> [Q FieldPat]
exFieldPats Debug
dbg String
nm [(FieldName, Name)]
nvs

mkToCoreType :: Debug -> String -> DecQ
mkToCoreType :: Debug -> String -> Q Dec
mkToCoreType Debug
dbg String
nm = do
	mn <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"mn"
	cnm <- fromJust' "baz" <$> lookupTypeName' dbg ("C." ++ nm)
	sigD (mkName $ nm' ++ "ToCore")
		(forallT []
			(cxt [conT ''WithPoked `appT`
				(conT ''TMaybe.M `appT` varT mn)])
			(conT (mkName nm) `appT` varT mn `arrT`
				(conT cnm `arrT` conT ''IO `appT` conT ''()) `arrT`
				conT ''IO `appT` conT ''()))
	where nm' :: String
nm' = (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
appHead Char -> Char
toLower String
nm

mkToCoreBody :: Debug -> String -> DictFieldName -> DecQ
mkToCoreBody :: Debug -> String -> DictFieldName -> Q Dec
mkToCoreBody Debug
dbg String
nm DictFieldName
ds = do
	f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
	cnm <- fromJust' "poooo" <$> lookupValueName' dbg ("C." ++ nm)
	stype <- fromJust' "hogefuga" <$> lookupValueName' dbg ("C." ++ nm' ++ "SType")
	pnext <- fromJust' "oops" <$> lookupValueName' dbg ("C." ++ nm' ++ "PNext")
	xs <- replicateM (length ds) $ newName "x"
	let	pes = (\(String
tp, FieldName
_) -> String -> (Name -> Q Pat, Name -> ExpQ)
typeToPatExp String
tp) ((String, FieldName) -> (Name -> Q Pat, Name -> ExpQ))
-> DictFieldName -> [(Name -> Q Pat, Name -> ExpQ)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DictFieldName
ds
		nvs = [(FieldName, Name)]
-> [(Name -> Q Pat, Name -> ExpQ)]
-> [((FieldName, Name), (Name -> Q Pat, 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) -> DictFieldName -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map (String, FieldName) -> FieldName
forall a b. (a, b) -> b
snd DictFieldName
ds) [Name]
xs) [(Name -> Q Pat, Name -> ExpQ)]
pes
	[mnxt, pnxt, pnxt'] <- newName `mapM` ["mnxt", "pnxt", "pnxt'"]
	funD (mkName $ nm' ++ "ToCore")
		. (: []) . ($ []) . clause [mkToCorePat mnxt nvs, varP f] . normalB
		$ varE 'withPoked' `appE` varE mnxt `appE`
			lamE [varP pnxt] (
				varE 'withPtrS `appE` varE pnxt `appE`
				lamE [viewP (varE 'castPtr) (varP pnxt')] (
					varE f `appE`
					recConE cnm (
						((stype ,) <$> conE '()) : ((pnext ,) <$> varE pnxt') :
						toFieldExps dbg nm (drop 2 nvs) ) ) )
	where
	nm' :: String
nm' = (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
appHead Char -> Char
toLower String
nm
	mkToCorePat :: Name -> [((FieldName, Name), (Name -> Q Pat, a))] -> Q Pat
mkToCorePat Name
mnxt [((FieldName, Name), (Name -> Q Pat, a))]
nvs = Name -> [Q FieldPat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP (String -> Name
mkName String
nm)
		([Q FieldPat] -> Q Pat) -> [Q FieldPat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Q Pat -> 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
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Next") (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
mnxt) Q FieldPat -> [Q FieldPat] -> [Q FieldPat]
forall a. a -> [a] -> [a]
: String -> [((FieldName, Name), (Name -> Q Pat, a))] -> [Q FieldPat]
forall a.
String -> [((FieldName, Name), (Name -> Q Pat, a))] -> [Q FieldPat]
toFieldPats String
nm (Int
-> [((FieldName, Name), (Name -> Q Pat, a))]
-> [((FieldName, Name), (Name -> Q Pat, a))]
forall a. Int -> [a] -> [a]
drop Int
2 [((FieldName, Name), (Name -> Q Pat, a))]
nvs)

type DictFieldName = [(String, FieldName)]

readStructData :: String -> Q DictFieldName
readStructData :: String -> Q DictFieldName
readStructData String
dtnm = IO DictFieldName -> Q DictFieldName
forall a. IO a -> Q a
runIO (IO DictFieldName -> Q DictFieldName)
-> IO DictFieldName -> Q DictFieldName
forall a b. (a -> b) -> a -> b
$ (String -> (String, FieldName)) -> [String] -> DictFieldName
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String
forall a. a -> a
id (String -> String)
-> (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] -> DictFieldName)
-> (String -> [String]) -> String -> DictFieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> DictFieldName) -> IO String -> IO DictFieldName
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dtnm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".txt")

data Debug = Production | Debug deriving Int -> Debug -> String -> String
[Debug] -> String -> String
Debug -> String
(Int -> Debug -> String -> String)
-> (Debug -> String) -> ([Debug] -> String -> String) -> Show Debug
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Debug -> String -> String
showsPrec :: Int -> Debug -> String -> String
$cshow :: Debug -> String
show :: Debug -> String
$cshowList :: [Debug] -> String -> String
showList :: [Debug] -> String -> String
Show

lookupValueName' :: Debug -> String -> Q (Maybe Name)
lookupValueName' :: Debug -> String -> Q (Maybe Name)
lookupValueName' = \case
--	Production -> lookupValueName
	Debug
Production -> 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
	Debug
Debug -> 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

lookupTypeName' :: Debug -> String -> Q (Maybe Name)
lookupTypeName' :: Debug -> String -> Q (Maybe Name)
lookupTypeName' = \case
	Debug
Production -> String -> Q (Maybe Name)
lookupTypeName
	Debug
Debug -> 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

sample :: String
sample :: String
sample = String
"DescriptorIndexingFeatures"

newtype DeviceSize = DeviceSize { DeviceSize -> Word64
unDeviceSize :: Word64 } deriving Int -> DeviceSize -> String -> String
[DeviceSize] -> String -> String
DeviceSize -> String
(Int -> DeviceSize -> String -> String)
-> (DeviceSize -> String)
-> ([DeviceSize] -> String -> String)
-> Show DeviceSize
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DeviceSize -> String -> String
showsPrec :: Int -> DeviceSize -> String -> String
$cshow :: DeviceSize -> String
show :: DeviceSize -> String
$cshowList :: [DeviceSize] -> String -> String
showList :: [DeviceSize] -> String -> String
Show
newtype Size = Size Word64 deriving Int -> Size -> String -> String
[Size] -> String -> String
Size -> String
(Int -> Size -> String -> String)
-> (Size -> String) -> ([Size] -> String -> String) -> Show Size
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Size -> String -> String
showsPrec :: Int -> Size -> String -> String
$cshow :: Size -> String
show :: Size -> String
$cshowList :: [Size] -> String -> String
showList :: [Size] -> String -> String
Show

infixr 8 `arrT`

arrT :: TypeQ -> TypeQ -> TypeQ
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

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

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

appHead :: (a -> a) -> [a] -> [a]
appHead :: forall a. (a -> a) -> [a] -> [a]
appHead a -> a
f = \case [] -> []; a
x : [a]
xs -> a -> a
f a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs

getNameType :: String -> String -> FieldName -> (String, TypeQ)
getNameType :: String -> String -> FieldName -> (String, Q Kind)
getNameType String
pfx String
tp (Atom String
fn) = (String
pfx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
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
-> [(String, (Q Kind, Name -> ExpQ))] -> (Q Kind, Name -> ExpQ)
forall a b. (Show a, Eq a) => a -> [(a, b)] -> b
lookup' String
tp [(String, (Q Kind, Name -> ExpQ))]
dict)
getNameType String
pfx String
tp (List String
fn Integer
nb) = (String
pfx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
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
-> [(String, (Q Kind, Name -> ExpQ))] -> (Q Kind, Name -> ExpQ)
forall a b. (Show a, Eq a) => a -> [(a, b)] -> b
lookup' String
tp [(String, (Q Kind, Name -> ExpQ))]
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
	Just b
y -> b
y

dict :: Dict
dict :: [(String, (Q Kind, Name -> ExpQ))]
dict = DictGen -> [(String, (Q Kind, Name -> ExpQ))]
dictGenToDict DictGen
dictGen

dictGenToDict :: DictGen -> Dict
dictGenToDict :: DictGen -> [(String, (Q Kind, Name -> ExpQ))]
dictGenToDict = ((String, (Q Kind, Name -> ExpQ), (Name -> Q Pat, Name -> ExpQ))
 -> (String, (Q Kind, Name -> ExpQ)))
-> DictGen -> [(String, (Q Kind, Name -> ExpQ))]
forall a b. (a -> b) -> [a] -> [b]
map \(String
tp, (Q Kind, Name -> ExpQ)
tfr, (Name -> Q Pat, 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 -> Q Pat, Name -> ExpQ))
 -> (String, (Name -> Q Pat, Name -> ExpQ)))
-> DictGen -> Dict2
forall a b. (a -> b) -> [a] -> [b]
map \(String
tp, (Q Kind, Name -> ExpQ)
_tfr, (Name -> Q Pat, Name -> ExpQ)
to) -> (String
tp, (Name -> Q Pat, 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 -> Q Pat
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 -> Q Pat
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 -> Q Pat
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 -> Q Pat
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 -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Size ([Q Pat] -> Q Pat) -> (Name -> [Q Pat]) -> Name -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Pat -> [Q Pat] -> [Q Pat]
forall a. a -> [a] -> [a]
: []) (Q Pat -> [Q Pat]) -> (Name -> Q Pat) -> Name -> [Q Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Pat
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 ''DeviceSize, ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'DeviceSize) (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 -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'DeviceSize ([Q Pat] -> Q Pat) -> (Name -> [Q Pat]) -> Name -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Pat -> [Q Pat] -> [Q Pat]
forall a. a -> [a] -> [a]
: []) (Q Pat -> [Q Pat]) -> (Name -> Q Pat) -> Name -> [Q Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Pat
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 -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'Sample.CountFlagBits ([Q Pat] -> Q Pat) -> (Name -> [Q Pat]) -> Name -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Pat -> [Q Pat] -> [Q Pat]
forall a. a -> [a] -> [a]
: []) (Q Pat -> [Q Pat]) -> (Name -> Q Pat) -> Name -> [Q Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP, Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE)) ]

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

noBang :: BangQ
noBang :: Q Bang
noBang = Q SourceUnpackedness -> Q SourceStrictness -> Q Bang
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

readName :: String -> FieldName
readName :: String -> FieldName
readName (Char
'A' : Char
' ' : String
nm) = String -> FieldName
Atom String
nm
readName (Char
'L' : Char
' ' : String
nmnb) = case String -> [String]
words String
nmnb of
	[String
nm, String
nb] -> String -> Integer -> FieldName
List String
nm (String -> Integer
forall a. Read a => String -> a
read String
nb); [String]
_ -> String -> FieldName
forall a. HasCallStack => String -> a
error String
"bad"
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"

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

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

typeToFun :: String -> (Name -> ExpQ)
typeToFun :: String -> Name -> ExpQ
typeToFun String
nm = case String
-> [(String, (Q Kind, Name -> ExpQ))]
-> Maybe (Q Kind, Name -> ExpQ)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
nm [(String, (Q Kind, Name -> ExpQ))]
dict of Just (Q Kind
_, Name -> ExpQ
f) -> Name -> ExpQ
f; Maybe (Q Kind, Name -> ExpQ)
Nothing -> String -> Name -> ExpQ
forall a. HasCallStack => String -> a
error String
"bad"

exFieldPats :: Debug -> String -> [(FieldName, Name)] -> [Q FieldPat]
exFieldPats :: Debug -> String -> [(FieldName, Name)] -> [Q FieldPat]
exFieldPats Debug
dbg 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 (Debug -> String -> FieldName -> Name -> Q FieldPat
exFieldPat1 Debug
dbg (String -> FieldName -> Name -> Q FieldPat)
-> String -> FieldName -> Name -> Q FieldPat
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
appHead Char -> Char
toLower String
dtnm)

exFieldPat1 :: Debug -> String -> FieldName -> Name -> Q FieldPat
exFieldPat1 :: Debug -> String -> FieldName -> Name -> Q FieldPat
exFieldPat1 Debug
dbg 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
fromJust' (String
"C." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pfx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
nm) (Maybe Name -> Name) -> Q (Maybe Name) -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debug -> String -> Q (Maybe Name)
lookupValueName' Debug
dbg (String
"C." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pfx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
nm)
	fieldPat n (varP x)

typeToPatExp :: String -> (Name -> PatQ, Name -> ExpQ)
typeToPatExp :: String -> (Name -> Q Pat, Name -> ExpQ)
typeToPatExp = String
-> Maybe (Name -> Q Pat, Name -> ExpQ)
-> (Name -> Q Pat, Name -> ExpQ)
forall a. String -> Maybe a -> a
fromJust' String
"nande" (Maybe (Name -> Q Pat, Name -> ExpQ)
 -> (Name -> Q Pat, Name -> ExpQ))
-> (String -> Maybe (Name -> Q Pat, Name -> ExpQ))
-> String
-> (Name -> Q Pat, Name -> ExpQ)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Dict2 -> Maybe (Name -> Q Pat, 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 -> Q Pat, a))] -> [Q FieldPat]
toFieldPats String
dtnm = (((FieldName, Name), (Name -> Q Pat, a)) -> Q FieldPat)
-> [((FieldName, Name), (Name -> Q Pat, a))] -> [Q FieldPat]
forall a b. (a -> b) -> [a] -> [b]
map ((((FieldName, Name), (Name -> Q Pat, a)) -> Q FieldPat)
 -> [((FieldName, Name), (Name -> Q Pat, a))] -> [Q FieldPat])
-> (((FieldName, Name) -> (Name -> Q Pat, a) -> Q FieldPat)
    -> ((FieldName, Name), (Name -> Q Pat, a)) -> Q FieldPat)
-> ((FieldName, Name) -> (Name -> Q Pat, a) -> Q FieldPat)
-> [((FieldName, Name), (Name -> Q Pat, a))]
-> [Q FieldPat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FieldName, Name) -> (Name -> Q Pat, a) -> Q FieldPat)
-> ((FieldName, Name), (Name -> Q Pat, a)) -> Q FieldPat
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (((FieldName, Name) -> (Name -> Q Pat, a) -> Q FieldPat)
 -> [((FieldName, Name), (Name -> Q Pat, a))] -> [Q FieldPat])
-> ((FieldName, Name) -> (Name -> Q Pat, a) -> Q FieldPat)
-> [((FieldName, Name), (Name -> Q Pat, a))]
-> [Q FieldPat]
forall a b. (a -> b) -> a -> b
$ (FieldName -> Name -> (Name -> Q Pat, a) -> Q FieldPat)
-> (FieldName, Name) -> (Name -> Q Pat, a) -> Q FieldPat
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> FieldName -> Name -> (Name -> Q Pat, a) -> Q FieldPat
forall a.
String -> FieldName -> Name -> (Name -> Q Pat, a) -> Q FieldPat
toFieldPat1 (String -> FieldName -> Name -> (Name -> Q Pat, a) -> Q FieldPat)
-> String -> FieldName -> Name -> (Name -> Q Pat, a) -> Q FieldPat
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
appHead Char -> Char
toLower String
dtnm)

toFieldPat1 :: String -> FieldName -> Name -> ((Name -> PatQ), a) -> Q FieldPat
toFieldPat1 :: forall a.
String -> FieldName -> Name -> (Name -> Q Pat, a) -> Q FieldPat
toFieldPat1 String
pfx (Atom String
nm) Name
x (Name -> Q Pat
f, a
_) = Name -> Q Pat -> 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
nm) (Name -> Q Pat
f Name
x)
toFieldPat1 String
pfx (List String
nm Integer
_) Name
x (Name -> Q Pat, a)
_ = Name -> Q Pat -> 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
nm) (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x)

exFieldExps :: String -> String -> [((FieldName, Name), Name -> ExpQ)] -> [Q (Name, Exp)]
exFieldExps :: String
-> String -> [((FieldName, Name), Name -> ExpQ)] -> [Q (Name, Exp)]
exFieldExps String
sfx 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
-> String -> FieldName -> Name -> (Name -> ExpQ) -> Q (Name, Exp)
exFieldExp1 String
sfx (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) -> String -> String
forall a. (a -> a) -> [a] -> [a]
appHead 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 -> String -> FieldName -> Name -> (Name -> ExpQ) -> Q (Name, Exp)
exFieldExp1 :: String
-> String -> FieldName -> Name -> (Name -> ExpQ) -> Q (Name, Exp)
exFieldExp1 String
sfx 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sfx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
nm) (Name -> ExpQ
f Name
x)
exFieldExp1 String
sfx 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 ++ sfx ++ 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

mkFromNoNextType :: String -> DecQ
mkFromNoNextType :: String -> Q Dec
mkFromNoNextType String
nm = do
	mn <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"mn"
	sigD (mkName $ nm' ++ "FromNoNext") $
		(conT ''TMaybe.M `appT` varT mn) `arrT`
		conT (mkName $ nm ++ "NoNext") `arrT`
		(conT (mkName nm) `appT` varT mn)
	where nm' :: String
nm' = (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
appHead Char -> Char
toLower String
nm

mkFromNoNextBody :: String -> DictFieldName -> DecQ
mkFromNoNextBody :: String -> DictFieldName -> Q Dec
mkFromNoNextBody String
nm DictFieldName
dct = do
	mnxt <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"mnxt"
	xs <- replicateM (length dct) $ newName "x"
	funD (mkName $ nm' ++ "FromNoNext") . (: []) . ($ [])
		. clause [varP mnxt, mkFromNoNextPat nm (drop 2 dct) xs] . normalB
		. recConE (mkName nm) $
			((mkName (nm' ++ "Next") ,) <$> varE mnxt) :
			(<$> zip (dictFieldNameToNames $ drop 2 dct) xs) \(String
fnm, Name
x) ->
				(String -> Name
mkName (String
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
fnm) ,) (Exp -> (Name, Exp)) -> ExpQ -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x
	where nm' :: String
nm' = (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
appHead Char -> Char
toLower String
nm

mkFromNoNextPat :: String -> DictFieldName -> [Name] -> PatQ
mkFromNoNextPat :: String -> DictFieldName -> [Name] -> Q Pat
mkFromNoNextPat String
nm DictFieldName
dct [Name]
xs = Name -> [Q FieldPat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"NoNext")
	([Q FieldPat] -> Q Pat) -> [Q FieldPat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (((String, Name) -> Q FieldPat) -> [(String, Name)] -> [Q FieldPat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> [Name] -> [(String, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip (DictFieldName -> [String]
dictFieldNameToNames DictFieldName
dct) [Name]
xs) \(String
fnm, Name
x) ->
		Name -> Q Pat -> 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
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"NoNext" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
capitalize String
fnm) (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x)
	where nm' :: String
nm' = (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
appHead Char -> Char
toLower String
nm

dictFieldNameToNames :: DictFieldName -> [String]
dictFieldNameToNames :: DictFieldName -> [String]
dictFieldNameToNames = ((String, FieldName) -> String
forall {a}. (a, FieldName) -> String
dfntn ((String, FieldName) -> String) -> DictFieldName -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
	where dfntn :: (a, FieldName) -> String
dfntn (a
_, FieldName
fn) = case FieldName
fn of Atom String
n -> String
n; List String
n Integer
_ -> String
n