{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TemplateHaskell #-}

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 qualified Data.List                                       as List
import           Data.List.NonEmpty                              ( NonEmpty(..) )
import qualified Data.List.NonEmpty                              as NE
import qualified Data.Map.Strict                                 as Map
import           Data.Text                                       ( Text )
import qualified Data.Text                                       as T
import           Data.Word

import           FlatBuffers.Internal.Build
import qualified FlatBuffers.Internal.Compiler.NamingConventions as NC
import qualified FlatBuffers.Internal.Compiler.ParserIO          as ParserIO
import           FlatBuffers.Internal.Compiler.SemanticAnalysis  ( SymbolTable(..) )
import qualified FlatBuffers.Internal.Compiler.SemanticAnalysis  as SemanticAnalysis
import qualified FlatBuffers.Internal.Compiler.SyntaxTree        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 qualified Language.Haskell.TH.Syntax                      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 -> [FilePath]
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 -> FilePath
(Int -> Options -> ShowS)
-> (Options -> FilePath) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> FilePath
$cshow :: Options -> FilePath
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show, Options -> Options -> Bool
(Options -> Options -> Bool)
-> (Options -> Options -> Bool) -> Eq Options
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options -> Options -> Bool
$c/= :: Options -> Options -> Bool
== :: Options -> Options -> Bool
$c== :: Options -> Options -> Bool
Eq)

-- | Default flatbuffers options:
--
-- > Options
-- >   { includeDirectories = []
-- >   , compileAllSchemas = False
-- >   }
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options :: [FilePath] -> Bool -> Options
Options
  { includeDirectories :: [FilePath]
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 :: FilePath -> Options -> Q [Dec]
mkFlatBuffers FilePath
rootFilePath Options
opts = do
  Text
currentModule <- FilePath -> Text
T.pack (FilePath -> Text) -> (Loc -> FilePath) -> Loc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> FilePath
loc_module (Loc -> Text) -> Q Loc -> Q Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location

  Either FilePath (FileTree Schema)
parseResult <- IO (Either FilePath (FileTree Schema))
-> Q (Either FilePath (FileTree Schema))
forall a. IO a -> Q a
runIO (IO (Either FilePath (FileTree Schema))
 -> Q (Either FilePath (FileTree Schema)))
-> IO (Either FilePath (FileTree Schema))
-> Q (Either FilePath (FileTree Schema))
forall a b. (a -> b) -> a -> b
$ ExceptT FilePath IO (FileTree Schema)
-> IO (Either FilePath (FileTree Schema))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT FilePath IO (FileTree Schema)
 -> IO (Either FilePath (FileTree Schema)))
-> ExceptT FilePath IO (FileTree Schema)
-> IO (Either FilePath (FileTree Schema))
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> ExceptT FilePath IO (FileTree Schema)
forall (m :: * -> *).
(MonadIO m, MonadError FilePath m) =>
FilePath -> [FilePath] -> m (FileTree Schema)
ParserIO.parseSchemas FilePath
rootFilePath (Options -> [FilePath]
includeDirectories Options
opts)

  FileTree Schema
schemaFileTree <- (FilePath -> Q (FileTree Schema))
-> (FileTree Schema -> Q (FileTree Schema))
-> Either FilePath (FileTree Schema)
-> Q (FileTree Schema)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> Q (FileTree Schema)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Q (FileTree Schema))
-> ShowS -> FilePath -> Q (FileTree Schema)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fixMsg) FileTree Schema -> Q (FileTree Schema)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either FilePath (FileTree Schema)
parseResult

  FileTree Schema -> Q ()
forall a. FileTree a -> Q ()
registerFiles FileTree Schema
schemaFileTree

  FileTree ValidDecls
symbolTables <- (FilePath -> Q (FileTree ValidDecls))
-> (FileTree ValidDecls -> Q (FileTree ValidDecls))
-> Either FilePath (FileTree ValidDecls)
-> Q (FileTree ValidDecls)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> Q (FileTree ValidDecls)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Q (FileTree ValidDecls))
-> ShowS -> FilePath -> Q (FileTree ValidDecls)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fixMsg) FileTree ValidDecls -> Q (FileTree ValidDecls)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath (FileTree ValidDecls) -> Q (FileTree ValidDecls))
-> Either FilePath (FileTree ValidDecls) -> Q (FileTree ValidDecls)
forall a b. (a -> b) -> a -> b
$ FileTree Schema -> Either FilePath (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 FilePath ValidDecls -> [ValidDecls]
forall k a. Map k a -> [a]
Map.elems (Map FilePath ValidDecls -> [ValidDecls])
-> Map FilePath ValidDecls -> [ValidDecls]
forall a b. (a -> b) -> a -> b
$ FileTree ValidDecls -> Map FilePath ValidDecls
forall a. FileTree a -> Map FilePath 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 FilePath
rootFilePath a
_ Map FilePath a
includedFiles) = do
      FilePath -> Q ()
TH.addDependentFile FilePath
rootFilePath
      (FilePath -> Q ()) -> [FilePath] -> Q ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ FilePath -> Q ()
TH.addDependentFile ([FilePath] -> Q ()) -> [FilePath] -> Q ()
forall a b. (a -> b) -> a -> b
$ Map FilePath a -> [FilePath]
forall k a. Map k a -> [k]
Map.keys Map FilePath 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 :: forall enum struct table union.
Map (Namespace, Ident) enum
-> Map (Namespace, Ident) struct
-> Map (Namespace, Ident) table
-> Map (Namespace, Ident) union
-> SymbolTable enum struct table union
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 = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
List.intercalate FilePath
"\n" ([FilePath] -> FilePath) -> (FilePath -> [FilePath]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
fixLine ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines
  where
    fixLine :: ShowS
fixLine FilePath
line = FilePath
" " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
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)
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)
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)
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)
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 (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 (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 = FilePath -> Name
mkName (FilePath -> Name) -> (EnumVal -> FilePath) -> EnumVal -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath) -> (EnumVal -> Text) -> EnumVal -> FilePath
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 (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 = FilePath -> Name
mkName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
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 <- FilePath -> Q Name
newName FilePath
"c"
  Name
firstRes <- FilePath -> Q Name
newName FilePath
"res0"
  [Dec]
firstClause <- [d| $(varP 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 (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 = FilePath -> Name
mkName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
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 (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 (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 <- FilePath -> Q Name
newName (FilePath
"res" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
ix)
      [Dec]
clause <-
        [d|
          $(varP res) = if $(varE name) .&. $(varE inputName) /= 0
                            then $(pure (textLitE ident)) : $(varE previousRes)
                            else $(varE 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 ->
        FilePath -> Name
mkName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
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 (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 (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 <- FilePath -> Q Name
newName FilePath
"n"
  [Dec] -> Q [Dec]
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 <- FilePath -> Q Name
newName FilePath
"n"
  [Dec] -> Q [Dec]
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 -> [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 <- FilePath -> Q Name
newName FilePath
"c"
  [Dec] -> Q [Dec]
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 -> [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 (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 (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 $(conT structName) where
      structAlignmentOf = $(lift . unAlignment  . structAlignment $ struct)
      structSizeOf      = $(lift . unInlineSize . structSize      $ 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)
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 (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 (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 (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 (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 = FilePath -> Name
mkName (Text -> FilePath
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 (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 (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)
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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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
_             ->
            [ Name -> Exp
VarE 'writeUnionTypeTableField Exp -> Exp -> Exp
`AppE` Exp
argRef
            , Name -> Exp
VarE 'writeUnionValueTableField Exp -> Exp -> Exp
`AppE` 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 = FilePath -> Name
mkName (Text -> FilePath
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 ->
          Exp -> Dec
mkFunWithBody (Exp -> Dec) -> Exp -> Dec
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
app
            [ Name -> Exp
VarE 'readTableFieldUnion
            , Name -> Exp
VarE (Name -> Exp) -> (Text -> Name) -> Text -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Name
mkName (FilePath -> Name) -> (Text -> FilePath) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
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
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
VarE (Name -> Exp) -> (Text -> Name) -> Text -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Name
mkName (FilePath -> Name) -> (Text -> FilePath) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
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
Item [Exp]
fieldIndex
                ]
              Required
Req -> [Exp] -> Exp
app
                [ Name -> Exp
VarE 'readTableFieldUnionVectorReq
                , Name -> Exp
VarE (Name -> Exp) -> (Text -> Name) -> Text -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Name
mkName (FilePath -> Name) -> (Text -> FilePath) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
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
Item [Exp]
fieldIndex
                , Text -> Exp
stringLitE (Text -> Exp) -> (TableField -> Text) -> TableField -> 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 -> Exp) -> TableField -> 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
stringLitE (Text -> Exp) -> (TableField -> Text) -> TableField -> 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 -> Exp) -> TableField -> 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 ->
        FilePath -> Name
mkName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
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 (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 (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 (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)
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` [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 (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 <- FilePath -> Q Name
newName FilePath
"n"
  Name
posArg <- FilePath -> Q Name
newName FilePath
"pos"
  Name
wildcard <- FilePath -> Q Name
newName FilePath
"n'"

  let funName :: Name
funName = FilePath -> Name
mkName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
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` [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 (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 :: 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
_        -> 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
_        -> 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' = FilePath -> Name
mkName (FilePath -> Name) -> (Text -> FilePath) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack

newName' :: Text -> Q Name
newName' :: Text -> Q Name
newName' = FilePath -> Q Name
newName (FilePath -> Q Name) -> (Text -> FilePath) -> Text -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack


intLitP :: Integral i => i -> Pat
intLitP :: 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 :: 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 :: 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 (FilePath -> Lit
StringL (Text -> FilePath
T.unpack Text
t))

stringLitE :: Text -> Exp
stringLitE :: Text -> Exp
stringLitE Text
t = Lit -> Exp
LitE (FilePath -> Lit
StringL (Text -> FilePath
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 (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 (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 :: 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
  )