{-# 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.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.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
DictFieldName
dct <- String -> Q DictFieldName
readStructData String
nm
[Q Dec] -> DecsQ
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 -> DictFieldName -> Q Dec
mkData String
nm DictFieldName
dct, String -> Q Dec
mkDataShow String
nm, String -> DictFieldName -> Q Dec
mkDataNoNext String
nm DictFieldName
dct,
Debug -> String -> Q Dec
mkFromCoreType Debug
Production String
nm, Debug -> String -> DictFieldName -> Q Dec
mkFromCoreBody Debug
Production String
nm DictFieldName
dct,
Debug -> String -> Q Dec
mkToCoreType Debug
Production String
nm, Debug -> String -> DictFieldName -> Q Dec
mkToCoreBody Debug
Production String
nm DictFieldName
dct,
String -> Q Dec
mkFromNoNextType String
nm, String -> DictFieldName -> Q Dec
mkFromNoNextBody String
nm DictFieldName
dct ]
mkData :: String -> DictFieldName -> DecQ
mkData :: String -> DictFieldName -> Q Dec
mkData String
nm DictFieldName
dct = do
Name
mn <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"mn"
let varBangTypes :: [VarBangTypeQ]
varBangTypes = String -> String -> DictFieldName -> [VarBangTypeQ]
getVarBangTypes String
"" 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
nm)
[Name -> TyVarBndr BndrVis
forall flag. DefaultBndrFlag flag => Name -> TyVarBndr flag
plainTV Name
mn] 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
nm) ([VarBangTypeQ] -> Q Con) -> [VarBangTypeQ] -> Q Con
forall a b. (a -> b) -> a -> b
$
(Name -> Q BangType -> VarBangTypeQ
forall (m :: * -> *).
Quote m =>
Name -> m BangType -> m VarBangType
varBangType (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")
(Q Bang -> Q Kind -> Q BangType
forall (m :: * -> *). Quote m => m Bang -> m Kind -> m BangType
bangType Q Bang
noBang
(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 Name
mn))) VarBangTypeQ -> [VarBangTypeQ] -> [VarBangTypeQ]
forall a. a -> [a] -> [a]
:
(Int -> [VarBangTypeQ] -> [VarBangTypeQ]
forall a. Int -> [a] -> [a]
drop Int
2 [VarBangTypeQ]
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
Name
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)
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
$ String
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"FromCore")
(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
cnm Q Kind -> Q Kind -> Q Kind
`arrT` 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
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"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
[Name]
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 :: [Name -> ExpQ]
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)]
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)]
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
Name
cnm <- String -> Maybe Name -> Name
forall a. String -> Maybe a -> a
fromJust' String
"bar" (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
nm)
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
$ String
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"FromCore") ([Q Clause] -> Q Dec) -> (ExpQ -> [Q Clause]) -> ExpQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Clause -> [Q Clause] -> [Q Clause]
forall a. a -> [a] -> [a]
: []) (Q Clause -> [Q Clause])
-> (ExpQ -> Q Clause) -> ExpQ -> [Q Clause]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Q Dec] -> Q Clause) -> [Q Dec] -> Q Clause
forall a b. (a -> b) -> a -> b
$ [])
(([Q Dec] -> Q Clause) -> Q Clause)
-> (ExpQ -> [Q Dec] -> Q Clause) -> ExpQ -> Q Clause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [(FieldName, Name)] -> Q Pat
mkFromCorePat Name
cnm [(FieldName, Name)]
nvs] (Q Body -> [Q Dec] -> Q Clause)
-> (ExpQ -> Q Body) -> ExpQ -> [Q Dec] -> Q Clause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
(ExpQ -> Q Dec) -> ExpQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Q (Name, Exp)] -> ExpQ
forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE (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 -> [((FieldName, Name), Name -> ExpQ)] -> [Q (Name, Exp)]
exFieldExps String
"NoNext" String
nm [((FieldName, Name), Name -> ExpQ)]
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
Name
mn <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"mn"
Name
cnm <- String -> Maybe Name -> Name
forall a. String -> Maybe a -> a
fromJust' String
"baz" (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)
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
$ String
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ToCore")
([TyVarBndr Specificity] -> Q Cxt -> Q Kind -> Q Kind
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Kind -> m Kind
forallT []
([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt [Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''WithPoked 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 Name
mn)])
(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 Name
mn Q Kind -> Q Kind -> Q Kind
`arrT`
(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
cnm Q Kind -> Q Kind -> Q Kind
`arrT` Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''IO 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 ''()) Q Kind -> Q Kind -> Q Kind
`arrT`
Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''IO 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 ''()))
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
Name
f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
Name
cnm <- String -> Maybe Name -> Name
forall a. String -> Maybe a -> a
fromJust' String
"poooo" (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
nm)
Name
stype <- String -> Maybe Name -> Name
forall a. String -> Maybe a -> a
fromJust' String
"hogefuga" (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
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"SType")
Name
pnext <- String -> Maybe Name -> Name
forall a. String -> Maybe a -> a
fromJust' String
"oops" (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
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"PNext")
[Name]
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 pes :: [(Name -> Q Pat, Name -> ExpQ)]
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))]
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
[Name
mnxt, Name
pnxt, Name
pnxt'] <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [String
"mnxt", String
"pnxt", String
"pnxt'"]
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
$ String
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ToCore")
([Q Clause] -> Q Dec) -> (ExpQ -> [Q Clause]) -> ExpQ -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Clause -> [Q Clause] -> [Q Clause]
forall a. a -> [a] -> [a]
: []) (Q Clause -> [Q Clause])
-> (ExpQ -> Q Clause) -> ExpQ -> [Q Clause]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Q Dec] -> Q Clause) -> [Q Dec] -> Q Clause
forall a b. (a -> b) -> a -> b
$ []) (([Q Dec] -> Q Clause) -> Q Clause)
-> (ExpQ -> [Q Dec] -> Q Clause) -> ExpQ -> Q Clause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name
-> [((FieldName, Name), (Name -> Q Pat, Name -> ExpQ))] -> Q Pat
forall {a}.
Name -> [((FieldName, Name), (Name -> Q Pat, a))] -> Q Pat
mkToCorePat Name
mnxt [((FieldName, Name), (Name -> Q Pat, Name -> ExpQ))]
nvs, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f] (Q Body -> [Q Dec] -> Q Clause)
-> (ExpQ -> Q Body) -> ExpQ -> [Q Dec] -> Q Clause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
(ExpQ -> Q Dec) -> ExpQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'withPoked' ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
mnxt ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
[Q Pat] -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
pnxt] (
Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'withPtrS ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pnxt ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
[Q Pat] -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [ExpQ -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Exp -> m Pat -> m Pat
viewP (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'castPtr) (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
pnxt')] (
Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
Name -> [Q (Name, Exp)] -> ExpQ
forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
cnm (
((Name
stype ,) (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
conE '()) Q (Name, Exp) -> [Q (Name, Exp)] -> [Q (Name, Exp)]
forall a. a -> [a] -> [a]
: ((Name
pnext ,) (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
pnxt') Q (Name, Exp) -> [Q (Name, Exp)] -> [Q (Name, Exp)]
forall a. a -> [a] -> [a]
:
Debug
-> String
-> [((FieldName, Name), (Name -> Q Pat, Name -> ExpQ))]
-> [Q (Name, Exp)]
toFieldExps Debug
dbg String
nm (Int
-> [((FieldName, Name), (Name -> Q Pat, Name -> ExpQ))]
-> [((FieldName, Name), (Name -> Q Pat, Name -> ExpQ))]
forall a. Int -> [a] -> [a]
drop Int
2 [((FieldName, Name), (Name -> Q Pat, Name -> ExpQ))]
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
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
Name
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)
Name -> ExpQ -> Q (Name, Exp)
forall (m :: * -> *). Quote m => Name -> m Exp -> m (Name, Exp)
fieldExp Name
n (Name -> ExpQ
f Name
x)
toFieldExp1 Debug
dbg String
pfx (List String
nm Integer
_) Name
x (Name -> Q Pat
pf, Name -> ExpQ
f) = do
Name
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)
Name
y <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
Name -> ExpQ -> Q (Name, Exp)
forall (m :: * -> *). Quote m => Name -> m Exp -> m (Name, Exp)
fieldExp Name
n (ExpQ -> Q (Name, Exp)) -> ExpQ -> Q (Name, Exp)
forall a b. (a -> b) -> a -> b
$ Q Pat -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> Q Pat
pf Name
y) (Name -> ExpQ
f Name
y) ExpQ -> ExpQ -> ExpQ
.<$> (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toList ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
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
Name
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)
Name -> Q Pat -> Q FieldPat
forall (m :: * -> *). Quote m => Name -> m Pat -> m FieldPat
fieldPat Name
n (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
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
Name
y <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
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)
(ExpQ -> Q (Name, Exp)) -> (ExpQ -> ExpQ) -> ExpQ -> Q (Name, Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'listToLengthL) (ExpQ -> Q (Name, Exp)) -> ExpQ -> Q (Name, Exp)
forall a b. (a -> b) -> a -> b
$ Q Pat -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y) (Name -> ExpQ
f Name
y) ExpQ -> ExpQ -> ExpQ
.<$> Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
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
Name
mn <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"mn"
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
$ String
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"FromNoNext") (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 ''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 Name
mn) Q Kind -> Q Kind -> Q Kind
`arrT`
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
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"NoNext") Q Kind -> Q Kind -> Q Kind
`arrT`
(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 Name
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
Name
mnxt <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"mnxt"
[Name]
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
dct) (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"
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
$ String
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"FromNoNext") ([Q Clause] -> Q Dec)
-> ([Q (Name, Exp)] -> [Q Clause]) -> [Q (Name, Exp)] -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Clause -> [Q Clause] -> [Q Clause]
forall a. a -> [a] -> [a]
: []) (Q Clause -> [Q Clause])
-> ([Q (Name, Exp)] -> Q Clause) -> [Q (Name, Exp)] -> [Q Clause]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Q Dec] -> Q Clause) -> [Q Dec] -> Q Clause
forall a b. (a -> b) -> a -> b
$ [])
(([Q Dec] -> Q Clause) -> Q Clause)
-> ([Q (Name, Exp)] -> [Q Dec] -> Q Clause)
-> [Q (Name, Exp)]
-> Q Clause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
mnxt, String -> DictFieldName -> [Name] -> Q Pat
mkFromNoNextPat String
nm (Int -> DictFieldName -> DictFieldName
forall a. Int -> [a] -> [a]
drop Int
2 DictFieldName
dct) [Name]
xs] (Q Body -> [Q Dec] -> Q Clause)
-> ([Q (Name, Exp)] -> Q Body)
-> [Q (Name, Exp)]
-> [Q Dec]
-> Q Clause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
(ExpQ -> Q Body)
-> ([Q (Name, Exp)] -> ExpQ) -> [Q (Name, Exp)] -> Q Body
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Q (Name, Exp)] -> ExpQ
forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE (String -> Name
mkName String
nm) ([Q (Name, Exp)] -> Q Dec) -> [Q (Name, Exp)] -> Q Dec
forall a b. (a -> b) -> a -> b
$
((String -> Name
mkName (String
nm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Next") ,) (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
mnxt) Q (Name, Exp) -> [Q (Name, Exp)] -> [Q (Name, Exp)]
forall a. a -> [a] -> [a]
:
(((String, Name) -> Q (Name, Exp))
-> [(String, Name)] -> [Q (Name, Exp)]
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 -> [String]) -> DictFieldName -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> DictFieldName -> DictFieldName
forall a. Int -> [a] -> [a]
drop Int
2 DictFieldName
dct) [Name]
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