{-# 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


-- | Helper method to create function types.
-- @ConT ''Int ~> ConT ''String === Int -> String@
(~>) :: 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 ~>

-- | Options to control how\/which flatbuffers constructors\/accessor should be generated.
--
-- Options can be set using record syntax on `defaultOptions` with the fields below.
--
-- > defaultOptions { compileAllSchemas = True }
data Options = Options
  { -- | Directories to search for @include@s (same as flatc @-I@ option).
    Options -> [[Char]]
includeDirectories :: [FilePath]
    -- | Generate code not just for the root schema,
    -- but for all schemas it includes as well
    -- (same as flatc @--gen-all@ option).
  , 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)

-- | Default flatbuffers options:
--
-- > Options
-- >   { includeDirectories = []
-- >   , compileAllSchemas = False
-- >   }
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options
  { includeDirectories :: [[Char]]
includeDirectories = []
  , compileAllSchemas :: Bool
compileAllSchemas = Bool
False
  }

-- | Generates constructors and accessors for all data types declared in the given flatbuffers
-- schema whose namespace matches the current module.
--
-- > namespace Data.Game;
-- >
-- > table Monster {}
--
-- > {-# LANGUAGE TemplateHaskell #-}
-- >
-- > module Data.Game where
-- > import FlatBuffers
-- >
-- > $(mkFlatBuffers "schemas/game.fbs" defaultOptions)
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

-- | This does two things:
--
-- 1. ghcid stops parsing an error when it finds a line that start with alphabetical characters or an empty lines,
--    so we prepend each line with an empty space to avoid this.
-- 2. we also remove any trailing \n, otherwise ghcid would stop parsing here and not show the source code location.
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]

-- | Generates a list with all the enum values, e.g.
--
-- > allColors = [colorsRed, colorsGreen, colorsBlue]
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]

-- | Generates @colorsNames@.
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)

-- | Generated declarations for a non-bit-flags enum.
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]
mkFromEnum :: Name -> EnumDecl -> NonEmpty (EnumVal, Name) -> Q [Dec]
mkFromEnum 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)))
        []

-- | Generates @colorsName@.
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

-- | Applies a function to multiple arguments. Assumes the list is not empty.
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
  )