{-# LANGUAGE OverloadedLists #-}
module FlatBuffers.Internal.Compiler.TH where
import Control.Monad (join)
import Control.Monad.Except (runExceptT)
import Data.Bits ((.&.))
import Data.Foldable (traverse_)
import Data.Functor ((<&>))
import Data.Int
import Data.List qualified as List
import Data.List.NonEmpty (NonEmpty(..))
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as T
import Data.Word
import FlatBuffers.Internal.Build
import FlatBuffers.Internal.Compiler.NamingConventions qualified as NC
import FlatBuffers.Internal.Compiler.ParserIO qualified as ParserIO
import FlatBuffers.Internal.Compiler.SemanticAnalysis (SymbolTable(..))
import FlatBuffers.Internal.Compiler.SemanticAnalysis qualified as SemanticAnalysis
import FlatBuffers.Internal.Compiler.SyntaxTree qualified as SyntaxTree
import FlatBuffers.Internal.Compiler.ValidSyntaxTree
import FlatBuffers.Internal.FileIdentifier (HasFileIdentifier(..), unsafeFileIdentifier)
import FlatBuffers.Internal.Read
import FlatBuffers.Internal.Types
import FlatBuffers.Internal.Write
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (lift)
import Language.Haskell.TH.Syntax qualified as TH
(~>) :: Type -> Type -> Type
Type
a ~> :: Type -> Type -> Type
~> Type
b = Type
ArrowT Type -> Type -> Type
`AppT` Type
a Type -> Type -> Type
`AppT` Type
b
infixr 1 ~>
data Options = Options
{
Options -> [[Char]]
includeDirectories :: [FilePath]
, Options -> Bool
compileAllSchemas :: Bool
}
deriving (Int -> Options -> ShowS
[Options] -> ShowS
Options -> [Char]
(Int -> Options -> ShowS)
-> (Options -> [Char]) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Options -> ShowS
showsPrec :: Int -> Options -> ShowS
$cshow :: Options -> [Char]
show :: Options -> [Char]
$cshowList :: [Options] -> ShowS
showList :: [Options] -> ShowS
Show, Options -> Options -> Bool
(Options -> Options -> Bool)
-> (Options -> Options -> Bool) -> Eq Options
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Options -> Options -> Bool
== :: Options -> Options -> Bool
$c/= :: Options -> Options -> Bool
/= :: Options -> Options -> Bool
Eq)
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options
{ includeDirectories :: [[Char]]
includeDirectories = []
, compileAllSchemas :: Bool
compileAllSchemas = Bool
False
}
mkFlatBuffers :: FilePath -> Options -> Q [Dec]
mkFlatBuffers :: [Char] -> Options -> Q [Dec]
mkFlatBuffers [Char]
rootFilePath Options
opts = do
Text
currentModule <- [Char] -> Text
T.pack ([Char] -> Text) -> (Loc -> [Char]) -> Loc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> [Char]
loc_module (Loc -> Text) -> Q Loc -> Q Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
Either [Char] (FileTree Schema)
parseResult <- IO (Either [Char] (FileTree Schema))
-> Q (Either [Char] (FileTree Schema))
forall a. IO a -> Q a
runIO (IO (Either [Char] (FileTree Schema))
-> Q (Either [Char] (FileTree Schema)))
-> IO (Either [Char] (FileTree Schema))
-> Q (Either [Char] (FileTree Schema))
forall a b. (a -> b) -> a -> b
$ ExceptT [Char] IO (FileTree Schema)
-> IO (Either [Char] (FileTree Schema))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT [Char] IO (FileTree Schema)
-> IO (Either [Char] (FileTree Schema)))
-> ExceptT [Char] IO (FileTree Schema)
-> IO (Either [Char] (FileTree Schema))
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> ExceptT [Char] IO (FileTree Schema)
forall (m :: * -> *).
(MonadIO m, MonadError [Char] m) =>
[Char] -> [[Char]] -> m (FileTree Schema)
ParserIO.parseSchemas [Char]
rootFilePath (Options -> [[Char]]
includeDirectories Options
opts)
FileTree Schema
schemaFileTree <- ([Char] -> Q (FileTree Schema))
-> (FileTree Schema -> Q (FileTree Schema))
-> Either [Char] (FileTree Schema)
-> Q (FileTree Schema)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Q (FileTree Schema)
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q (FileTree Schema))
-> ShowS -> [Char] -> Q (FileTree Schema)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fixMsg) FileTree Schema -> Q (FileTree Schema)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either [Char] (FileTree Schema)
parseResult
FileTree Schema -> Q ()
forall {a}. FileTree a -> Q ()
registerFiles FileTree Schema
schemaFileTree
FileTree ValidDecls
symbolTables <- ([Char] -> Q (FileTree ValidDecls))
-> (FileTree ValidDecls -> Q (FileTree ValidDecls))
-> Either [Char] (FileTree ValidDecls)
-> Q (FileTree ValidDecls)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Q (FileTree ValidDecls)
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q (FileTree ValidDecls))
-> ShowS -> [Char] -> Q (FileTree ValidDecls)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fixMsg) FileTree ValidDecls -> Q (FileTree ValidDecls)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] (FileTree ValidDecls) -> Q (FileTree ValidDecls))
-> Either [Char] (FileTree ValidDecls) -> Q (FileTree ValidDecls)
forall a b. (a -> b) -> a -> b
$ FileTree Schema -> Either [Char] (FileTree ValidDecls)
SemanticAnalysis.validateSchemas FileTree Schema
schemaFileTree
let symbolTable :: ValidDecls
symbolTable =
if Options -> Bool
compileAllSchemas Options
opts
then FileTree ValidDecls -> ValidDecls
forall a. FileTree a -> a
SyntaxTree.fileTreeRoot FileTree ValidDecls
symbolTables
ValidDecls -> ValidDecls -> ValidDecls
forall a. Semigroup a => a -> a -> a
<> [ValidDecls] -> ValidDecls
forall a. Monoid a => [a] -> a
mconcat (Map [Char] ValidDecls -> [ValidDecls]
forall k a. Map k a -> [a]
Map.elems (Map [Char] ValidDecls -> [ValidDecls])
-> Map [Char] ValidDecls -> [ValidDecls]
forall a b. (a -> b) -> a -> b
$ FileTree ValidDecls -> Map [Char] ValidDecls
forall a. FileTree a -> Map [Char] a
SyntaxTree.fileTreeForest FileTree ValidDecls
symbolTables)
else FileTree ValidDecls -> ValidDecls
forall a. FileTree a -> a
SyntaxTree.fileTreeRoot FileTree ValidDecls
symbolTables
let symbolTable' :: ValidDecls
symbolTable' = Text -> ValidDecls -> ValidDecls
forall {enum} {struct} {table} {union}.
Text
-> SymbolTable enum struct table union
-> SymbolTable enum struct table union
filterByCurrentModule Text
currentModule ValidDecls
symbolTable
ValidDecls -> Q [Dec]
compileSymbolTable ValidDecls
symbolTable'
where
registerFiles :: FileTree a -> Q ()
registerFiles (SyntaxTree.FileTree [Char]
rootFilePath a
_ Map [Char] a
includedFiles) = do
[Char] -> Q ()
TH.addDependentFile [Char]
rootFilePath
([Char] -> Q ()) -> [[Char]] -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ [Char] -> Q ()
TH.addDependentFile ([[Char]] -> Q ()) -> [[Char]] -> Q ()
forall a b. (a -> b) -> a -> b
$ Map [Char] a -> [[Char]]
forall k a. Map k a -> [k]
Map.keys Map [Char] a
includedFiles
filterByCurrentModule :: Text
-> SymbolTable enum struct table union
-> SymbolTable enum struct table union
filterByCurrentModule Text
currentModule (SymbolTable Map (Namespace, Ident) enum
enums Map (Namespace, Ident) struct
structs Map (Namespace, Ident) table
tables Map (Namespace, Ident) union
unions) =
SymbolTable
{ allEnums :: Map (Namespace, Ident) enum
allEnums = ((Namespace, Ident) -> enum -> Bool)
-> Map (Namespace, Ident) enum -> Map (Namespace, Ident) enum
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (Text -> (Namespace, Ident) -> enum -> Bool
forall {b} {p}. Text -> (Namespace, b) -> p -> Bool
isCurrentModule Text
currentModule) Map (Namespace, Ident) enum
enums
, allStructs :: Map (Namespace, Ident) struct
allStructs = ((Namespace, Ident) -> struct -> Bool)
-> Map (Namespace, Ident) struct -> Map (Namespace, Ident) struct
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (Text -> (Namespace, Ident) -> struct -> Bool
forall {b} {p}. Text -> (Namespace, b) -> p -> Bool
isCurrentModule Text
currentModule) Map (Namespace, Ident) struct
structs
, allTables :: Map (Namespace, Ident) table
allTables = ((Namespace, Ident) -> table -> Bool)
-> Map (Namespace, Ident) table -> Map (Namespace, Ident) table
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (Text -> (Namespace, Ident) -> table -> Bool
forall {b} {p}. Text -> (Namespace, b) -> p -> Bool
isCurrentModule Text
currentModule) Map (Namespace, Ident) table
tables
, allUnions :: Map (Namespace, Ident) union
allUnions = ((Namespace, Ident) -> union -> Bool)
-> Map (Namespace, Ident) union -> Map (Namespace, Ident) union
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (Text -> (Namespace, Ident) -> union -> Bool
forall {b} {p}. Text -> (Namespace, b) -> p -> Bool
isCurrentModule Text
currentModule) Map (Namespace, Ident) union
unions
}
isCurrentModule :: Text -> (Namespace, b) -> p -> Bool
isCurrentModule Text
currentModule (Namespace
ns, b
_) p
_ = Namespace -> Text
NC.namespace Namespace
ns Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
currentModule
fixMsg :: String -> String
fixMsg :: ShowS
fixMsg = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
"\n" ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
forall {a}. (Semigroup a, IsString a) => a -> a
fixLine ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
where
fixLine :: a -> a
fixLine a
line = a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
line
compileSymbolTable :: SemanticAnalysis.ValidDecls -> Q [Dec]
compileSymbolTable :: ValidDecls -> Q [Dec]
compileSymbolTable ValidDecls
symbolTable = do
[Dec]
enumDecs <- [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EnumDecl -> Q [Dec]) -> [EnumDecl] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse EnumDecl -> Q [Dec]
mkEnum (Map (Namespace, Ident) EnumDecl -> [EnumDecl]
forall k a. Map k a -> [a]
Map.elems (ValidDecls -> Map (Namespace, Ident) EnumDecl
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) enum
allEnums ValidDecls
symbolTable))
[Dec]
structDecs <- [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StructDecl -> Q [Dec]) -> [StructDecl] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse StructDecl -> Q [Dec]
mkStruct (Map (Namespace, Ident) StructDecl -> [StructDecl]
forall k a. Map k a -> [a]
Map.elems (ValidDecls -> Map (Namespace, Ident) StructDecl
forall enum struct table union.
SymbolTable enum struct table union
-> Map (Namespace, Ident) struct
allStructs ValidDecls
symbolTable))
[Dec]
tableDecs <- [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TableDecl -> Q [Dec]) -> [TableDecl] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TableDecl -> Q [Dec]
mkTable (Map (Namespace, Ident) TableDecl -> [TableDecl]
forall k a. Map k a -> [a]
Map.elems (ValidDecls -> Map (Namespace, Ident) TableDecl
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) table
allTables ValidDecls
symbolTable))
[Dec]
unionDecs <- [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnionDecl -> Q [Dec]) -> [UnionDecl] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse UnionDecl -> Q [Dec]
mkUnion (Map (Namespace, Ident) UnionDecl -> [UnionDecl]
forall k a. Map k a -> [a]
Map.elems (ValidDecls -> Map (Namespace, Ident) UnionDecl
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) union
allUnions ValidDecls
symbolTable))
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
enumDecs [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
structDecs [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
tableDecs [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
unionDecs
mkEnum :: EnumDecl -> Q [Dec]
mkEnum :: EnumDecl -> Q [Dec]
mkEnum EnumDecl
enum =
if EnumDecl -> Bool
enumBitFlags EnumDecl
enum
then EnumDecl -> Q [Dec]
mkEnumBitFlags EnumDecl
enum
else EnumDecl -> Q [Dec]
mkEnumNormal EnumDecl
enum
mkEnumBitFlags :: EnumDecl -> Q [Dec]
mkEnumBitFlags :: EnumDecl -> Q [Dec]
mkEnumBitFlags EnumDecl
enum = do
[Dec]
nameFun <- EnumDecl -> [Name] -> Q [Dec]
mkEnumBitFlagsNames EnumDecl
enum [Name]
enumValNames
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
EnumDecl -> [Name] -> [Dec]
mkEnumBitFlagsConstants EnumDecl
enum [Name]
enumValNames
[Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> EnumDecl -> [Name] -> [Dec]
mkEnumBitFlagsAllValls EnumDecl
enum [Name]
enumValNames
[Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
nameFun
where
enumValNames :: [Name]
enumValNames = [Char] -> Name
mkName ([Char] -> Name) -> (EnumVal -> [Char]) -> EnumVal -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> [Char]) -> (EnumVal -> Text) -> EnumVal -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumDecl -> EnumVal -> Text
NC.enumBitFlagsConstant EnumDecl
enum (EnumVal -> Name) -> [EnumVal] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty EnumVal -> [EnumVal]
forall a. NonEmpty a -> [a]
NE.toList (EnumDecl -> NonEmpty EnumVal
enumVals EnumDecl
enum)
mkEnumBitFlagsConstants :: EnumDecl -> [Name] -> [Dec]
mkEnumBitFlagsConstants :: EnumDecl -> [Name] -> [Dec]
mkEnumBitFlagsConstants EnumDecl
enum [Name]
enumValNames =
NonEmpty EnumVal -> [EnumVal]
forall a. NonEmpty a -> [a]
NE.toList (EnumDecl -> NonEmpty EnumVal
enumVals EnumDecl
enum) [EnumVal] -> [Name] -> [(EnumVal, Name)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Name]
enumValNames [(EnumVal, Name)] -> ((EnumVal, Name) -> [Dec]) -> [Dec]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(EnumVal
enumVal, Name
enumValName) ->
let sig :: Dec
sig = Name -> Type -> Dec
SigD Name
enumValName (EnumType -> Type
enumTypeToType (EnumDecl -> EnumType
enumType EnumDecl
enum))
fun :: Dec
fun = Name -> [Clause] -> Dec
FunD Name
enumValName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE (EnumVal -> Integer
enumValInt EnumVal
enumVal))) []]
in [Dec
Item [Dec]
sig, Dec
Item [Dec]
fun]
mkEnumBitFlagsAllValls :: EnumDecl -> [Name] -> [Dec]
mkEnumBitFlagsAllValls :: EnumDecl -> [Name] -> [Dec]
mkEnumBitFlagsAllValls EnumDecl
enum [Name]
enumValNames =
let name :: Name
name = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ EnumDecl -> Text
NC.enumBitFlagsAllFun EnumDecl
enum
sig :: Dec
sig = Name -> Type -> Dec
SigD Name
name (Type
ListT Type -> Type -> Type
`AppT` EnumType -> Type
enumTypeToType (EnumDecl -> EnumType
enumType EnumDecl
enum))
fun :: Dec
fun = Name -> [Clause] -> Dec
FunD Name
name [ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []]
body :: Exp
body = [Exp] -> Exp
ListE (Name -> Exp
VarE (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
enumValNames)
in [Dec
Item [Dec]
sig, Dec
Item [Dec]
fun, Name -> Dec
inlinePragma Name
name]
mkEnumBitFlagsNames :: EnumDecl -> [Name] -> Q [Dec]
mkEnumBitFlagsNames :: EnumDecl -> [Name] -> Q [Dec]
mkEnumBitFlagsNames EnumDecl
enum [Name]
enumValNames = do
Name
inputName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"c"
Name
firstRes <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"res0"
[Dec]
firstClause <- [d| $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
firstRes) = [] |]
([Dec]
clauses, Name
lastRes) <- [(Name, Ident)] -> Int -> Name -> Name -> [Dec] -> Q ([Dec], Name)
mkClauses [(Name, Ident)]
namesAndIdentifiers Int
1 Name
inputName Name
firstRes [Dec]
firstClause
let fun :: Dec
fun = Name -> [Clause] -> Dec
FunD Name
funName
[ [Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> Pat
VarP Name
inputName]
(Exp -> Body
NormalB (Name -> Exp
VarE Name
lastRes))
([Dec] -> [Dec]
forall a. [a] -> [a]
List.reverse [Dec]
clauses)
]
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Dec
Item [Dec]
sig
, Dec
Item [Dec]
fun
, Name -> Dec
inlinePragma Name
funName
]
where
funName :: Name
funName = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ EnumDecl -> Text
NC.enumBitFlagsNamesFun EnumDecl
enum
sig :: Dec
sig = Name -> Type -> Dec
SigD Name
funName (EnumType -> Type
enumTypeToType (EnumDecl -> EnumType
enumType EnumDecl
enum) Type -> Type -> Type
~> Type
ListT Type -> Type -> Type
`AppT` Name -> Type
ConT ''Text)
namesAndIdentifiers :: [(Name, Ident)]
namesAndIdentifiers :: [(Name, Ident)]
namesAndIdentifiers = [(Name, Ident)] -> [(Name, Ident)]
forall a. [a] -> [a]
List.reverse ([Name]
enumValNames [Name] -> [Ident] -> [(Name, Ident)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (EnumVal -> Ident) -> [EnumVal] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EnumVal -> Ident
enumValIdent (NonEmpty EnumVal -> [EnumVal]
forall a. NonEmpty a -> [a]
NE.toList (EnumDecl -> NonEmpty EnumVal
enumVals EnumDecl
enum)))
mkClauses :: [(Name, Ident)] -> Int -> Name -> Name -> [Dec] -> Q ([Dec], Name)
mkClauses :: [(Name, Ident)] -> Int -> Name -> Name -> [Dec] -> Q ([Dec], Name)
mkClauses [] Int
_ Name
_ Name
previousRes [Dec]
clauses = ([Dec], Name) -> Q ([Dec], Name)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
clauses, Name
previousRes)
mkClauses ((Name
name, Ident Text
ident) : [(Name, Ident)]
rest) Int
ix Name
inputName Name
previousRes [Dec]
clauses = do
Name
res <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName ([Char]
"res" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ix)
[Dec]
clause <-
[d|
$(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
res) = if $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name) .&. $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
inputName) /= 0
then $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Exp
textLitE Text
ident)) : $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
previousRes)
else $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
previousRes)
|]
[(Name, Ident)] -> Int -> Name -> Name -> [Dec] -> Q ([Dec], Name)
mkClauses [(Name, Ident)]
rest (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Name
inputName Name
res ([Dec]
clause [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
clauses)
mkEnumNormal :: EnumDecl -> Q [Dec]
mkEnumNormal :: EnumDecl -> Q [Dec]
mkEnumNormal EnumDecl
enum = do
let enumName :: Name
enumName = Text -> Name
mkName' (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ EnumDecl -> Text
forall a. HasIdent a => a -> Text
NC.dataTypeName EnumDecl
enum
let enumValNames :: NonEmpty Name
enumValNames = EnumDecl -> NonEmpty EnumVal
enumVals EnumDecl
enum NonEmpty EnumVal -> (EnumVal -> Name) -> NonEmpty Name
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \EnumVal
enumVal ->
[Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ EnumDecl -> EnumVal -> Text
forall parent val.
(HasIdent parent, HasIdent val) =>
parent -> val -> Text
NC.enumUnionMember EnumDecl
enum EnumVal
enumVal
let enumDec :: Dec
enumDec = Name -> NonEmpty Name -> Dec
mkEnumDataDec Name
enumName NonEmpty Name
enumValNames
let enumValsAndNames :: NonEmpty (EnumVal, Name)
enumValsAndNames = EnumDecl -> NonEmpty EnumVal
enumVals EnumDecl
enum NonEmpty EnumVal -> NonEmpty Name -> NonEmpty (EnumVal, Name)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
`NE.zip` NonEmpty Name
enumValNames
[Dec]
toEnumDecs <- Name -> EnumDecl -> NonEmpty (EnumVal, Name) -> Q [Dec]
mkToEnum Name
enumName EnumDecl
enum NonEmpty (EnumVal, Name)
enumValsAndNames
[Dec]
fromEnumDecs <- Name -> EnumDecl -> NonEmpty (EnumVal, Name) -> Q [Dec]
mkFromEnum Name
enumName EnumDecl
enum NonEmpty (EnumVal, Name)
enumValsAndNames
[Dec]
enumNameDecs <- Name -> EnumDecl -> NonEmpty (EnumVal, Name) -> Q [Dec]
mkEnumNameFun Name
enumName EnumDecl
enum NonEmpty (EnumVal, Name)
enumValsAndNames
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
enumDec Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
toEnumDecs [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
fromEnumDecs [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
enumNameDecs
mkEnumDataDec :: Name -> NonEmpty Name -> Dec
mkEnumDataDec :: Name -> NonEmpty Name -> Dec
mkEnumDataDec Name
enumName NonEmpty Name
enumValNames =
Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
enumName [] Maybe Type
forall a. Maybe a
Nothing
((Name -> Con) -> [Name] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
n -> Name -> [BangType] -> Con
NormalC Name
n []) (NonEmpty Name -> [Name]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Name
enumValNames))
[ Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing
[ Name -> Type
ConT ''Eq
, Name -> Type
ConT ''Show
, Name -> Type
ConT ''Read
, Name -> Type
ConT ''Ord
, Name -> Type
ConT ''Bounded
]
]
mkToEnum :: Name -> EnumDecl -> NonEmpty (EnumVal, Name) -> Q [Dec]
mkToEnum :: Name -> EnumDecl -> NonEmpty (EnumVal, Name) -> Q [Dec]
mkToEnum Name
enumName EnumDecl
enum NonEmpty (EnumVal, Name)
enumValsAndNames = do
let funName :: Name
funName = Text -> Name
mkName' (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ EnumDecl -> Text
NC.toEnumFun EnumDecl
enum
Name
argName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"n"
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Name -> Type -> Dec
SigD Name
funName (EnumType -> Type
enumTypeToType (EnumDecl -> EnumType
enumType EnumDecl
enum) Type -> Type -> Type
~> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Name -> Type
ConT Name
enumName)
, Name -> [Clause] -> Dec
FunD Name
funName
[ [Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> Pat
VarP Name
argName]
(Exp -> Body
NormalB (Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
argName) [Match]
matches))
[]
]
, Name -> Dec
inlinePragma Name
funName
]
where
matches :: [Match]
matches =
((EnumVal, Name) -> Match
mkMatch ((EnumVal, Name) -> Match) -> [(EnumVal, Name)] -> [Match]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (EnumVal, Name) -> [(EnumVal, Name)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (EnumVal, Name)
enumValsAndNames) [Match] -> [Match] -> [Match]
forall a. Semigroup a => a -> a -> a
<> [Match
Item [Match]
matchWildcard]
mkMatch :: (EnumVal, Name) -> Match
mkMatch (EnumVal
enumVal, Name
enumName) =
Pat -> Body -> [Dec] -> Match
Match
(Integer -> Pat
forall i. Integral i => i -> Pat
intLitP (EnumVal -> Integer
enumValInt EnumVal
enumVal))
(Exp -> Body
NormalB (Name -> Exp
ConE 'Just Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE Name
enumName))
[]
matchWildcard :: Match
matchWildcard =
Pat -> Body -> [Dec] -> Match
Match
Pat
WildP
(Exp -> Body
NormalB (Name -> Exp
ConE 'Nothing))
[]
mkFromEnum :: Name -> EnumDecl -> NonEmpty (EnumVal, Name) -> Q [Dec]
Name
enumName EnumDecl
enum NonEmpty (EnumVal, Name)
enumValsAndNames = do
let funName :: Name
funName = Text -> Name
mkName' (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ EnumDecl -> Text
NC.fromEnumFun EnumDecl
enum
Name
argName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"n"
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Name -> Type -> Dec
SigD Name
funName (Name -> Type
ConT Name
enumName Type -> Type -> Type
~> EnumType -> Type
enumTypeToType (EnumDecl -> EnumType
enumType EnumDecl
enum))
, Name -> [Clause] -> Dec
FunD Name
funName
[ [Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> Pat
VarP Name
argName]
(Exp -> Body
NormalB (Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
argName) ((EnumVal, Name) -> Match
mkMatch ((EnumVal, Name) -> Match) -> [(EnumVal, Name)] -> [Match]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (EnumVal, Name) -> [(EnumVal, Name)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (EnumVal, Name)
enumValsAndNames)))
[]
]
, Name -> Dec
inlinePragma Name
funName
]
where
mkMatch :: (EnumVal, Name) -> Match
mkMatch (EnumVal
enumVal, Name
enumName) =
Pat -> Body -> [Dec] -> Match
Match
(Name -> Cxt -> [Pat] -> Pat
ConP Name
enumName [] [])
(Exp -> Body
NormalB (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE (EnumVal -> Integer
enumValInt EnumVal
enumVal)))
[]
mkEnumNameFun :: Name -> EnumDecl -> NonEmpty (EnumVal, Name) -> Q [Dec]
mkEnumNameFun :: Name -> EnumDecl -> NonEmpty (EnumVal, Name) -> Q [Dec]
mkEnumNameFun Name
enumName EnumDecl
enum NonEmpty (EnumVal, Name)
enumValsAndNames = do
let funName :: Name
funName = Text -> Name
mkName' (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ EnumDecl -> Text
NC.enumNameFun EnumDecl
enum
Name
argName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"c"
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Name -> Type -> Dec
SigD Name
funName (Name -> Type
ConT Name
enumName Type -> Type -> Type
~> Name -> Type
ConT ''Text)
, Name -> [Clause] -> Dec
FunD Name
funName
[ [Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> Pat
VarP Name
argName]
(Exp -> Body
NormalB (Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
argName) ((EnumVal, Name) -> Match
forall {a}. HasIdent a => (a, Name) -> Match
mkMatch ((EnumVal, Name) -> Match) -> [(EnumVal, Name)] -> [Match]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (EnumVal, Name) -> [(EnumVal, Name)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (EnumVal, Name)
enumValsAndNames)))
[]
]
, Name -> Dec
inlinePragma Name
funName
]
where
mkMatch :: (a, Name) -> Match
mkMatch (a
enumVal, Name
enumName) =
Pat -> Body -> [Dec] -> Match
Match
(Name -> Cxt -> [Pat] -> Pat
ConP Name
enumName [] [])
(Exp -> Body
NormalB (Text -> Exp
textLitE (Ident -> Text
unIdent (a -> Ident
forall a. HasIdent a => a -> Ident
getIdent a
enumVal))))
[]
mkStruct :: StructDecl -> Q [Dec]
mkStruct :: StructDecl -> Q [Dec]
mkStruct StructDecl
struct = do
let structName :: Name
structName = Text -> Name
mkName' (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ StructDecl -> Text
forall a. HasIdent a => a -> Text
NC.dataTypeName StructDecl
struct
[Dec]
isStructInstance <- Name -> StructDecl -> Q [Dec]
mkIsStructInstance Name
structName StructDecl
struct
let dataDec :: Dec
dataDec = Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
structName [] Maybe Type
forall a. Maybe a
Nothing [] []
(Dec
consSig, Dec
cons) <- Name -> StructDecl -> Q (Dec, Dec)
mkStructConstructor Name
structName StructDecl
struct
let getters :: [Dec]
getters = (StructField -> [Dec]) -> NonEmpty StructField -> [Dec]
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Name -> StructDecl -> StructField -> [Dec]
mkStructFieldGetter Name
structName StructDecl
struct) (StructDecl -> NonEmpty StructField
structFields StructDecl
struct)
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
Dec
dataDec Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:
[Dec]
isStructInstance [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<>
[ Dec
Item [Dec]
consSig, Dec
Item [Dec]
cons ] [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<>
[Dec]
getters
mkIsStructInstance :: Name -> StructDecl -> Q [Dec]
mkIsStructInstance :: Name -> StructDecl -> Q [Dec]
mkIsStructInstance Name
structName StructDecl
struct =
[d|
instance IsStruct $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
structName) where
structAlignmentOf = $(Word8 -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Word8 -> m Exp
lift (Word8 -> Q Exp) -> (StructDecl -> Word8) -> StructDecl -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alignment -> Word8
unAlignment (Alignment -> Word8)
-> (StructDecl -> Alignment) -> StructDecl -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructDecl -> Alignment
structAlignment (StructDecl -> Q Exp) -> StructDecl -> Q Exp
forall a b. (a -> b) -> a -> b
$ StructDecl
struct)
structSizeOf = $(Word16 -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Word16 -> m Exp
lift (Word16 -> Q Exp) -> (StructDecl -> Word16) -> StructDecl -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InlineSize -> Word16
unInlineSize (InlineSize -> Word16)
-> (StructDecl -> InlineSize) -> StructDecl -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructDecl -> InlineSize
structSize (StructDecl -> Q Exp) -> StructDecl -> Q Exp
forall a b. (a -> b) -> a -> b
$ StructDecl
struct)
|]
mkStructConstructor :: Name -> StructDecl -> Q (Dec, Dec)
mkStructConstructor :: Name -> StructDecl -> Q (Dec, Dec)
mkStructConstructor Name
structName StructDecl
struct = do
NonEmpty (Type, Pat, NonEmpty Exp)
argsInfo <- (StructField -> Q (Type, Pat, NonEmpty Exp))
-> NonEmpty StructField -> Q (NonEmpty (Type, Pat, NonEmpty Exp))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse StructField -> Q (Type, Pat, NonEmpty Exp)
mkStructConstructorArg (StructDecl -> NonEmpty StructField
structFields StructDecl
struct)
let (NonEmpty Type
argTypes, NonEmpty Pat
pats, NonEmpty (NonEmpty Exp)
exps) = NonEmpty (Type, Pat, NonEmpty Exp)
-> (NonEmpty Type, NonEmpty Pat, NonEmpty (NonEmpty Exp))
forall a b c.
NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)
nonEmptyUnzip3 NonEmpty (Type, Pat, NonEmpty Exp)
argsInfo
let retType :: Type
retType = Type -> Type -> Type
AppT (Name -> Type
ConT ''WriteStruct) (Name -> Type
ConT Name
structName)
let sigType :: Type
sigType = (Type -> Type -> Type) -> Type -> NonEmpty Type -> Type
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
(~>) Type
retType NonEmpty Type
argTypes
let consName :: Name
consName = Text -> Name
mkName' (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ StructDecl -> Text
forall a. HasIdent a => a -> Text
NC.dataTypeConstructor StructDecl
struct
let consSig :: Dec
consSig = Name -> Type -> Dec
SigD Name
consName Type
sigType
let exp :: Exp
exp = (Exp -> Exp -> Exp) -> NonEmpty Exp -> Exp
forall a. (a -> a -> a) -> NonEmpty a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Exp
e Exp
acc -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
e) (Name -> Exp
VarE '(<>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
acc)) (NonEmpty (NonEmpty Exp) -> NonEmpty Exp
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join NonEmpty (NonEmpty Exp)
exps)
let body :: Body
body = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'WriteStruct Exp -> Exp -> Exp
`AppE` Exp
exp
let cons :: Dec
cons = Name -> [Clause] -> Dec
FunD Name
consName [ [Pat] -> Body -> [Dec] -> Clause
Clause (NonEmpty Pat -> [Pat]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Pat
pats) Body
body [] ]
(Dec, Dec) -> Q (Dec, Dec)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
consSig, Dec
cons)
mkStructConstructorArg :: StructField -> Q (Type, Pat, NonEmpty Exp)
mkStructConstructorArg :: StructField -> Q (Type, Pat, NonEmpty Exp)
mkStructConstructorArg StructField
sf = do
Name
argName <- Text -> Q Name
newName' (Text -> Q Name) -> Text -> Q Name
forall a b. (a -> b) -> a -> b
$ StructField -> Text
forall a. HasIdent a => a -> Text
NC.arg StructField
sf
let argPat :: Pat
argPat = Name -> Pat
VarP Name
argName
let argRef :: Exp
argRef = Name -> Exp
VarE Name
argName
let argType :: Type
argType = StructFieldType -> Type
structFieldTypeToWriteType (StructField -> StructFieldType
structFieldType StructField
sf)
let mkWriteExp :: StructFieldType -> Exp
mkWriteExp StructFieldType
sft =
case StructFieldType
sft of
StructFieldType
SInt8 -> Name -> Exp
VarE 'buildInt8
StructFieldType
SInt16 -> Name -> Exp
VarE 'buildInt16
StructFieldType
SInt32 -> Name -> Exp
VarE 'buildInt32
StructFieldType
SInt64 -> Name -> Exp
VarE 'buildInt64
StructFieldType
SWord8 -> Name -> Exp
VarE 'buildWord8
StructFieldType
SWord16 -> Name -> Exp
VarE 'buildWord16
StructFieldType
SWord32 -> Name -> Exp
VarE 'buildWord32
StructFieldType
SWord64 -> Name -> Exp
VarE 'buildWord64
StructFieldType
SFloat -> Name -> Exp
VarE 'buildFloat
StructFieldType
SDouble -> Name -> Exp
VarE 'buildDouble
StructFieldType
SBool -> Name -> Exp
VarE 'buildBool
SEnum TypeRef
_ EnumType
enumType -> StructFieldType -> Exp
mkWriteExp (EnumType -> StructFieldType
enumTypeToStructFieldType EnumType
enumType)
SStruct (Namespace, StructDecl)
_ -> Name -> Exp
VarE 'buildStruct
let exp :: Exp
exp = StructFieldType -> Exp
mkWriteExp (StructField -> StructFieldType
structFieldType StructField
sf) Exp -> Exp -> Exp
`AppE` Exp
argRef
let exps :: NonEmpty Exp
exps =
if StructField -> Word8
structFieldPadding StructField
sf Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0
then [ Exp
Item (NonEmpty Exp)
exp ]
else
[ Exp
Item (NonEmpty Exp)
exp
, Name -> Exp
VarE 'buildPadding Exp -> Exp -> Exp
`AppE` Word8 -> Exp
forall i. Integral i => i -> Exp
intLitE (StructField -> Word8
structFieldPadding StructField
sf)
]
(Type, Pat, NonEmpty Exp) -> Q (Type, Pat, NonEmpty Exp)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
argType, Pat
argPat, NonEmpty Exp
exps)
mkStructFieldGetter :: Name -> StructDecl -> StructField -> [Dec]
mkStructFieldGetter :: Name -> StructDecl -> StructField -> [Dec]
mkStructFieldGetter Name
structName StructDecl
struct StructField
sf =
[Dec
Item [Dec]
sig, Dec
Item [Dec]
fun]
where
funName :: Name
funName = [Char] -> Name
mkName (Text -> [Char]
T.unpack (StructDecl -> StructField -> Text
forall parent val.
(HasIdent parent, HasIdent val) =>
parent -> val -> Text
NC.getter StructDecl
struct StructField
sf))
fieldOffsetExp :: Exp
fieldOffsetExp = Word16 -> Exp
forall i. Integral i => i -> Exp
intLitE (StructField -> Word16
structFieldOffset StructField
sf)
retType :: Type
retType = StructFieldType -> Type
structFieldTypeToReadType (StructField -> StructFieldType
structFieldType StructField
sf)
sig :: Dec
sig =
Name -> Type -> Dec
SigD Name
funName (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$
case StructField -> StructFieldType
structFieldType StructField
sf of
SStruct (Namespace, StructDecl)
_ ->
Name -> Type
ConT ''Struct Type -> Type -> Type
`AppT` Name -> Type
ConT Name
structName Type -> Type -> Type
~> Type
retType
StructFieldType
_ ->
Name -> Type
ConT ''Struct Type -> Type -> Type
`AppT` Name -> Type
ConT Name
structName Type -> Type -> Type
~> Name -> Type
ConT ''Either Type -> Type -> Type
`AppT` Name -> Type
ConT ''ReadError Type -> Type -> Type
`AppT` Type
retType
fun :: Dec
fun = Name -> [Clause] -> Dec
FunD Name
funName [ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) [] ]
body :: Exp
body = [Exp] -> Exp
app
[ Name -> Exp
VarE 'readStructField
, StructFieldType -> Exp
mkReadExp (StructField -> StructFieldType
structFieldType StructField
sf)
, Exp
Item [Exp]
fieldOffsetExp
]
mkReadExp :: StructFieldType -> Exp
mkReadExp StructFieldType
sft =
case StructFieldType
sft of
StructFieldType
SInt8 -> Name -> Exp
VarE 'readInt8
StructFieldType
SInt16 -> Name -> Exp
VarE 'readInt16
StructFieldType
SInt32 -> Name -> Exp
VarE 'readInt32
StructFieldType
SInt64 -> Name -> Exp
VarE 'readInt64
StructFieldType
SWord8 -> Name -> Exp
VarE 'readWord8
StructFieldType
SWord16 -> Name -> Exp
VarE 'readWord16
StructFieldType
SWord32 -> Name -> Exp
VarE 'readWord32
StructFieldType
SWord64 -> Name -> Exp
VarE 'readWord64
StructFieldType
SFloat -> Name -> Exp
VarE 'readFloat
StructFieldType
SDouble -> Name -> Exp
VarE 'readDouble
StructFieldType
SBool -> Name -> Exp
VarE 'readBool
SEnum TypeRef
_ EnumType
enumType -> StructFieldType -> Exp
mkReadExp (StructFieldType -> Exp) -> StructFieldType -> Exp
forall a b. (a -> b) -> a -> b
$ EnumType -> StructFieldType
enumTypeToStructFieldType EnumType
enumType
SStruct (Namespace, StructDecl)
_ -> Name -> Exp
VarE 'readStruct
mkTable :: TableDecl -> Q [Dec]
mkTable :: TableDecl -> Q [Dec]
mkTable TableDecl
table = do
let tableName :: Name
tableName = Text -> Name
mkName' (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ TableDecl -> Text
forall a. HasIdent a => a -> Text
NC.dataTypeName TableDecl
table
(Dec
consSig, Dec
cons) <- Name -> TableDecl -> Q (Dec, Dec)
mkTableConstructor Name
tableName TableDecl
table
let fileIdentifierDec :: [Dec]
fileIdentifierDec = Name -> IsRoot -> [Dec]
mkTableFileIdentifier Name
tableName (TableDecl -> IsRoot
tableIsRoot TableDecl
table)
let getters :: [Dec]
getters = (TableField -> [Dec]) -> [TableField] -> [Dec]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Name -> TableDecl -> TableField -> [Dec]
mkTableFieldGetter Name
tableName TableDecl
table) (TableDecl -> [TableField]
tableFields TableDecl
table)
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
[ Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
tableName [] Maybe Type
forall a. Maybe a
Nothing [] []
, Dec
Item [Dec]
consSig
, Dec
Item [Dec]
cons
] [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
fileIdentifierDec
[Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
getters
mkTableFileIdentifier :: Name -> IsRoot -> [Dec]
mkTableFileIdentifier :: Name -> IsRoot -> [Dec]
mkTableFileIdentifier Name
tableName IsRoot
isRoot =
case IsRoot
isRoot of
IsRoot
NotRoot -> []
IsRoot Maybe Text
Nothing -> []
IsRoot (Just Text
fileIdentifier) ->
[ Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD
Maybe Overlap
forall a. Maybe a
Nothing
[]
(Name -> Type
ConT ''HasFileIdentifier Type -> Type -> Type
`AppT` Name -> Type
ConT Name
tableName)
[ Name -> [Clause] -> Dec
FunD 'getFileIdentifier
[ [Pat] -> Body -> [Dec] -> Clause
Clause
[]
(Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'unsafeFileIdentifier Exp -> Exp -> Exp
`AppE` Text -> Exp
textLitE Text
fileIdentifier)
[]
]
]
]
mkTableConstructor :: Name -> TableDecl -> Q (Dec, Dec)
mkTableConstructor :: Name -> TableDecl -> Q (Dec, Dec)
mkTableConstructor Name
tableName TableDecl
table = do
(Cxt
argTypes, [Pat]
pats, [Exp]
exps) <- [(Cxt, [Pat], [Exp])] -> (Cxt, [Pat], [Exp])
forall a. Monoid a => [a] -> a
mconcat ([(Cxt, [Pat], [Exp])] -> (Cxt, [Pat], [Exp]))
-> Q [(Cxt, [Pat], [Exp])] -> Q (Cxt, [Pat], [Exp])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TableField -> Q (Cxt, [Pat], [Exp]))
-> [TableField] -> Q [(Cxt, [Pat], [Exp])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TableField -> Q (Cxt, [Pat], [Exp])
mkTableContructorArg (TableDecl -> [TableField]
tableFields TableDecl
table)
let retType :: Type
retType = Type -> Type -> Type
AppT (Name -> Type
ConT ''WriteTable) (Name -> Type
ConT Name
tableName)
let sigType :: Type
sigType = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
(~>) Type
retType Cxt
argTypes
let consName :: Name
consName = Text -> Name
mkName' (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ TableDecl -> Text
forall a. HasIdent a => a -> Text
NC.dataTypeConstructor TableDecl
table
let consSig :: Dec
consSig = Name -> Type -> Dec
SigD Name
consName Type
sigType
let body :: Body
body = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'writeTable) ([Exp] -> Exp
ListE [Exp]
exps)
let cons :: Dec
cons = Name -> [Clause] -> Dec
FunD Name
consName [ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
pats Body
body [] ]
(Dec, Dec) -> Q (Dec, Dec)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
consSig, Dec
cons)
mkTableContructorArg :: TableField -> Q ([Type], [Pat], [Exp])
mkTableContructorArg :: TableField -> Q (Cxt, [Pat], [Exp])
mkTableContructorArg TableField
tf =
if TableField -> Bool
tableFieldDeprecated TableField
tf
then
case TableField -> TableFieldType
tableFieldType TableField
tf of
TUnion TypeRef
_ Required
_ -> (Cxt, [Pat], [Exp]) -> Q (Cxt, [Pat], [Exp])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], [Name -> Exp
VarE 'deprecated, Name -> Exp
VarE 'deprecated])
TVector Required
_ (VUnion TypeRef
_) -> (Cxt, [Pat], [Exp]) -> Q (Cxt, [Pat], [Exp])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], [Name -> Exp
VarE 'deprecated, Name -> Exp
VarE 'deprecated])
TableFieldType
_ -> (Cxt, [Pat], [Exp]) -> Q (Cxt, [Pat], [Exp])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], [Name -> Exp
VarE 'deprecated])
else do
Name
argName <- Text -> Q Name
newName' (Text -> Q Name) -> Text -> Q Name
forall a b. (a -> b) -> a -> b
$ TableField -> Text
forall a. HasIdent a => a -> Text
NC.arg TableField
tf
let argPat :: Pat
argPat = Name -> Pat
VarP Name
argName
let argRef :: Exp
argRef = Name -> Exp
VarE Name
argName
let argType :: Type
argType = TableFieldType -> Type
tableFieldTypeToWriteType (TableField -> TableFieldType
tableFieldType TableField
tf)
let exps :: [Exp]
exps = Exp -> TableFieldType -> [Exp]
mkExps Exp
argRef (TableField -> TableFieldType
tableFieldType TableField
tf)
(Cxt, [Pat], [Exp]) -> Q (Cxt, [Pat], [Exp])
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type
Item Cxt
argType], [Pat
Item [Pat]
argPat], [Exp]
exps)
where
expForScalar :: Exp -> Exp -> Exp -> Exp
expForScalar :: Exp -> Exp -> Exp -> Exp
expForScalar Exp
defaultValExp Exp
writeExp Exp
varExp =
Name -> Exp
VarE 'optionalDef Exp -> Exp -> Exp
`AppE` Exp
defaultValExp Exp -> Exp -> Exp
`AppE` Exp
writeExp Exp -> Exp -> Exp
`AppE` Exp
varExp
expForNonScalar :: Required -> Exp -> Exp -> Exp
expForNonScalar :: Required -> Exp -> Exp -> Exp
expForNonScalar Required
Req Exp
exp Exp
argRef = Exp
exp Exp -> Exp -> Exp
`AppE` Exp
argRef
expForNonScalar Required
Opt Exp
exp Exp
argRef = Name -> Exp
VarE 'optional Exp -> Exp -> Exp
`AppE` Exp
exp Exp -> Exp -> Exp
`AppE` Exp
argRef
mkExps :: Exp -> TableFieldType -> [Exp]
mkExps :: Exp -> TableFieldType -> [Exp]
mkExps Exp
argRef TableFieldType
tfType =
case TableFieldType
tfType of
TInt8 (DefaultVal Integer
n) -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
expForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'writeInt8TableField ) Exp
argRef
TInt16 (DefaultVal Integer
n) -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
expForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'writeInt16TableField ) Exp
argRef
TInt32 (DefaultVal Integer
n) -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
expForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'writeInt32TableField ) Exp
argRef
TInt64 (DefaultVal Integer
n) -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
expForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'writeInt64TableField ) Exp
argRef
TWord8 (DefaultVal Integer
n) -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
expForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'writeWord8TableField ) Exp
argRef
TWord16 (DefaultVal Integer
n) -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
expForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'writeWord16TableField ) Exp
argRef
TWord32 (DefaultVal Integer
n) -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
expForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'writeWord32TableField ) Exp
argRef
TWord64 (DefaultVal Integer
n) -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
expForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'writeWord64TableField ) Exp
argRef
TFloat (DefaultVal Scientific
n) -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
expForScalar (Scientific -> Exp
forall i. Real i => i -> Exp
realLitE Scientific
n) (Name -> Exp
VarE 'writeFloatTableField ) Exp
argRef
TDouble (DefaultVal Scientific
n) -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
expForScalar (Scientific -> Exp
forall i. Real i => i -> Exp
realLitE Scientific
n) (Name -> Exp
VarE 'writeDoubleTableField ) Exp
argRef
TBool (DefaultVal Bool
b) -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
expForScalar (if Bool
b then Name -> Exp
ConE 'True else Name -> Exp
ConE 'False) (Name -> Exp
VarE 'writeBoolTableField) Exp
argRef
TString Required
req -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeTextTableField) Exp
argRef
TEnum TypeRef
_ EnumType
enumType DefaultVal Integer
dflt -> Exp -> TableFieldType -> [Exp]
mkExps Exp
argRef (EnumType -> DefaultVal Integer -> TableFieldType
forall a. Integral a => EnumType -> DefaultVal a -> TableFieldType
enumTypeToTableFieldType EnumType
enumType DefaultVal Integer
dflt)
TStruct TypeRef
_ Required
req -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeStructTableField) Exp
argRef
TTable TypeRef
_ Required
req -> Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> Exp -> [Exp]
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeTableTableField) Exp
argRef
TUnion TypeRef
_ Required
req ->
[ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeUnionTypeTableField) Exp
argRef
, Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeUnionValueTableField) Exp
argRef
]
TVector Required
req VectorElementType
vecElemType -> Exp -> Required -> VectorElementType -> [Exp]
mkExpForVector Exp
argRef Required
req VectorElementType
vecElemType
mkExpForVector :: Exp -> Required -> VectorElementType -> [Exp]
mkExpForVector :: Exp -> Required -> VectorElementType -> [Exp]
mkExpForVector Exp
argRef Required
req VectorElementType
vecElemType =
case VectorElementType
vecElemType of
VectorElementType
VInt8 -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorInt8TableField) Exp
argRef ]
VectorElementType
VInt16 -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorInt16TableField) Exp
argRef ]
VectorElementType
VInt32 -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorInt32TableField) Exp
argRef ]
VectorElementType
VInt64 -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorInt64TableField) Exp
argRef ]
VectorElementType
VWord8 -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorWord8TableField) Exp
argRef ]
VectorElementType
VWord16 -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorWord16TableField) Exp
argRef ]
VectorElementType
VWord32 -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorWord32TableField) Exp
argRef ]
VectorElementType
VWord64 -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorWord64TableField) Exp
argRef ]
VectorElementType
VFloat -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorFloatTableField) Exp
argRef ]
VectorElementType
VDouble -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorDoubleTableField) Exp
argRef ]
VectorElementType
VBool -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorBoolTableField) Exp
argRef ]
VectorElementType
VString -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorTextTableField) Exp
argRef ]
VEnum TypeRef
_ EnumType
enumType -> Exp -> Required -> VectorElementType -> [Exp]
mkExpForVector Exp
argRef Required
req (EnumType -> VectorElementType
enumTypeToVectorElementType EnumType
enumType)
VStruct TypeRef
_ -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorStructTableField) Exp
argRef ]
VTable TypeRef
_ -> [ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeVectorTableTableField) Exp
argRef ]
VUnion TypeRef
_ ->
[ Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeUnionTypesVectorTableField) Exp
argRef
, Required -> Exp -> Exp -> Exp
expForNonScalar Required
req (Name -> Exp
VarE 'writeUnionValuesVectorTableField) Exp
argRef
]
mkTableFieldGetter :: Name -> TableDecl -> TableField -> [Dec]
mkTableFieldGetter :: Name -> TableDecl -> TableField -> [Dec]
mkTableFieldGetter Name
tableName TableDecl
table TableField
tf =
if TableField -> Bool
tableFieldDeprecated TableField
tf
then []
else [Dec
Item [Dec]
sig, TableFieldType -> Dec
mkFun (TableField -> TableFieldType
tableFieldType TableField
tf)]
where
funName :: Name
funName = [Char] -> Name
mkName (Text -> [Char]
T.unpack (TableDecl -> TableField -> Text
forall parent val.
(HasIdent parent, HasIdent val) =>
parent -> val -> Text
NC.getter TableDecl
table TableField
tf))
fieldIndex :: Exp
fieldIndex = Integer -> Exp
forall i. Integral i => i -> Exp
intLitE (TableField -> Integer
tableFieldId TableField
tf)
sig :: Dec
sig =
Name -> Type -> Dec
SigD Name
funName (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$
Name -> Type
ConT ''Table Type -> Type -> Type
`AppT` Name -> Type
ConT Name
tableName Type -> Type -> Type
~> Name -> Type
ConT ''Either Type -> Type -> Type
`AppT` Name -> Type
ConT ''ReadError Type -> Type -> Type
`AppT` TableFieldType -> Type
tableFieldTypeToReadType (TableField -> TableFieldType
tableFieldType TableField
tf)
mkFun :: TableFieldType -> Dec
mkFun :: TableFieldType -> Dec
mkFun TableFieldType
tft =
case TableFieldType
tft of
TWord8 (DefaultVal Integer
n) -> Exp -> Dec
mkFunWithBody (Exp -> Exp -> Exp
bodyForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'readWord8))
TWord16 (DefaultVal Integer
n) -> Exp -> Dec
mkFunWithBody (Exp -> Exp -> Exp
bodyForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'readWord16))
TWord32 (DefaultVal Integer
n) -> Exp -> Dec
mkFunWithBody (Exp -> Exp -> Exp
bodyForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'readWord32))
TWord64 (DefaultVal Integer
n) -> Exp -> Dec
mkFunWithBody (Exp -> Exp -> Exp
bodyForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'readWord64))
TInt8 (DefaultVal Integer
n) -> Exp -> Dec
mkFunWithBody (Exp -> Exp -> Exp
bodyForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'readInt8))
TInt16 (DefaultVal Integer
n) -> Exp -> Dec
mkFunWithBody (Exp -> Exp -> Exp
bodyForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'readInt16))
TInt32 (DefaultVal Integer
n) -> Exp -> Dec
mkFunWithBody (Exp -> Exp -> Exp
bodyForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'readInt32))
TInt64 (DefaultVal Integer
n) -> Exp -> Dec
mkFunWithBody (Exp -> Exp -> Exp
bodyForScalar (Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
n) (Name -> Exp
VarE 'readInt64))
TFloat (DefaultVal Scientific
n) -> Exp -> Dec
mkFunWithBody (Exp -> Exp -> Exp
bodyForScalar (Scientific -> Exp
forall i. Real i => i -> Exp
realLitE Scientific
n) (Name -> Exp
VarE 'readFloat))
TDouble (DefaultVal Scientific
n) -> Exp -> Dec
mkFunWithBody (Exp -> Exp -> Exp
bodyForScalar (Scientific -> Exp
forall i. Real i => i -> Exp
realLitE Scientific
n) (Name -> Exp
VarE 'readDouble))
TBool (DefaultVal Bool
b) -> Exp -> Dec
mkFunWithBody (Exp -> Exp -> Exp
bodyForScalar (if Bool
b then Name -> Exp
ConE 'True else Name -> Exp
ConE 'False) (Name -> Exp
VarE 'readBool))
TString Required
req -> Exp -> Dec
mkFunWithBody (Required -> Exp -> Exp
bodyForNonScalar Required
req (Name -> Exp
VarE 'readText))
TEnum TypeRef
_ EnumType
enumType DefaultVal Integer
dflt -> TableFieldType -> Dec
mkFun (TableFieldType -> Dec) -> TableFieldType -> Dec
forall a b. (a -> b) -> a -> b
$ EnumType -> DefaultVal Integer -> TableFieldType
forall a. Integral a => EnumType -> DefaultVal a -> TableFieldType
enumTypeToTableFieldType EnumType
enumType DefaultVal Integer
dflt
TStruct TypeRef
_ Required
req -> Exp -> Dec
mkFunWithBody (Required -> Exp -> Exp
bodyForNonScalar Required
req ([Exp] -> Exp
compose [Name -> Exp
ConE 'Right, Name -> Exp
VarE 'readStruct]))
TTable TypeRef
_ Required
req -> Exp -> Dec
mkFunWithBody (Required -> Exp -> Exp
bodyForNonScalar Required
req (Name -> Exp
VarE 'readTable))
TUnion (TypeRef Namespace
ns Ident
ident) Required
req -> do
let readUnionFunName :: Exp
readUnionFunName = Name -> Exp
VarE (Name -> Exp) -> (Text -> Name) -> Text -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
mkName ([Char] -> Name) -> (Text -> [Char]) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> Text -> Text
NC.withModulePrefix Namespace
ns (Text -> Exp) -> Text -> Exp
forall a b. (a -> b) -> a -> b
$ Ident -> Text
forall a. HasIdent a => a -> Text
NC.readUnionFun Ident
ident
Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
app
case Required
req of
Required
Req ->
[ Name -> Exp
VarE 'readTableFieldUnionReq
, Exp
Item [Exp]
readUnionFunName
, Exp
Item [Exp]
fieldIndex
, Text -> Exp
Text -> Item [Exp]
stringLitE (Text -> Item [Exp])
-> (TableField -> Text) -> TableField -> Item [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
unIdent (Ident -> Text) -> (TableField -> Ident) -> TableField -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableField -> Ident
forall a. HasIdent a => a -> Ident
getIdent (TableField -> Item [Exp]) -> TableField -> Item [Exp]
forall a b. (a -> b) -> a -> b
$ TableField
tf
]
Required
Opt ->
[ Name -> Exp
VarE 'readTableFieldUnionOpt
, Exp
Item [Exp]
readUnionFunName
, Exp
Item [Exp]
fieldIndex
]
TVector Required
req VectorElementType
vecElemType -> Required -> VectorElementType -> Dec
mkFunForVector Required
req VectorElementType
vecElemType
mkFunForVector :: Required -> VectorElementType -> Dec
mkFunForVector :: Required -> VectorElementType -> Dec
mkFunForVector Required
req VectorElementType
vecElemType =
case VectorElementType
vecElemType of
VectorElementType
VInt8 -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorInt8
VectorElementType
VInt16 -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorInt16
VectorElementType
VInt32 -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorInt32
VectorElementType
VInt64 -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorInt64
VectorElementType
VWord8 -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorWord8
VectorElementType
VWord16 -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorWord16
VectorElementType
VWord32 -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorWord32
VectorElementType
VWord64 -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorWord64
VectorElementType
VFloat -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorFloat
VectorElementType
VDouble -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorDouble
VectorElementType
VBool -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorBool
VectorElementType
VString -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorText
VEnum TypeRef
_ EnumType
enumType -> Required -> VectorElementType -> Dec
mkFunForVector Required
req (EnumType -> VectorElementType
enumTypeToVectorElementType EnumType
enumType)
VStruct TypeRef
_ -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readPrimVector Exp -> Exp -> Exp
`AppE` Name -> Exp
ConE 'VectorStruct
VTable TypeRef
_ -> Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ Required -> Exp -> Exp
bodyForNonScalar Required
req (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'readTableVector
VUnion (TypeRef Namespace
ns Ident
ident) ->
Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$
case Required
req of
Required
Opt -> [Exp] -> Exp
app
[ Name -> Exp
VarE 'readTableFieldUnionVectorOpt
, Name -> Exp
Name -> Item [Exp]
VarE (Name -> Item [Exp]) -> (Text -> Name) -> Text -> Item [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
mkName ([Char] -> Name) -> (Text -> [Char]) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> Text -> Text
NC.withModulePrefix Namespace
ns (Text -> Item [Exp]) -> Text -> Item [Exp]
forall a b. (a -> b) -> a -> b
$ Ident -> Text
forall a. HasIdent a => a -> Text
NC.readUnionFun Ident
ident
, Exp
Item [Exp]
fieldIndex
]
Required
Req -> [Exp] -> Exp
app
[ Name -> Exp
VarE 'readTableFieldUnionVectorReq
, Name -> Exp
Name -> Item [Exp]
VarE (Name -> Item [Exp]) -> (Text -> Name) -> Text -> Item [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
mkName ([Char] -> Name) -> (Text -> [Char]) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> Text -> Text
NC.withModulePrefix Namespace
ns (Text -> Item [Exp]) -> Text -> Item [Exp]
forall a b. (a -> b) -> a -> b
$ Ident -> Text
forall a. HasIdent a => a -> Text
NC.readUnionFun Ident
ident
, Exp
Item [Exp]
fieldIndex
, Text -> Exp
Text -> Item [Exp]
stringLitE (Text -> Item [Exp])
-> (TableField -> Text) -> TableField -> Item [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
unIdent (Ident -> Text) -> (TableField -> Ident) -> TableField -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableField -> Ident
forall a. HasIdent a => a -> Ident
getIdent (TableField -> Item [Exp]) -> TableField -> Item [Exp]
forall a b. (a -> b) -> a -> b
$ TableField
tf
]
mkFunWithBody :: Exp -> Dec
mkFunWithBody :: Exp -> Dec
mkFunWithBody Exp
body = Name -> [Clause] -> Dec
FunD Name
funName [ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) [] ]
bodyForNonScalar :: Required -> Exp -> Exp
bodyForNonScalar Required
req Exp
readExp =
case Required
req of
Required
Req ->
[Exp] -> Exp
app
[ Name -> Exp
VarE 'readTableFieldReq
, Exp
Item [Exp]
readExp
, Exp
Item [Exp]
fieldIndex
, Text -> Exp
Text -> Item [Exp]
stringLitE (Text -> Item [Exp])
-> (TableField -> Text) -> TableField -> Item [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
unIdent (Ident -> Text) -> (TableField -> Ident) -> TableField -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableField -> Ident
forall a. HasIdent a => a -> Ident
getIdent (TableField -> Item [Exp]) -> TableField -> Item [Exp]
forall a b. (a -> b) -> a -> b
$ TableField
tf
]
Required
Opt ->
[Exp] -> Exp
app
[ Name -> Exp
VarE 'readTableFieldOpt
, Exp
Item [Exp]
readExp
, Exp
Item [Exp]
fieldIndex
]
bodyForScalar :: Exp -> Exp -> Exp
bodyForScalar Exp
defaultValExp Exp
readExp =
[Exp] -> Exp
app
[ Name -> Exp
VarE 'readTableFieldWithDef
, Exp
Item [Exp]
readExp
, Exp
Item [Exp]
fieldIndex
, Exp
Item [Exp]
defaultValExp
]
mkUnion :: UnionDecl -> Q [Dec]
mkUnion :: UnionDecl -> Q [Dec]
mkUnion UnionDecl
union = do
let unionName :: Name
unionName = Text -> Name
mkName' (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ UnionDecl -> Text
forall a. HasIdent a => a -> Text
NC.dataTypeName UnionDecl
union
let unionValNames :: NonEmpty Name
unionValNames = UnionDecl -> NonEmpty UnionVal
unionVals UnionDecl
union NonEmpty UnionVal -> (UnionVal -> Name) -> NonEmpty Name
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \UnionVal
unionVal ->
[Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ UnionDecl -> UnionVal -> Text
forall parent val.
(HasIdent parent, HasIdent val) =>
parent -> val -> Text
NC.enumUnionMember UnionDecl
union UnionVal
unionVal
[Dec]
unionConstructors <- Name -> UnionDecl -> Q [Dec]
mkUnionConstructors Name
unionName UnionDecl
union
[Dec]
readFun <- Name -> NonEmpty Name -> UnionDecl -> Q [Dec]
mkReadUnionFun Name
unionName NonEmpty Name
unionValNames UnionDecl
union
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
Name -> NonEmpty (UnionVal, Name) -> Dec
mkUnionDataDec Name
unionName (UnionDecl -> NonEmpty UnionVal
unionVals UnionDecl
union NonEmpty UnionVal -> NonEmpty Name -> NonEmpty (UnionVal, Name)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
`NE.zip` NonEmpty Name
unionValNames)
Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
unionConstructors
[Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
readFun
mkUnionDataDec :: Name -> NonEmpty (UnionVal, Name) -> Dec
mkUnionDataDec :: Name -> NonEmpty (UnionVal, Name) -> Dec
mkUnionDataDec Name
unionName NonEmpty (UnionVal, Name)
unionValsAndNames =
Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
unionName [] Maybe Type
forall a. Maybe a
Nothing
(NonEmpty Con -> [Con]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Con -> [Con]) -> NonEmpty Con -> [Con]
forall a b. (a -> b) -> a -> b
$ ((UnionVal, Name) -> Con)
-> NonEmpty (UnionVal, Name) -> NonEmpty Con
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UnionVal, Name) -> Con
mkCons NonEmpty (UnionVal, Name)
unionValsAndNames)
[]
where
mkCons :: (UnionVal, Name) -> Con
mkCons (UnionVal
unionVal, Name
unionValName) =
Name -> [BangType] -> Con
NormalC Name
unionValName [(Bang
bang, Name -> Type
ConT ''Table Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType (UnionVal -> TypeRef
unionValTableRef UnionVal
unionVal))]
bang :: Bang
bang = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict
mkUnionConstructors :: Name -> UnionDecl -> Q [Dec]
mkUnionConstructors :: Name -> UnionDecl -> Q [Dec]
mkUnionConstructors Name
unionName UnionDecl
union =
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Q [[Dec]] -> Q [Dec])
-> ([(UnionVal, Integer)] -> Q [[Dec]])
-> [(UnionVal, Integer)]
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UnionVal, Integer) -> Q [Dec])
-> [(UnionVal, Integer)] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (UnionVal, Integer) -> Q [Dec]
mkUnionConstructor ([(UnionVal, Integer)] -> Q [Dec])
-> [(UnionVal, Integer)] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ NonEmpty UnionVal -> [UnionVal]
forall a. NonEmpty a -> [a]
NE.toList (UnionDecl -> NonEmpty UnionVal
unionVals UnionDecl
union) [UnionVal] -> [Integer] -> [(UnionVal, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Integer
Item [Integer]
1..]
where
mkUnionConstructor :: (UnionVal, Integer) -> Q [Dec]
mkUnionConstructor :: (UnionVal, Integer) -> Q [Dec]
mkUnionConstructor (UnionVal
unionVal, Integer
ix) = do
let constructorName :: Name
constructorName = Text -> Name
mkName' (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ UnionDecl -> UnionVal -> Text
NC.unionConstructor UnionDecl
union UnionVal
unionVal
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Name -> Type -> Dec
SigD Name
constructorName (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$
Name -> Type
ConT ''WriteTable Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType (UnionVal -> TypeRef
unionValTableRef UnionVal
unionVal)
Type -> Type -> Type
~> Name -> Type
ConT ''WriteUnion Type -> Type -> Type
`AppT` Name -> Type
ConT Name
unionName
, Name -> [Clause] -> Dec
FunD Name
constructorName
[ [Pat] -> Body -> [Dec] -> Clause
Clause
[]
(Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'writeUnion Exp -> Exp -> Exp
`AppE` Integer -> Exp
forall i. Integral i => i -> Exp
intLitE Integer
ix)
[]
]
]
mkReadUnionFun :: Name -> NonEmpty Name -> UnionDecl -> Q [Dec]
mkReadUnionFun :: Name -> NonEmpty Name -> UnionDecl -> Q [Dec]
mkReadUnionFun Name
unionName NonEmpty Name
unionValNames UnionDecl
union = do
Name
nArg <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"n"
Name
posArg <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"pos"
Name
wildcard <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"n'"
let funName :: Name
funName = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ UnionDecl -> Text
forall a. HasIdent a => a -> Text
NC.readUnionFun UnionDecl
union
let sig :: Dec
sig =
Name -> Type -> Dec
SigD Name
funName (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$
Name -> Type
ConT ''Positive Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word8
Type -> Type -> Type
~> Name -> Type
ConT ''PositionInfo
Type -> Type -> Type
~> Name -> Type
ConT ''Either Type -> Type -> Type
`AppT` Name -> Type
ConT ''ReadError Type -> Type -> Type
`AppT` (Name -> Type
ConT ''Union Type -> Type -> Type
`AppT` Name -> Type
ConT Name
unionName)
let
mkMatch :: Name -> Integer -> Match
mkMatch :: Name -> Integer -> Match
mkMatch Name
unionValName Integer
ix =
Pat -> Body -> [Dec] -> Match
Match
(Integer -> Pat
forall i. Integral i => i -> Pat
intLitP Integer
ix)
(Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just ([Exp] -> Exp
compose [Name -> Exp
ConE 'Union, Name -> Exp
ConE Name
unionValName]))
(Name -> Exp
VarE '(<$>))
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE 'readTable' Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
posArg))
)
[]
let matchWildcard :: Match
matchWildcard =
Pat -> Body -> [Dec] -> Match
Match
(Name -> Pat
VarP Name
wildcard)
(Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE 'pure))
(Name -> Exp
VarE '($!))
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
ConE 'UnionUnknown Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
wildcard))
)
[]
let matches :: [Match]
matches = ((Name -> Integer -> Match) -> (Name, Integer) -> Match
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Integer -> Match
mkMatch ((Name, Integer) -> Match) -> [(Name, Integer)] -> [Match]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Name -> [Name]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Name
unionValNames [Name] -> [Integer] -> [(Name, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Integer
Item [Integer]
1..]) [Match] -> [Match] -> [Match]
forall a. Semigroup a => a -> a -> a
<> [Match
Item [Match]
matchWildcard]
let funBody :: Body
funBody =
Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
Exp -> [Match] -> Exp
CaseE
(Name -> Exp
VarE 'getPositive Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
nArg)
[Match]
matches
let fun :: Dec
fun =
Name -> [Clause] -> Dec
FunD Name
funName
[ [Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> Pat
VarP Name
nArg, Name -> Pat
VarP Name
posArg]
Body
funBody
[]
]
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
Item [Dec]
sig, Dec
Item [Dec]
fun]
enumTypeToType :: EnumType -> Type
enumTypeToType :: EnumType -> Type
enumTypeToType EnumType
et =
case EnumType
et of
EnumType
EInt8 -> Name -> Type
ConT ''Int8
EnumType
EInt16 -> Name -> Type
ConT ''Int16
EnumType
EInt32 -> Name -> Type
ConT ''Int32
EnumType
EInt64 -> Name -> Type
ConT ''Int64
EnumType
EWord8 -> Name -> Type
ConT ''Word8
EnumType
EWord16 -> Name -> Type
ConT ''Word16
EnumType
EWord32 -> Name -> Type
ConT ''Word32
EnumType
EWord64 -> Name -> Type
ConT ''Word64
enumTypeToTableFieldType :: Integral a => EnumType -> DefaultVal a -> TableFieldType
enumTypeToTableFieldType :: forall a. Integral a => EnumType -> DefaultVal a -> TableFieldType
enumTypeToTableFieldType EnumType
et DefaultVal a
dflt =
case EnumType
et of
EnumType
EInt8 -> DefaultVal Integer -> TableFieldType
TInt8 (DefaultVal a -> DefaultVal Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral DefaultVal a
dflt)
EnumType
EInt16 -> DefaultVal Integer -> TableFieldType
TInt16 (DefaultVal a -> DefaultVal Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral DefaultVal a
dflt)
EnumType
EInt32 -> DefaultVal Integer -> TableFieldType
TInt32 (DefaultVal a -> DefaultVal Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral DefaultVal a
dflt)
EnumType
EInt64 -> DefaultVal Integer -> TableFieldType
TInt64 (DefaultVal a -> DefaultVal Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral DefaultVal a
dflt)
EnumType
EWord8 -> DefaultVal Integer -> TableFieldType
TWord8 (DefaultVal a -> DefaultVal Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral DefaultVal a
dflt)
EnumType
EWord16 -> DefaultVal Integer -> TableFieldType
TWord16 (DefaultVal a -> DefaultVal Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral DefaultVal a
dflt)
EnumType
EWord32 -> DefaultVal Integer -> TableFieldType
TWord32 (DefaultVal a -> DefaultVal Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral DefaultVal a
dflt)
EnumType
EWord64 -> DefaultVal Integer -> TableFieldType
TWord64 (DefaultVal a -> DefaultVal Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral DefaultVal a
dflt)
enumTypeToStructFieldType :: EnumType -> StructFieldType
enumTypeToStructFieldType :: EnumType -> StructFieldType
enumTypeToStructFieldType EnumType
et =
case EnumType
et of
EnumType
EInt8 -> StructFieldType
SInt8
EnumType
EInt16 -> StructFieldType
SInt16
EnumType
EInt32 -> StructFieldType
SInt32
EnumType
EInt64 -> StructFieldType
SInt64
EnumType
EWord8 -> StructFieldType
SWord8
EnumType
EWord16 -> StructFieldType
SWord16
EnumType
EWord32 -> StructFieldType
SWord32
EnumType
EWord64 -> StructFieldType
SWord64
enumTypeToVectorElementType :: EnumType -> VectorElementType
enumTypeToVectorElementType :: EnumType -> VectorElementType
enumTypeToVectorElementType EnumType
et =
case EnumType
et of
EnumType
EInt8 -> VectorElementType
VInt8
EnumType
EInt16 -> VectorElementType
VInt16
EnumType
EInt32 -> VectorElementType
VInt32
EnumType
EInt64 -> VectorElementType
VInt64
EnumType
EWord8 -> VectorElementType
VWord8
EnumType
EWord16 -> VectorElementType
VWord16
EnumType
EWord32 -> VectorElementType
VWord32
EnumType
EWord64 -> VectorElementType
VWord64
structFieldTypeToWriteType :: StructFieldType -> Type
structFieldTypeToWriteType :: StructFieldType -> Type
structFieldTypeToWriteType StructFieldType
sft =
case StructFieldType
sft of
StructFieldType
SInt8 -> Name -> Type
ConT ''Int8
StructFieldType
SInt16 -> Name -> Type
ConT ''Int16
StructFieldType
SInt32 -> Name -> Type
ConT ''Int32
StructFieldType
SInt64 -> Name -> Type
ConT ''Int64
StructFieldType
SWord8 -> Name -> Type
ConT ''Word8
StructFieldType
SWord16 -> Name -> Type
ConT ''Word16
StructFieldType
SWord32 -> Name -> Type
ConT ''Word32
StructFieldType
SWord64 -> Name -> Type
ConT ''Word64
StructFieldType
SFloat -> Name -> Type
ConT ''Float
StructFieldType
SDouble -> Name -> Type
ConT ''Double
StructFieldType
SBool -> Name -> Type
ConT ''Bool
SEnum TypeRef
_ EnumType
enumType -> EnumType -> Type
enumTypeToType EnumType
enumType
SStruct (Namespace
namespace, StructDecl
structDecl) ->
Name -> Type
ConT ''WriteStruct Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType (Namespace -> Ident -> TypeRef
TypeRef Namespace
namespace (StructDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent StructDecl
structDecl))
structFieldTypeToReadType :: StructFieldType -> Type
structFieldTypeToReadType :: StructFieldType -> Type
structFieldTypeToReadType StructFieldType
sft =
case StructFieldType
sft of
StructFieldType
SInt8 -> Name -> Type
ConT ''Int8
StructFieldType
SInt16 -> Name -> Type
ConT ''Int16
StructFieldType
SInt32 -> Name -> Type
ConT ''Int32
StructFieldType
SInt64 -> Name -> Type
ConT ''Int64
StructFieldType
SWord8 -> Name -> Type
ConT ''Word8
StructFieldType
SWord16 -> Name -> Type
ConT ''Word16
StructFieldType
SWord32 -> Name -> Type
ConT ''Word32
StructFieldType
SWord64 -> Name -> Type
ConT ''Word64
StructFieldType
SFloat -> Name -> Type
ConT ''Float
StructFieldType
SDouble -> Name -> Type
ConT ''Double
StructFieldType
SBool -> Name -> Type
ConT ''Bool
SEnum TypeRef
_ EnumType
enumType -> EnumType -> Type
enumTypeToType EnumType
enumType
SStruct (Namespace
namespace, StructDecl
structDecl) ->
Name -> Type
ConT ''Struct Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType (Namespace -> Ident -> TypeRef
TypeRef Namespace
namespace (StructDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent StructDecl
structDecl))
tableFieldTypeToWriteType :: TableFieldType -> Type
tableFieldTypeToWriteType :: TableFieldType -> Type
tableFieldTypeToWriteType TableFieldType
tft =
case TableFieldType
tft of
TInt8 DefaultVal Integer
_ -> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Name -> Type
ConT ''Int8
TInt16 DefaultVal Integer
_ -> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Name -> Type
ConT ''Int16
TInt32 DefaultVal Integer
_ -> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Name -> Type
ConT ''Int32
TInt64 DefaultVal Integer
_ -> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Name -> Type
ConT ''Int64
TWord8 DefaultVal Integer
_ -> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word8
TWord16 DefaultVal Integer
_ -> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word16
TWord32 DefaultVal Integer
_ -> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word32
TWord64 DefaultVal Integer
_ -> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word64
TFloat DefaultVal Scientific
_ -> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Name -> Type
ConT ''Float
TDouble DefaultVal Scientific
_ -> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Name -> Type
ConT ''Double
TBool DefaultVal Bool
_ -> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` Name -> Type
ConT ''Bool
TString Required
req -> Required -> Type -> Type
requiredType Required
req (Name -> Type
ConT ''Text)
TEnum TypeRef
_ EnumType
enumType DefaultVal Integer
_ -> Name -> Type
ConT ''Maybe Type -> Type -> Type
`AppT` EnumType -> Type
enumTypeToType EnumType
enumType
TStruct TypeRef
typeRef Required
req -> Required -> Type -> Type
requiredType Required
req (Name -> Type
ConT ''WriteStruct Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType TypeRef
typeRef)
TTable TypeRef
typeRef Required
req -> Required -> Type -> Type
requiredType Required
req (Name -> Type
ConT ''WriteTable Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType TypeRef
typeRef)
TUnion TypeRef
typeRef Required
req -> Required -> Type -> Type
requiredType Required
req (Name -> Type
ConT ''WriteUnion Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType TypeRef
typeRef)
TVector Required
req VectorElementType
vecElemType -> Required -> Type -> Type
requiredType Required
req (VectorElementType -> Type
vectorElementTypeToWriteType VectorElementType
vecElemType)
tableFieldTypeToReadType :: TableFieldType -> Type
tableFieldTypeToReadType :: TableFieldType -> Type
tableFieldTypeToReadType TableFieldType
tft =
case TableFieldType
tft of
TInt8 DefaultVal Integer
_ -> Name -> Type
ConT ''Int8
TInt16 DefaultVal Integer
_ -> Name -> Type
ConT ''Int16
TInt32 DefaultVal Integer
_ -> Name -> Type
ConT ''Int32
TInt64 DefaultVal Integer
_ -> Name -> Type
ConT ''Int64
TWord8 DefaultVal Integer
_ -> Name -> Type
ConT ''Word8
TWord16 DefaultVal Integer
_ -> Name -> Type
ConT ''Word16
TWord32 DefaultVal Integer
_ -> Name -> Type
ConT ''Word32
TWord64 DefaultVal Integer
_ -> Name -> Type
ConT ''Word64
TFloat DefaultVal Scientific
_ -> Name -> Type
ConT ''Float
TDouble DefaultVal Scientific
_ -> Name -> Type
ConT ''Double
TBool DefaultVal Bool
_ -> Name -> Type
ConT ''Bool
TString Required
req -> Required -> Type -> Type
requiredType Required
req (Name -> Type
ConT ''Text)
TEnum TypeRef
_ EnumType
enumType DefaultVal Integer
_ -> EnumType -> Type
enumTypeToType EnumType
enumType
TStruct TypeRef
typeRef Required
req -> Required -> Type -> Type
requiredType Required
req (Name -> Type
ConT ''Struct Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType TypeRef
typeRef)
TTable TypeRef
typeRef Required
req -> Required -> Type -> Type
requiredType Required
req (Name -> Type
ConT ''Table Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType TypeRef
typeRef)
TUnion TypeRef
typeRef Required
req -> Required -> Type -> Type
requiredType Required
req (Name -> Type
ConT ''Union Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType TypeRef
typeRef)
TVector Required
req VectorElementType
vecElemType -> Required -> Type -> Type
requiredType Required
req (VectorElementType -> Type
vectorElementTypeToReadType VectorElementType
vecElemType)
vectorElementTypeToWriteType :: VectorElementType -> Type
vectorElementTypeToWriteType :: VectorElementType -> Type
vectorElementTypeToWriteType VectorElementType
vet =
case VectorElementType
vet of
VectorElementType
VInt8 -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Int8
VectorElementType
VInt16 -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Int16
VectorElementType
VInt32 -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Int32
VectorElementType
VInt64 -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Int64
VectorElementType
VWord8 -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word8
VectorElementType
VWord16 -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word16
VectorElementType
VWord32 -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word32
VectorElementType
VWord64 -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word64
VectorElementType
VFloat -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Float
VectorElementType
VDouble -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Double
VectorElementType
VBool -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Bool
VectorElementType
VString -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Text
VEnum TypeRef
_ EnumType
enumType -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` EnumType -> Type
enumTypeToType EnumType
enumType
VStruct TypeRef
typeRef -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` (Name -> Type
ConT ''WriteStruct Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType TypeRef
typeRef)
VTable TypeRef
typeRef -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` (Name -> Type
ConT ''WriteTable Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType TypeRef
typeRef)
VUnion TypeRef
typeRef -> Name -> Type
ConT ''WriteVector Type -> Type -> Type
`AppT` (Name -> Type
ConT ''WriteUnion Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType TypeRef
typeRef)
vectorElementTypeToReadType :: VectorElementType -> Type
vectorElementTypeToReadType :: VectorElementType -> Type
vectorElementTypeToReadType VectorElementType
vet =
case VectorElementType
vet of
VectorElementType
VInt8 -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Int8
VectorElementType
VInt16 -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Int16
VectorElementType
VInt32 -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Int32
VectorElementType
VInt64 -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Int64
VectorElementType
VWord8 -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word8
VectorElementType
VWord16 -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word16
VectorElementType
VWord32 -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word32
VectorElementType
VWord64 -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Word64
VectorElementType
VFloat -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Float
VectorElementType
VDouble -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Double
VectorElementType
VBool -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Bool
VectorElementType
VString -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` Name -> Type
ConT ''Text
VEnum TypeRef
_ EnumType
enumType -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` EnumType -> Type
enumTypeToType EnumType
enumType
VStruct TypeRef
typeRef -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` (Name -> Type
ConT ''Struct Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType TypeRef
typeRef)
VTable TypeRef
typeRef -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` (Name -> Type
ConT ''Table Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType TypeRef
typeRef)
VUnion TypeRef
typeRef -> Name -> Type
ConT ''Vector Type -> Type -> Type
`AppT` (Name -> Type
ConT ''Union Type -> Type -> Type
`AppT` TypeRef -> Type
typeRefToType TypeRef
typeRef)
typeRefToType :: TypeRef -> Type
typeRefToType :: TypeRef -> Type
typeRefToType (TypeRef Namespace
ns Ident
ident) =
Name -> Type
ConT (Name -> Type) -> (Ident -> Name) -> Ident -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Name
mkName' (Text -> Name) -> (Ident -> Text) -> Ident -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> Text -> Text
NC.withModulePrefix Namespace
ns (Text -> Text) -> (Ident -> Text) -> Ident -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
forall a. HasIdent a => a -> Text
NC.dataTypeName (Ident -> Type) -> Ident -> Type
forall a b. (a -> b) -> a -> b
$ Ident
ident
requiredType :: Required -> Type -> Type
requiredType :: Required -> Type -> Type
requiredType Required
Req Type
t = Type
t
requiredType Required
Opt Type
t = Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe) Type
t
mkName' :: Text -> Name
mkName' :: Text -> Name
mkName' = [Char] -> Name
mkName ([Char] -> Name) -> (Text -> [Char]) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack
newName' :: Text -> Q Name
newName' :: Text -> Q Name
newName' = [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName ([Char] -> Q Name) -> (Text -> [Char]) -> Text -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack
intLitP :: Integral i => i -> Pat
intLitP :: forall i. Integral i => i -> Pat
intLitP = Lit -> Pat
LitP (Lit -> Pat) -> (i -> Lit) -> i -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (i -> Integer) -> i -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Integer
forall a. Integral a => a -> Integer
toInteger
intLitE :: Integral i => i -> Exp
intLitE :: forall i. Integral i => i -> Exp
intLitE = Lit -> Exp
LitE (Lit -> Exp) -> (i -> Lit) -> i -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (i -> Integer) -> i -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Integer
forall a. Integral a => a -> Integer
toInteger
realLitE :: Real i => i -> Exp
realLitE :: forall i. Real i => i -> Exp
realLitE = Lit -> Exp
LitE (Lit -> Exp) -> (i -> Lit) -> i -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Lit
RationalL (Rational -> Lit) -> (i -> Rational) -> i -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Rational
forall a. Real a => a -> Rational
toRational
textLitE :: Text -> Exp
textLitE :: Text -> Exp
textLitE Text
t = Name -> Exp
VarE 'T.pack Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE ([Char] -> Lit
StringL (Text -> [Char]
T.unpack Text
t))
stringLitE :: Text -> Exp
stringLitE :: Text -> Exp
stringLitE Text
t = Lit -> Exp
LitE ([Char] -> Lit
StringL (Text -> [Char]
T.unpack Text
t))
inlinePragma :: Name -> Dec
inlinePragma :: Name -> Dec
inlinePragma Name
funName = Pragma -> Dec
PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
funName Inline
Inline RuleMatch
FunLike Phases
AllPhases
app :: [Exp] -> Exp
app :: [Exp] -> Exp
app = (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Exp -> Exp -> Exp
AppE
compose :: [Exp] -> Exp
compose :: [Exp] -> Exp
compose = (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Exp
e1 Exp
e2 -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
e1) (Name -> Exp
VarE '(.)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
e2))
nonEmptyUnzip3 :: NonEmpty (a,b,c) -> (NonEmpty a, NonEmpty b, NonEmpty c)
nonEmptyUnzip3 :: forall a b c.
NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)
nonEmptyUnzip3 NonEmpty (a, b, c)
xs =
( (\(a
x, b
_, c
_) -> a
x) ((a, b, c) -> a) -> NonEmpty (a, b, c) -> NonEmpty a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (a, b, c)
xs
, (\(a
_, b
x, c
_) -> b
x) ((a, b, c) -> b) -> NonEmpty (a, b, c) -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (a, b, c)
xs
, (\(a
_, b
_, c
x) -> c
x) ((a, b, c) -> c) -> NonEmpty (a, b, c) -> NonEmpty c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (a, b, c)
xs
)