{-# LANGUAGE LambdaCase #-}
module Data.Schema.C (genC) where

import           Control.Arrow   ((&&&))
import qualified Data.Char       as Char
import           Data.Fix        (Fix (..), foldFix)
import           Data.List.Split as List
import           Data.Schema     (Schema, SchemaF (..), Type (..))
import           Prettyprinter
import qualified Text.Casing     as Casing

genC :: Schema -> Doc ()
genC :: Schema -> Doc ()
genC (Fix (Sum (Just (String
mName, String
dName)) [Schema]
cons)) =
    [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
    ([Doc ()] -> Doc ())
-> ([Schema] -> [Doc ()]) -> [Schema] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ()
forall ann. Doc ann
line
    ([Doc ()] -> [Doc ()])
-> ([Schema] -> [Doc ()]) -> [Schema] -> [Doc ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Schema -> Doc ()) -> [Schema] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map ((StructName -> [StructField] -> Doc ())
-> (StructName, [StructField]) -> Doc ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry StructName -> [StructField] -> Doc ()
genDatatype ((StructName, [StructField]) -> Doc ())
-> (Schema -> (StructName, [StructField])) -> Schema -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Schema -> (StructName, [StructField])
flattenFields String
ns String
prefix)
    ([Schema] -> Doc ()) -> [Schema] -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Schema]
cons
  where
    ns :: String
ns = [String] -> String
namespaceFor ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
List.splitOn String
"." (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
mName
    prefix :: String
prefix = String -> String
toCamelSnake String
dName
genC Schema
s = String -> Doc ()
forall a. HasCallStack => String -> a
error (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ Schema -> String
forall a. Show a => a -> String
show Schema
s

namespaceFor :: [String] -> String
namespaceFor :: [String] -> String
namespaceFor []               = String
""
namespaceFor [String
ns, String
"Types", String
_] = String
ns String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_"
namespaceFor (String
_:[String]
parts)        = [String] -> String
namespaceFor [String]
parts

data StructField = StructField
    { StructField -> Doc ()
sfField :: Doc ()
    , StructField -> Type
sfType  :: Type
    }
    deriving (Int -> StructField -> String -> String
[StructField] -> String -> String
StructField -> String
(Int -> StructField -> String -> String)
-> (StructField -> String)
-> ([StructField] -> String -> String)
-> Show StructField
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [StructField] -> String -> String
$cshowList :: [StructField] -> String -> String
show :: StructField -> String
$cshow :: StructField -> String
showsPrec :: Int -> StructField -> String -> String
$cshowsPrec :: Int -> StructField -> String -> String
Show)

data StructName = StructName
    { StructName -> Doc ()
snType :: Doc ()
    , StructName -> Doc ()
snFun  :: Doc ()
    }
    deriving (Int -> StructName -> String -> String
[StructName] -> String -> String
StructName -> String
(Int -> StructName -> String -> String)
-> (StructName -> String)
-> ([StructName] -> String -> String)
-> Show StructName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [StructName] -> String -> String
$cshowList :: [StructName] -> String -> String
show :: StructName -> String
$cshow :: StructName -> String
showsPrec :: Int -> StructName -> String -> String
$cshowsPrec :: Int -> StructName -> String -> String
Show)

flattenFields :: String -> String -> Schema -> (StructName, [StructField])
flattenFields :: String -> String -> Schema -> (StructName, [StructField])
flattenFields String
ns String
prefix = SchemaF Schema -> StructName
forall a. SchemaF a -> StructName
conName (SchemaF Schema -> StructName)
-> (Schema -> SchemaF Schema) -> Schema -> StructName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> SchemaF Schema
forall (f :: * -> *). Fix f -> f (Fix f)
unFix (Schema -> StructName)
-> (Schema -> [StructField])
-> Schema
-> (StructName, [StructField])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (SchemaF [StructField] -> [StructField]) -> Schema -> [StructField]
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix SchemaF [StructField] -> [StructField]
go
  where
    go :: SchemaF [StructField] -> [StructField]
go (Atom Type
ty)              = [Doc () -> Type -> StructField
StructField Doc ()
forall a. Monoid a => a
mempty Type
ty]
    go (Sum (Just (String
_, String
ty)) [[StructField]]
_) = [Doc () -> Type -> StructField
StructField Doc ()
forall a. Monoid a => a
mempty (Type -> StructField) -> Type -> StructField
forall a b. (a -> b) -> a -> b
$ String -> String -> Type
tyName String
ns String
ty]

    go (Field String
name [StructField]
tys)       = (StructField -> StructField) -> [StructField] -> [StructField]
forall a b. (a -> b) -> [a] -> [b]
map (\StructField
ty -> StructField
ty{sfField :: Doc ()
sfField = String -> Doc ()
fieldName String
name}) [StructField]
tys
    go (Con String
_ [StructField]
tys)            = [StructField]
tys
    go (Prod [[StructField]]
fields)          = [[StructField]] -> [StructField]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[StructField]]
fields
    go (Sum Maybe DatatypeName
Nothing [[StructField]]
_)        = []
    go SchemaF [StructField]
Empty                  = []
    go Module{}               = []
    go Schema{}               = []
    go List{}                 = []

    conName :: SchemaF a -> StructName
conName (Con String
name a
_) = StructName :: Doc () -> Doc () -> StructName
StructName
        { snType :: Doc ()
snType = String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> String
toCName String
name
        , snFun :: Doc ()
snFun = String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
toCName String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_"
        }
    conName SchemaF a
_ = Doc () -> Doc () -> StructName
StructName Doc ()
forall a. Monoid a => a
mempty Doc ()
forall a. Monoid a => a
mempty

    -- | @TypeName -> Namespace_Prefix_Type_Name@
    toCName :: String -> String
    toCName :: String -> String
toCName String
name =
        let cName :: String
cName = String -> String
toCamelSnake String
name in
        if String
prefix String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
cName
            then String
ns String -> String -> String
forall a. Semigroup a => a -> a -> a
<>           String
cName
            else String
ns String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cName

genDatatype :: StructName -> [StructField] -> Doc ()
genDatatype :: StructName -> [StructField] -> Doc ()
genDatatype StructName
sName [StructField]
fields =
    StructName -> [StructField] -> Doc ()
genHeader StructName
sName [StructField]
fields Doc () -> Doc () -> Doc ()
<$$>
    StructName -> [StructField] -> Doc ()
genSource StructName
sName [StructField]
fields

genHeader :: StructName -> [StructField] -> Doc ()
genHeader :: StructName -> [StructField] -> Doc ()
genHeader StructName
sName [StructField]
fields =
    String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"// events.h" Doc () -> Doc () -> Doc ()
<$$>
    StructName -> Doc ()
genTypedef StructName
sName Doc () -> Doc () -> Doc ()
<$$>
    StructName -> [StructField] -> Doc ()
genGetterDecls StructName
sName [StructField]
fields

genSource :: StructName -> [StructField] -> Doc ()
genSource :: StructName -> [StructField] -> Doc ()
genSource StructName
sName [StructField]
fields =
    String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"// events.c" Doc () -> Doc () -> Doc ()
<$$>
    StructName -> [StructField] -> Doc ()
genStruct StructName
sName [StructField]
fields Doc () -> Doc () -> Doc ()
<$$>
    ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ()] -> Doc ())
-> ([StructField] -> [Doc ()]) -> [StructField] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ()
forall ann. Doc ann
line ([Doc ()] -> [Doc ()])
-> ([StructField] -> [Doc ()]) -> [StructField] -> [Doc ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StructField -> [Doc ()]) -> [StructField] -> [Doc ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\StructField
field ->
        StructName -> StructField -> [Doc ()]
genGetterDefn StructName
sName StructField
field [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++
        [StructName -> StructField -> Doc ()
genSetterDefn StructName
sName StructField
field]) ([StructField] -> Doc ()) -> [StructField] -> Doc ()
forall a b. (a -> b) -> a -> b
$ [StructField]
fields)

genTypedef :: StructName -> Doc ()
genTypedef :: StructName -> Doc ()
genTypedef (StructName Doc ()
sName Doc ()
_) =
    String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"typedef struct" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
sName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
sName Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
semi

-- | Generate the C struct definition.
genStruct :: StructName -> [StructField] -> Doc ()
genStruct :: StructName -> [StructField] -> Doc ()
genStruct (StructName Doc ()
sName Doc ()
_) [StructField]
fields =
    String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"struct" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
sName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces (Doc ()
forall ann. Doc ann
line Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<>
        Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ((Doc () -> Doc ()) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
semi) ([Doc ()] -> [Doc ()]) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> a -> b
$ (StructField -> [Doc ()]) -> [StructField] -> [Doc ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap StructField -> [Doc ()]
go [StructField]
fields))
        Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
line) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
semi
  where
    go :: StructField -> [Doc ()]
go (StructField Doc ()
f Type
TyBool)     = [String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"bool"     Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
f]
    go (StructField Doc ()
f Type
TyWord8)    = [String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"uint8_t"  Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
f]
    go (StructField Doc ()
f Type
TyWord16)   = [String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"uint16_t" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
f]
    go (StructField Doc ()
f Type
TyWord32)   = [String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"uint32_t" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
f]
    go (StructField Doc ()
f Type
TyWord64)   = [String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"uint64_t" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
f]
    go (StructField Doc ()
f (TyName String
s)) = [String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
s Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
f]
    go (StructField Doc ()
f (TyFixedBin Int
s)) =
        [String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"uint8_t" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
f Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
brackets (Int -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty Int
s)]
    go (StructField Doc ()
f Type
TyBin) =
        [ String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"uint8_t *" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
f
        , String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"uint32_t " Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
f Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"_size"
        ]

eventParam :: Doc () -> Doc () -> Doc () -> Doc ()
eventParam :: Doc () -> Doc () -> Doc () -> Doc ()
eventParam Doc ()
qual Doc ()
sName Doc ()
params =
    Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (Doc ()
forall ann. Doc ann
line Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (Doc ()
qual Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
sName Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"*event" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
params))

getterDecl :: Doc () -> Doc () -> String -> Doc () -> Doc ()
getterDecl :: Doc () -> Doc () -> String -> Doc () -> Doc ()
getterDecl Doc ()
sName Doc ()
fName String
ty Doc ()
f =
    String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
ty Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
fName Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"get_" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
f Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc () -> Doc () -> Doc () -> Doc ()
eventParam (String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"const ") Doc ()
sName Doc ()
forall a. Monoid a => a
mempty

setterDecl :: Doc () -> Doc () -> String -> Doc () -> Doc () -> Doc ()
setterDecl :: Doc () -> Doc () -> String -> Doc () -> Doc () -> Doc ()
setterDecl Doc ()
sName Doc ()
fName String
ty Doc ()
f Doc ()
params =
    String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"static void" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ()
fName Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"set_" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
f Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc () -> Doc () -> Doc () -> Doc ()
eventParam Doc ()
forall a. Monoid a => a
mempty Doc ()
sName (String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty (String
", " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ty String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"value") Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
params)

getterDeclFor :: (String -> Doc () -> Doc ()) -> StructField -> [Doc ()]
getterDeclFor :: (String -> Doc () -> Doc ()) -> StructField -> [Doc ()]
getterDeclFor String -> Doc () -> Doc ()
decl = \case
    (StructField Doc ()
f Type
TyBool)       -> [String -> Doc () -> Doc ()
decl String
"bool "     Doc ()
f]
    (StructField Doc ()
f Type
TyWord8)      -> [String -> Doc () -> Doc ()
decl String
"uint8_t "  Doc ()
f]
    (StructField Doc ()
f Type
TyWord16)     -> [String -> Doc () -> Doc ()
decl String
"uint16_t " Doc ()
f]
    (StructField Doc ()
f Type
TyWord32)     -> [String -> Doc () -> Doc ()
decl String
"uint32_t " Doc ()
f]
    (StructField Doc ()
f Type
TyWord64)     -> [String -> Doc () -> Doc ()
decl String
"uint64_t " Doc ()
f]
    (StructField Doc ()
f (TyName String
s))   -> [String -> Doc () -> Doc ()
decl (String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ")  Doc ()
f]
    (StructField Doc ()
f TyFixedBin{}) -> [String -> Doc () -> Doc ()
decl String
"const uint8_t *" Doc ()
f]
    (StructField Doc ()
f Type
TyBin) ->
        [ String -> Doc () -> Doc ()
decl String
"const uint8_t *" Doc ()
f
        , String -> Doc () -> Doc ()
decl String
"uint32_t " (Doc ()
f Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"_size")
        ]

genGetterDecls :: StructName -> [StructField] -> Doc ()
genGetterDecls :: StructName -> [StructField] -> Doc ()
genGetterDecls (StructName Doc ()
sName Doc ()
fName) [StructField]
fields =
    [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vcat ((Doc () -> Doc ()) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> [a] -> [b]
map (Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
semi) ([Doc ()] -> [Doc ()]) -> [Doc ()] -> [Doc ()]
forall a b. (a -> b) -> a -> b
$ (StructField -> [Doc ()]) -> [StructField] -> [Doc ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> Doc () -> Doc ()) -> StructField -> [Doc ()]
getterDeclFor String -> Doc () -> Doc ()
decl) [StructField]
fields)
  where
    decl :: String -> Doc () -> Doc ()
decl = Doc () -> Doc () -> String -> Doc () -> Doc ()
getterDecl Doc ()
sName Doc ()
fName

genGetterDefn :: StructName -> StructField -> [Doc ()]
genGetterDefn :: StructName -> StructField -> [Doc ()]
genGetterDefn (StructName Doc ()
sName Doc ()
fName) = (String -> Doc () -> Doc ()) -> StructField -> [Doc ()]
getterDeclFor String -> Doc () -> Doc ()
defn
  where
    defn :: String -> Doc () -> Doc ()
defn String
ty Doc ()
f = Doc () -> Doc () -> String -> Doc () -> Doc ()
getterDecl Doc ()
sName Doc ()
fName String
ty Doc ()
f Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces
        (Doc ()
forall ann. Doc ann
line Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"return event->" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
f Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
semi) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
line)

genSetterDefn :: StructName -> StructField -> Doc ()
genSetterDefn :: StructName -> StructField -> Doc ()
genSetterDefn (StructName Doc ()
sName Doc ()
fName) = StructField -> Doc ()
go
  where
    defn :: Doc () -> (Doc () -> Doc ()) -> String -> Doc () -> Doc ()
defn Doc ()
params Doc () -> Doc ()
body String
ty Doc ()
field = Doc () -> Doc () -> String -> Doc () -> Doc () -> Doc ()
setterDecl Doc ()
sName Doc ()
fName String
ty Doc ()
field Doc ()
params Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces
        (Doc ()
forall ann. Doc ann
line Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (Doc () -> Doc ()
body Doc ()
field) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
line)

    setValue :: Doc ann -> Doc ann
setValue Doc ann
field = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"event->" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
field Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
" = value" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
semi
    simpleDefn :: String -> Doc () -> Doc ()
simpleDefn = Doc () -> (Doc () -> Doc ()) -> String -> Doc () -> Doc ()
defn Doc ()
forall a. Monoid a => a
mempty Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
setValue

    setFixedBin :: a -> Doc ann -> Doc ann
setFixedBin a
n Doc ann
field =
        String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"memcpy" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"event->" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
field Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
", value, " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
n) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
semi
    setBin :: Doc () -> Doc ()
setBin Doc ()
field =
        String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"assert(event != nullptr);" Doc () -> Doc () -> Doc ()
<$$>
        String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"if (event->" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
field Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
" != nullptr)" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces (Doc ()
forall ann. Doc ann
line Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<>
            Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (
                String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"free(event->" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
field Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
");" Doc () -> Doc () -> Doc ()
<$$>
                String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"event->" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
field Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
" = nullptr;" Doc () -> Doc () -> Doc ()
<$$>
                String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"event->" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
field Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"_size = 0;"
            ) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
line) Doc () -> Doc () -> Doc ()
<$$>
        String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"event->" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
field Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
" = (uint8_t *)malloc(size);" Doc () -> Doc () -> Doc ()
<$$>
        String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"if (event->" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
field Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
" == nullptr)" Doc () -> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
braces (Doc ()
forall ann. Doc ann
line Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<>
            Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
4 (
                String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"return false;"
            ) Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
line) Doc () -> Doc () -> Doc ()
<$$>
        String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"memcpy" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc () -> Doc ()
forall ann. Doc ann -> Doc ann
parens (String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"event->" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
field Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
", value, size") Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
semi Doc () -> Doc () -> Doc ()
<$$>
        String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"event->" Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
field Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"_size = size;" Doc () -> Doc () -> Doc ()
<$$>
        String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
"return true;"

    go :: StructField -> Doc ()
go (StructField Doc ()
field Type
TyBool)       = String -> Doc () -> Doc ()
simpleDefn String
"bool "     Doc ()
field
    go (StructField Doc ()
field Type
TyWord8)      = String -> Doc () -> Doc ()
simpleDefn String
"uint8_t "  Doc ()
field
    go (StructField Doc ()
field Type
TyWord16)     = String -> Doc () -> Doc ()
simpleDefn String
"uint16_t " Doc ()
field
    go (StructField Doc ()
field Type
TyWord32)     = String -> Doc () -> Doc ()
simpleDefn String
"uint32_t " Doc ()
field
    go (StructField Doc ()
field Type
TyWord64)     = String -> Doc () -> Doc ()
simpleDefn String
"uint64_t " Doc ()
field
    go (StructField Doc ()
field (TyName String
s))   = String -> Doc () -> Doc ()
simpleDefn (String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ")  Doc ()
field
    go (StructField Doc ()
field (TyFixedBin Int
n)) =
        Doc () -> (Doc () -> Doc ()) -> String -> Doc () -> Doc ()
defn Doc ()
forall a. Monoid a => a
mempty (Int -> Doc () -> Doc ()
forall a ann. Pretty a => a -> Doc ann -> Doc ann
setFixedBin Int
n) String
"const uint8_t *" Doc ()
field
    go (StructField Doc ()
field Type
TyBin) =
        Doc () -> (Doc () -> Doc ()) -> String -> Doc () -> Doc ()
defn (String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty String
", uint32_t size") Doc () -> Doc ()
setBin String
"const uint8_t *" Doc ()
field

-- | @fieldName' -> field_name@
fieldName :: String -> Doc ()
fieldName :: String -> Doc ()
fieldName = String -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ()) -> (String -> String) -> String -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\'') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier String -> String
Casing.toQuietSnake (Identifier String -> String)
-> (String -> Identifier String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
Casing.fromHumps

tyName :: String -> String -> Type
tyName :: String -> String -> Type
tyName String
ns = String -> Type
TyName (String -> Type) -> (String -> String) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
ns String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toCamelSnake

-- | @TypeName -> Type_Name@
toCamelSnake :: String -> String
toCamelSnake :: String -> String
toCamelSnake = Identifier String -> String
Casing.toSnake (Identifier String -> String)
-> (String -> Identifier String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
Casing.fromHumps

infixr 5 <$$>
(<$$>) :: Doc () -> Doc () -> Doc ()
Doc ()
x <$$> :: Doc () -> Doc () -> Doc ()
<$$> Doc ()
y = Doc ()
x Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
forall ann. Doc ann
line Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
y