runtime/src/Data/Bond/Internal/SchemaOps.hs
{-# LANGUAGE FlexibleContexts #-}
module Data.Bond.Internal.SchemaOps where
import Data.Bond.Struct
import Data.Bond.TypedSchema
import Data.Bond.Types
import Data.Bond.Internal.Default
import Data.Bond.Internal.OrdinalSet
import Data.Bond.Internal.SchemaUtils
import Data.Bond.Schema.BondDataType
import Data.Bond.Schema.Metadata
import Data.Bond.Schema.Modifier
import Data.Bond.Schema.SchemaDef
import Data.Bond.Schema.Variant
import qualified Data.Bond.Schema.FieldDef as FD
import qualified Data.Bond.Schema.StructDef as SD
import qualified Data.Bond.Schema.TypeDef as TD
import Control.Applicative hiding (optional)
import Control.Arrow
import Control.Monad.State.Strict
import Control.Monad.Error
import Data.Either
import Data.List
import Data.Maybe
import Data.Typeable
import Data.Vector ((//))
import Prelude -- ghc 7.10 workaround for Control.Applicative
import qualified Data.IntSet as IS
import qualified Data.Map.Lazy as ML
import qualified Data.Map.Strict as M
import qualified Data.Vector as V
validateSchemaDef :: MonadError String m => SchemaDef -> m ()
validateSchemaDef schema = do
checkChain IS.empty 0
let rootTD = root schema
when (TD.id rootTD /= bT_STRUCT) $ throwError "root type is not struct"
checkType rootTD
V.mapM_ checkStruct (structs schema)
where
checkChain _ n | n == V.length (structs schema) = return ()
checkChain seen n | IS.member n seen = checkChain seen (n + 1)
checkChain seen n = do
let step stack i = do
when (i >= V.length (structs schema)) $ throwError $ "struct index " ++ show i ++ " out of range"
when (IS.member i stack) $ throwError "loop in inheritance chain"
let baseStruct = SD.base_def $ structs schema V.! i
let newStack = IS.insert i stack
case baseStruct of
Nothing -> return newStack
Just b -> do
when (TD.id b /= bT_STRUCT) $ throwError "not a struct in inheritance chain"
step newStack (fromIntegral $ TD.struct_def b)
stack <- step IS.empty n
checkChain (IS.union seen stack) (n + 1)
checkStruct struct = do
maybe (return ()) checkType (SD.base_def struct)
-- FIXME check for duplicate ordinals
V.forM_ (SD.fields struct) $ checkType . FD.typedef
checkType t@TD.TypeDef{TD.id = typ}
| typ == bT_BOOL = return ()
| typ == bT_INT8 = return ()
| typ == bT_INT16 = return ()
| typ == bT_INT32 = return ()
| typ == bT_INT64 = return ()
| typ == bT_UINT8 = return ()
| typ == bT_UINT16 = return ()
| typ == bT_UINT32 = return ()
| typ == bT_UINT64 = return ()
| typ == bT_FLOAT = return ()
| typ == bT_DOUBLE = return ()
| typ == bT_STRING = return ()
| typ == bT_WSTRING = return ()
| typ == bT_LIST =
case TD.element t of
Nothing -> throwError "element type missing in list schema"
Just subtype -> checkType subtype
| typ == bT_SET =
case TD.element t of
Nothing -> throwError "element type missing in set schema"
Just subtype -> checkType subtype
| typ == bT_MAP = do
case TD.element t of
Nothing -> throwError "value type missing in map schema"
Just subtype -> checkType subtype
case TD.key t of
Nothing -> throwError "key type missing in map schema"
Just subtype -> checkType subtype
| typ == bT_STRUCT = do
let idx = fromIntegral $ TD.struct_def t
when (idx >= V.length (structs schema)) $ throwError $ "struct index " ++ show idx ++ " out of range"
| otherwise = throwError $ "unexpected data type " ++ bondTypeName typ
-- |Convert 'SchemaDef' to internal schema representation.
parseSchema :: SchemaDef -> Either String StructSchema
parseSchema schemadef = validateSchemaDef schemadef >> makeSchema
where
substructs = V.map compileStruct (structs schemadef)
makeSchema = V.indexM substructs (fromIntegral $ TD.struct_def $ root schemadef)
compileStruct struct =
let meta = SD.metadata struct
tycon = mkTyCon3 "Bond" "RuntimeSchema" (toString $ qualified_name meta)
typerep = mkTyConApp tycon []
requiredOrdinals = fromOrdinalVector $ V.map (Ordinal . fromIntegral . FD.id) $
V.filter (\ f -> modifier (FD.metadata f) == required) $ SD.fields struct
fieldMap = M.fromList $ V.toList $ V.map makeField $ SD.fields struct
in StructSchema
{ structTag = typerep
, structName = toText (name meta)
, structQualifiedName = toText (qualified_name meta)
, structAttrs = M.fromList $ map (toText *** toText) $ M.toList $ attributes meta
, structBase = fmap (V.unsafeIndex substructs . fromIntegral . TD.struct_def) (SD.base_def struct)
, structFields = fieldMap
, structRequiredOrdinals = requiredOrdinals
}
makeField field =
let meta = FD.metadata field
fieldMod
| modifier meta == optional = FieldOptional
| modifier meta == required = FieldRequired
| otherwise = FieldRequiredOptional
schema = FieldSchema
{ fieldName = toText (name meta)
, fieldAttrs = M.fromList $ map (toText *** toText) $ M.toList $ attributes meta
, fieldModifier = fieldMod
, fieldType = makeFieldType (FD.typedef field) (default_value $ FD.metadata field)
}
in (Ordinal $ FD.id field, schema)
makeFieldType td variant
| TD.id td == bT_BOOL = FieldBool $ defnothing (uint_value variant /= 0)
| TD.id td == bT_INT8 = FieldInt8 $ defnothing (fromIntegral $ int_value variant)
| TD.id td == bT_INT16 = FieldInt16 $ defnothing (fromIntegral $ int_value variant)
| TD.id td == bT_INT32 = FieldInt32 $ defnothing (fromIntegral $ int_value variant)
| TD.id td == bT_INT64 = FieldInt64 $ defnothing (int_value variant)
| TD.id td == bT_UINT8 = FieldUInt8 $ defnothing (fromIntegral $ uint_value variant)
| TD.id td == bT_UINT16 = FieldUInt16 $ defnothing (fromIntegral $ uint_value variant)
| TD.id td == bT_UINT32 = FieldUInt32 $ defnothing (fromIntegral $ uint_value variant)
| TD.id td == bT_UINT64 = FieldUInt64 $ defnothing (uint_value variant)
| TD.id td == bT_FLOAT = FieldFloat $ defnothing (realToFrac $ double_value variant)
| TD.id td == bT_DOUBLE = FieldDouble $ defnothing (double_value variant)
| TD.id td == bT_STRING = FieldString $ defnothing (string_value variant)
| TD.id td == bT_WSTRING = FieldWString $ defnothing (wstring_value variant)
| TD.id td == bT_STRUCT && TD.bonded_type td = FieldBonded (defnothing ()) (V.unsafeIndex substructs $ fromIntegral $ TD.struct_def td)
| TD.id td == bT_STRUCT = FieldStruct (defnothing ()) (V.unsafeIndex substructs $ fromIntegral $ TD.struct_def td)
| TD.id td == bT_LIST = FieldList (defnothing ()) (makeElementType $ fromJust $ TD.element td)
| TD.id td == bT_SET = FieldSet (defnothing ()) (makeElementType $ fromJust $ TD.element td)
| TD.id td == bT_MAP = FieldMap (defnothing ()) (makeElementType $ fromJust $ TD.key td) (makeElementType $ fromJust $ TD.element td)
| otherwise = error $ "internal error: schema validation missed invalid type tag " ++ show (TD.id td)
where
defnothing v = if nothing variant then DefaultNothing else DefaultValue v
makeElementType td
| TD.id td == bT_BOOL = ElementBool
| TD.id td == bT_INT8 = ElementInt8
| TD.id td == bT_INT16 = ElementInt16
| TD.id td == bT_INT32 = ElementInt32
| TD.id td == bT_INT64 = ElementInt64
| TD.id td == bT_UINT8 = ElementUInt8
| TD.id td == bT_UINT16 = ElementUInt16
| TD.id td == bT_UINT32 = ElementUInt32
| TD.id td == bT_UINT64 = ElementUInt64
| TD.id td == bT_FLOAT = ElementFloat
| TD.id td == bT_DOUBLE = ElementDouble
| TD.id td == bT_STRING = ElementString
| TD.id td == bT_WSTRING = ElementWString
| TD.id td == bT_STRUCT && TD.bonded_type td = ElementBonded (V.unsafeIndex substructs $ fromIntegral $ TD.struct_def td)
| TD.id td == bT_STRUCT = ElementStruct (V.unsafeIndex substructs $ fromIntegral $ TD.struct_def td)
| TD.id td == bT_LIST = ElementList (makeElementType $ fromJust $ TD.element td)
| TD.id td == bT_SET = ElementSet (makeElementType $ fromJust $ TD.element td)
| TD.id td == bT_MAP = ElementMap (makeElementType $ fromJust $ TD.key td) (makeElementType $ fromJust $ TD.element td)
| otherwise = error $ "internal error: schema validation missed invalid type tag " ++ show (TD.id td)
data SchemaState = SchemaState
{ knownStructs :: V.Vector SD.StructDef
, structMap :: M.Map TypeRep Word16
}
-- |Convert internal schema representation to 'SchemaDef' for storage or transfer.
assembleSchema :: StructSchema -> SchemaDef
assembleSchema schema = SchemaDef { structs = structVector, root = rootStruct }
where
(rootStruct, SchemaState{knownStructs = structVector}) = runState (makeStructDef schema) (SchemaState V.empty M.empty)
makeStructDef :: StructSchema -> State SchemaState TD.TypeDef
makeStructDef struct = do
m <- gets structMap
idx <- case M.lookup (structTag struct) m of
Just i -> return i
Nothing -> do
vec <- gets knownStructs
let i = V.length vec
let vnew = V.snoc vec (error "internal error: unfinished StructDef used")
put $ SchemaState vnew (M.insert (structTag struct) (fromIntegral i) m)
baseTypeDef <- case structBase struct of
Nothing -> return Nothing
Just s -> Just <$> makeStructDef s
fieldVec <- fmap V.fromList $ mapM makeFieldDef $ M.toAscList $ structFields struct
let structDef = SD.StructDef
{ SD.metadata = defaultValue
{ name = fromText (structName struct)
, qualified_name = fromText (structQualifiedName struct)
, attributes = M.fromList $ map (fromText *** fromText) $ M.toList $ structAttrs struct
}
, SD.base_def = baseTypeDef
, SD.fields = fieldVec
}
modify $ \ s -> let bigvec = knownStructs s
in s{ knownStructs = bigvec // [(i, structDef)] }
return (fromIntegral i)
return defaultValue{ TD.struct_def = idx }
makeFieldDef (Ordinal n, field) = do
fieldTypeDef <- makeFieldTypeDef (fieldType field)
return defaultValue
{ FD.metadata = defaultValue
{ name = fromText (fieldName field)
, attributes = M.fromList $ map (fromText *** fromText) $ M.toList $ fieldAttrs field
, modifier = case fieldModifier field of
FieldOptional -> optional
FieldRequired -> required
FieldRequiredOptional -> requiredOptional
, default_value = makeDefaultValue (fieldType field)
}
, FD.id = n
, FD.typedef = fieldTypeDef
}
makeFieldTypeDef (FieldBool _) = return defaultValue{TD.id = bT_BOOL}
makeFieldTypeDef (FieldInt8 _) = return defaultValue{TD.id = bT_INT8}
makeFieldTypeDef (FieldInt16 _) = return defaultValue{TD.id = bT_INT16}
makeFieldTypeDef (FieldInt32 _) = return defaultValue{TD.id = bT_INT32}
makeFieldTypeDef (FieldInt64 _) = return defaultValue{TD.id = bT_INT64}
makeFieldTypeDef (FieldUInt8 _) = return defaultValue{TD.id = bT_UINT8}
makeFieldTypeDef (FieldUInt16 _) = return defaultValue{TD.id = bT_UINT16}
makeFieldTypeDef (FieldUInt32 _) = return defaultValue{TD.id = bT_UINT32}
makeFieldTypeDef (FieldUInt64 _) = return defaultValue{TD.id = bT_UINT64}
makeFieldTypeDef (FieldFloat _) = return defaultValue{TD.id = bT_FLOAT}
makeFieldTypeDef (FieldDouble _) = return defaultValue{TD.id = bT_DOUBLE}
makeFieldTypeDef (FieldString _) = return defaultValue{TD.id = bT_STRING}
makeFieldTypeDef (FieldWString _) = return defaultValue{TD.id = bT_WSTRING}
makeFieldTypeDef (FieldStruct _ substruct) = makeStructDef substruct
makeFieldTypeDef (FieldBonded _ substruct) = do
typeDef <- makeStructDef substruct
return typeDef{TD.bonded_type = True}
makeFieldTypeDef (FieldList _ element) = do
typeDef <- makeElementTypeDef element
return defaultValue{TD.id = bT_LIST, TD.element = Just typeDef}
makeFieldTypeDef (FieldSet _ element) = do
typeDef <- makeElementTypeDef element
return defaultValue{TD.id = bT_SET, TD.element = Just typeDef}
makeFieldTypeDef (FieldMap _ key value) = do
keyTypeDef <- makeElementTypeDef key
valueTypeDef <- makeElementTypeDef value
return defaultValue
{ TD.id = bT_MAP
, TD.element = Just valueTypeDef
, TD.key = Just keyTypeDef
}
makeElementTypeDef ElementBool = return defaultValue{TD.id = bT_BOOL}
makeElementTypeDef ElementInt8 = return defaultValue{TD.id = bT_INT8}
makeElementTypeDef ElementInt16 = return defaultValue{TD.id = bT_INT16}
makeElementTypeDef ElementInt32 = return defaultValue{TD.id = bT_INT32}
makeElementTypeDef ElementInt64 = return defaultValue{TD.id = bT_INT64}
makeElementTypeDef ElementUInt8 = return defaultValue{TD.id = bT_UINT8}
makeElementTypeDef ElementUInt16 = return defaultValue{TD.id = bT_UINT16}
makeElementTypeDef ElementUInt32 = return defaultValue{TD.id = bT_UINT32}
makeElementTypeDef ElementUInt64 = return defaultValue{TD.id = bT_UINT64}
makeElementTypeDef ElementFloat = return defaultValue{TD.id = bT_FLOAT}
makeElementTypeDef ElementDouble = return defaultValue{TD.id = bT_DOUBLE}
makeElementTypeDef ElementString = return defaultValue{TD.id = bT_STRING}
makeElementTypeDef ElementWString = return defaultValue{TD.id = bT_WSTRING}
makeElementTypeDef (ElementStruct substruct) = makeStructDef substruct
makeElementTypeDef (ElementBonded substruct) = do
typeDef <- makeStructDef substruct
return typeDef{TD.bonded_type = True}
makeElementTypeDef (ElementList element) = do
typeDef <- makeElementTypeDef element
return defaultValue{TD.id = bT_LIST, TD.element = Just typeDef}
makeElementTypeDef (ElementSet element) = do
typeDef <- makeElementTypeDef element
return defaultValue{TD.id = bT_SET, TD.element = Just typeDef}
makeElementTypeDef (ElementMap key value) = do
keyTypeDef <- makeElementTypeDef key
valueTypeDef <- makeElementTypeDef value
return defaultValue
{ TD.id = bT_MAP
, TD.element = Just valueTypeDef
, TD.key = Just keyTypeDef
}
makeDefaultValue (FieldBool DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldInt8 DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldInt16 DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldInt32 DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldInt64 DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldUInt8 DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldUInt16 DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldUInt32 DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldUInt64 DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldFloat DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldDouble DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldString DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldWString DefaultNothing) = defaultValue{nothing = True}
makeDefaultValue (FieldStruct DefaultNothing _) = defaultValue{nothing = True}
makeDefaultValue (FieldBonded DefaultNothing _) = defaultValue{nothing = True}
makeDefaultValue (FieldList DefaultNothing _) = defaultValue{nothing = True}
makeDefaultValue (FieldSet DefaultNothing _) = defaultValue{nothing = True}
makeDefaultValue (FieldMap DefaultNothing _ _) = defaultValue{nothing = True}
makeDefaultValue (FieldBool (DefaultValue v)) = defaultValue{uint_value = if v then 1 else 0}
makeDefaultValue (FieldInt8 (DefaultValue v)) = defaultValue{int_value = fromIntegral v}
makeDefaultValue (FieldInt16 (DefaultValue v)) = defaultValue{int_value = fromIntegral v}
makeDefaultValue (FieldInt32 (DefaultValue v)) = defaultValue{int_value = fromIntegral v}
makeDefaultValue (FieldInt64 (DefaultValue v)) = defaultValue{int_value = v}
makeDefaultValue (FieldUInt8 (DefaultValue v)) = defaultValue{uint_value = fromIntegral v}
makeDefaultValue (FieldUInt16 (DefaultValue v)) = defaultValue{uint_value = fromIntegral v}
makeDefaultValue (FieldUInt32 (DefaultValue v)) = defaultValue{uint_value = fromIntegral v}
makeDefaultValue (FieldUInt64 (DefaultValue v)) = defaultValue{uint_value = v}
makeDefaultValue (FieldFloat (DefaultValue v)) = defaultValue{double_value = realToFrac v}
makeDefaultValue (FieldDouble (DefaultValue v)) = defaultValue{double_value = v}
makeDefaultValue (FieldString (DefaultValue v)) = defaultValue{string_value = v}
makeDefaultValue (FieldWString (DefaultValue v)) = defaultValue{wstring_value = v}
makeDefaultValue (FieldStruct (DefaultValue ()) _) = defaultValue
makeDefaultValue (FieldBonded (DefaultValue ()) _) = defaultValue
makeDefaultValue (FieldList (DefaultValue ()) _) = defaultValue
makeDefaultValue (FieldSet (DefaultValue ()) _) = defaultValue
makeDefaultValue (FieldMap (DefaultValue ()) _ _) = defaultValue
-- |Verify that 'Struct' matches 'StructSchema' and is internally consistent.
checkStructSchema :: MonadError String m => StructSchema -> Struct -> m Struct
checkStructSchema rootSchema rootStruct = do
when (length schemaStack > length structStack) $ throwError "schema depth is larger than struct depth"
let shortStructStack = take (length schemaStack) structStack
let errs = lefts $ zipWith checkStackLevel schemaStack shortStructStack
unless (null errs) $ throwError $ intercalate "\n" errs
return $ head shortStructStack
where
checkStackLevel schema struct = mapM_ (checkField struct) (M.toList $ structFields schema)
checkField struct (fieldId, fieldInfo) = case M.lookup fieldId (fields struct) of
Nothing -> when (fieldModifier fieldInfo /= FieldOptional) $ Left $ "non-optional field " ++ show (fieldName fieldInfo) ++ " missing"
Just v -> checkValueType (fieldToElementType $ fieldType fieldInfo) v
checkValueType ElementBool (BOOL _) = Right ()
checkValueType ElementInt8 (INT8 _) = Right ()
checkValueType ElementInt16 (INT16 _) = Right ()
checkValueType ElementInt32 (INT32 _) = Right ()
checkValueType ElementInt64 (INT64 _) = Right ()
checkValueType ElementUInt8 (UINT8 _) = Right ()
checkValueType ElementUInt16 (UINT16 _) = Right ()
checkValueType ElementUInt32 (UINT32 _) = Right ()
checkValueType ElementUInt64 (UINT64 _) = Right ()
checkValueType ElementFloat (FLOAT _) = Right ()
checkValueType ElementDouble (DOUBLE _) = Right ()
checkValueType ElementString (STRING _) = Right ()
checkValueType ElementWString (WSTRING _) = Right ()
checkValueType (ElementStruct schema) (STRUCT struct) = void $ checkStructSchema schema struct
checkValueType (ElementBonded _) (BONDED _) = Right ()
checkValueType (ElementBonded _) (STRUCT _) = Right ()
checkValueType (ElementList element) (LIST bt xs) = do
let expectedbt = elementToBondDataType element
when (bt /= expectedbt) $ Left $ "list element type " ++ bondTypeName bt ++ " does not match schema type " ++ bondTypeName expectedbt
mapM_ (checkValueType element) xs
checkValueType (ElementSet element) (SET bt xs) = do
let expectedbt = elementToBondDataType element
when (bt /= expectedbt) $ Left $ "set element type " ++ bondTypeName bt ++ " does not match schema type " ++ bondTypeName expectedbt
mapM_ (checkValueType element) xs
checkValueType (ElementMap key value) (MAP btkey btvalue xs) = do
let expectedbtkey = elementToBondDataType key
let expectedbtvalue = elementToBondDataType value
when (btkey /= expectedbtkey) $ Left $ "map key element type " ++ bondTypeName btkey ++ " does not match schema type " ++ bondTypeName expectedbtkey
when (btvalue /= expectedbtvalue) $ Left $ "map value element type " ++ bondTypeName btvalue ++ " does not match schema type " ++ bondTypeName expectedbtvalue
forM_ xs $ \(k, v) -> checkValueType key k >> checkValueType value v
checkValueType t v = Left $ "field type " ++ valueName v ++ " does not match schema type " ++ bondTypeName (elementToBondDataType t)
structStack = let step s = case base s of
Nothing -> [s]
Just b -> s : step b
in step rootStruct
schemaStack = let step s = case structBase s of
Nothing -> [s]
Just b -> s : step b
in step rootSchema
defaultFieldValue :: FieldTypeInfo -> Maybe Value
defaultFieldValue (FieldBool DefaultNothing) = Nothing
defaultFieldValue (FieldInt8 DefaultNothing) = Nothing
defaultFieldValue (FieldInt16 DefaultNothing) = Nothing
defaultFieldValue (FieldInt32 DefaultNothing) = Nothing
defaultFieldValue (FieldInt64 DefaultNothing) = Nothing
defaultFieldValue (FieldUInt8 DefaultNothing) = Nothing
defaultFieldValue (FieldUInt16 DefaultNothing) = Nothing
defaultFieldValue (FieldUInt32 DefaultNothing) = Nothing
defaultFieldValue (FieldUInt64 DefaultNothing) = Nothing
defaultFieldValue (FieldFloat DefaultNothing) = Nothing
defaultFieldValue (FieldDouble DefaultNothing) = Nothing
defaultFieldValue (FieldString DefaultNothing) = Nothing
defaultFieldValue (FieldWString DefaultNothing) = Nothing
defaultFieldValue (FieldStruct DefaultNothing _) = Nothing
defaultFieldValue (FieldBonded DefaultNothing _) = Nothing
defaultFieldValue (FieldList DefaultNothing _) = Nothing
defaultFieldValue (FieldSet DefaultNothing _) = Nothing
defaultFieldValue (FieldMap DefaultNothing _ _) = Nothing
defaultFieldValue (FieldBool (DefaultValue v)) = Just (BOOL v)
defaultFieldValue (FieldInt8 (DefaultValue v)) = Just (INT8 v)
defaultFieldValue (FieldInt16 (DefaultValue v)) = Just (INT16 v)
defaultFieldValue (FieldInt32 (DefaultValue v)) = Just (INT32 v)
defaultFieldValue (FieldInt64 (DefaultValue v)) = Just (INT64 v)
defaultFieldValue (FieldUInt8 (DefaultValue v)) = Just (UINT8 v)
defaultFieldValue (FieldUInt16 (DefaultValue v)) = Just (UINT16 v)
defaultFieldValue (FieldUInt32 (DefaultValue v)) = Just (UINT32 v)
defaultFieldValue (FieldUInt64 (DefaultValue v)) = Just (UINT64 v)
defaultFieldValue (FieldFloat (DefaultValue v)) = Just (FLOAT v)
defaultFieldValue (FieldDouble (DefaultValue v)) = Just (DOUBLE v)
defaultFieldValue (FieldString (DefaultValue v)) = Just (STRING v)
defaultFieldValue (FieldWString (DefaultValue v)) = Just (WSTRING v)
defaultFieldValue (FieldStruct (DefaultValue ()) schema) = Just (STRUCT $ defaultStruct schema)
defaultFieldValue (FieldBonded (DefaultValue ()) schema) = Just (BONDED $ BondedObject $ defaultStruct schema)
defaultFieldValue (FieldList (DefaultValue ()) et) = Just (LIST (elementToBondDataType et) [])
defaultFieldValue (FieldSet (DefaultValue ()) et) = Just (SET (elementToBondDataType et) [])
defaultFieldValue (FieldMap (DefaultValue ()) kt vt) = Just (MAP (elementToBondDataType kt) (elementToBondDataType vt) [])
-- |Create minimal valid 'Struct' representing given @schema@
defaultStruct :: StructSchema -> Struct
defaultStruct schema = Struct (defaultStruct <$> structBase schema) requiredFields
where
requiredFields = ML.mapMaybe makeDefault $ structFields schema
makeDefault field
| fieldModifier field == FieldOptional = Nothing
| otherwise = defaultFieldValue $ fieldType field