hydra-ext-0.18.0: src/main/haskell/Hydra/Ext/Avro/Encoder.hs
-- Note: this is an automatically generated file. Do not edit.
-- | Hydra-to-Avro encoder: converts Hydra types and terms to Avro schemas and JSON values
module Hydra.Ext.Avro.Encoder where
import qualified Hydra.Core.Annotations as Annotations
import qualified Hydra.Core.Ast as Ast
import qualified Hydra.Core.Coders as Coders
import qualified Hydra.Core.Diff as Diff
import qualified Hydra.Core.Docs as Docs
import qualified Hydra.Core.Error.Checking as Checking
import qualified Hydra.Core.Error.File as ErrorFile
import qualified Hydra.Core.Error.Model as ErrorModel
import qualified Hydra.Core.Error.Packaging as ErrorPackaging
import qualified Hydra.Core.Error.System as ErrorSystem
import qualified Hydra.Core.Errors as Errors
import qualified Hydra.Core.Extract.Model as ExtractModel
import qualified Hydra.Core.File as File
import qualified Hydra.Core.Graph as Graph
import qualified Hydra.Core.Json.Model as JsonModel
import qualified Hydra.Core.Overlay.Haskell.Lib.Eithers as Eithers
import qualified Hydra.Core.Overlay.Haskell.Lib.Equality as Equality
import qualified Hydra.Core.Overlay.Haskell.Lib.Lists as Lists
import qualified Hydra.Core.Overlay.Haskell.Lib.Literals as Literals
import qualified Hydra.Core.Overlay.Haskell.Lib.Logic as Logic
import qualified Hydra.Core.Overlay.Haskell.Lib.Maps as Maps
import qualified Hydra.Core.Overlay.Haskell.Lib.Optionals as Optionals
import qualified Hydra.Core.Overlay.Haskell.Lib.Pairs as Pairs
import qualified Hydra.Core.Overlay.Haskell.Lib.Sets as Sets
import qualified Hydra.Core.Overlay.Haskell.Lib.Strings as Strings
import qualified Hydra.Core.Markdown as Markdown
import qualified Hydra.Core.Model as Model
import qualified Hydra.Core.Packaging as Packaging
import qualified Hydra.Core.Parsing as Parsing
import qualified Hydra.Core.Paths as Paths
import qualified Hydra.Core.Query as Query
import qualified Hydra.Core.Regex as Regex
import qualified Hydra.Core.Relational as Relational
import qualified Hydra.Core.Strip as Strip
import qualified Hydra.Core.System as System
import qualified Hydra.Core.Tabular as Tabular
import qualified Hydra.Core.Testing as Testing
import qualified Hydra.Core.Time as Time
import qualified Hydra.Core.Topology as Topology
import qualified Hydra.Core.Typed as Typed
import qualified Hydra.Core.Typing as Typing
import qualified Hydra.Core.Util as Util
import qualified Hydra.Core.Validation as Validation
import qualified Hydra.Core.Variants as Variants
import qualified Hydra.Ext.Avro.Environment as Environment
import qualified Hydra.Ext.Avro.Schema as Schema
import Prelude hiding (Enum, Ordering, decodeFloat, encodeFloat, fail, lines, map, pure, sum, unlines)
import qualified Data.Scientific as Sci
import Data.Void
import qualified Data.Map as M
-- | Build an Avro field from a name-adapter pair
buildAvroField :: (Model.Name, (Coders.Adapter t0 Schema.Schema t1 t2 t3)) -> Schema.Field
buildAvroField nameAd =
let name_ = Pairs.first nameAd
ad = Pairs.second nameAd
in Schema.Field {
Schema.fieldName = (localName name_),
Schema.fieldDoc = Nothing,
Schema.fieldType = (Coders.adapterTarget ad),
Schema.fieldDefault = Nothing,
Schema.fieldOrder = Nothing,
Schema.fieldAliases = Nothing,
Schema.fieldAnnotations = Maps.empty}
-- | Create an empty encode environment with the given type map
emptyEncodeEnvironment :: M.Map Model.Name Model.Type -> Environment.EncodeEnvironment
emptyEncodeEnvironment typeMap =
Environment.EncodeEnvironment {
Environment.encodeEnvironmentTypeMap = typeMap,
Environment.encodeEnvironmentEmitted = Maps.empty}
-- | Encode a Hydra type to an Avro schema adapter, given the type map and a root name
encodeType :: t0 -> M.Map Model.Name Model.Type -> Model.Name -> Either Errors.Error (Coders.Adapter Model.Type Schema.Schema Model.Term JsonModel.Value Errors.Error)
encodeType cx typeMap name_ =
Eithers.map (\adEnv -> Pairs.first adEnv) (encodeTypeWithEnv cx name_ (emptyEncodeEnvironment typeMap))
-- | Core encoding logic: recursively encode a Hydra type to an Avro schema
encodeTypeInner :: t0 -> Maybe Model.Name -> Model.Type -> Environment.EncodeEnvironment -> Either Errors.Error (Coders.Adapter Model.Type Schema.Schema Model.Term JsonModel.Value Errors.Error, Environment.EncodeEnvironment)
encodeTypeInner cx mName typ env =
let annResult = extractAnnotations typ
annotations = Pairs.first annResult
bareType = Pairs.second annResult
simpleAdapter =
\target -> \lossy -> \encode -> \decode -> Right (
Coders.Adapter {
Coders.adapterIsLossy = lossy,
Coders.adapterSource = typ,
Coders.adapterTarget = target,
Coders.adapterCoder = Coders.Coder {
Coders.coderEncode = encode,
Coders.coderDecode = decode}},
env)
in case bareType of
Model.TypeUnit -> simpleAdapter (Schema.SchemaPrimitive Schema.PrimitiveNull) False (\_t -> Right JsonModel.ValueNull) (\_j -> Right Model.TermUnit)
Model.TypeLiteral v0 -> Eithers.map (\ad -> (ad, env)) (literalAdapter cx typ v0)
Model.TypeList v0 -> Eithers.bind (encodeTypeInner cx Nothing v0 env) (\adEnv ->
let innerAd = Pairs.first adEnv
env1 = Pairs.second adEnv
in (Right (
Coders.Adapter {
Coders.adapterIsLossy = (Coders.adapterIsLossy innerAd),
Coders.adapterSource = typ,
Coders.adapterTarget = (Schema.SchemaArray (Schema.Array {
Schema.arrayItems = (Coders.adapterTarget innerAd)})),
Coders.adapterCoder = Coders.Coder {
Coders.coderEncode = (\t -> case t of
Model.TermList v1 -> Eithers.map (\jvs -> JsonModel.ValueArray jvs) (Eithers.mapList (\el -> Coders.coderEncode (Coders.adapterCoder innerAd) el) v1)),
Coders.coderDecode = (\j -> case j of
JsonModel.ValueArray v1 -> Eithers.map (\ts -> Model.TermList ts) (Eithers.mapList (\el -> Coders.coderDecode (Coders.adapterCoder innerAd) el) v1))}},
env1)))
Model.TypeMap v0 ->
let keyType = Model.mapTypeKeys v0
valType = Model.mapTypeValues v0
in case (Strip.deannotateType keyType) of
Model.TypeLiteral v1 -> case v1 of
Model.LiteralTypeString -> Eithers.bind (encodeTypeInner cx Nothing valType env) (\adEnv ->
let valAd = Pairs.first adEnv
env1 = Pairs.second adEnv
in (Right (
Coders.Adapter {
Coders.adapterIsLossy = (Coders.adapterIsLossy valAd),
Coders.adapterSource = typ,
Coders.adapterTarget = (Schema.SchemaMap (Schema.Map {
Schema.mapValues = (Coders.adapterTarget valAd)})),
Coders.adapterCoder = Coders.Coder {
Coders.coderEncode = (\t -> case t of
Model.TermMap v3 ->
let encodeEntry =
\entry ->
let k = Pairs.first entry
v = Pairs.second entry
in (Eithers.bind (ExtractModel.string (Graph.Graph {
Graph.graphBoundTerms = Maps.empty,
Graph.graphBoundTypes = Maps.empty,
Graph.graphClassConstraints = Maps.empty,
Graph.graphLambdaVariables = Sets.empty,
Graph.graphMetadata = Maps.empty,
Graph.graphPrimitives = Maps.empty,
Graph.graphSchemaTypes = Maps.empty,
Graph.graphTypeVariables = Sets.empty}) k) (\kStr -> Eithers.map (\vJson -> (kStr, vJson)) (Coders.coderEncode (Coders.adapterCoder valAd) v)))
in (Eithers.map (\pairs -> JsonModel.ValueObject pairs) (Eithers.mapList encodeEntry (Maps.toList v3)))),
Coders.coderDecode = (\j -> case j of
JsonModel.ValueObject v3 ->
let decodeEntry =
\entry ->
let k = Pairs.first entry
v = Pairs.second entry
in (Eithers.map (\vTerm -> (Model.TermLiteral (Model.LiteralString k), vTerm)) (Coders.coderDecode (Coders.adapterCoder valAd) v))
in (Eithers.map (\pairs -> Model.TermMap (Maps.fromList pairs)) (Eithers.mapList decodeEntry v3)))}},
env1)))
_ -> err cx "Avro maps require string keys"
_ -> err cx "Avro maps require string keys"
Model.TypeRecord v0 -> namedTypeAdapter cx typ mName annotations v0 env (\avroFields -> Schema.NamedTypeRecord (Schema.Record {
Schema.recordFields = avroFields})) recordTermCoder
Model.TypeUnion v0 ->
let allUnit =
Lists.foldl (\b -> \ft -> Logic.and b (case (Model.fieldTypeType ft) of
Model.TypeUnit -> True
_ -> False)) True v0
in (Logic.ifElse allUnit (enumAdapter cx typ mName annotations v0 env) (unionAsRecordAdapter cx typ mName annotations v0 env))
Model.TypeOptional v0 -> Eithers.bind (encodeTypeInner cx Nothing v0 env) (\adEnv ->
let innerAd = Pairs.first adEnv
env1 = Pairs.second adEnv
in (Right (
Coders.Adapter {
Coders.adapterIsLossy = (Coders.adapterIsLossy innerAd),
Coders.adapterSource = typ,
Coders.adapterTarget = (Schema.SchemaUnion (Schema.Union [
Schema.SchemaPrimitive Schema.PrimitiveNull,
(Coders.adapterTarget innerAd)])),
Coders.adapterCoder = Coders.Coder {
Coders.coderEncode = (\t -> case t of
Model.TermOptional v1 -> Optionals.match v1 (Right JsonModel.ValueNull) (\inner -> Coders.coderEncode (Coders.adapterCoder innerAd) inner)),
Coders.coderDecode = (\j -> case j of
JsonModel.ValueNull -> Right (Model.TermOptional Nothing)
_ -> Eithers.map (\t -> Model.TermOptional (Just t)) (Coders.coderDecode (Coders.adapterCoder innerAd) j))}},
env1)))
Model.TypeWrap v0 -> encodeTypeInner cx mName v0 env
Model.TypeVariable v0 -> Optionals.match (Maps.lookup v0 (Environment.encodeEnvironmentEmitted env)) (Optionals.match (Maps.lookup v0 (Environment.encodeEnvironmentTypeMap env)) (err cx (Strings.concat2 "referenced type not found: " (Model.unName v0))) (\refType -> encodeTypeInner cx (Just v0) refType env)) (\existingAd -> Right (
Coders.Adapter {
Coders.adapterIsLossy = (Coders.adapterIsLossy existingAd),
Coders.adapterSource = (Coders.adapterSource existingAd),
Coders.adapterTarget = (Schema.SchemaReference (localName v0)),
Coders.adapterCoder = (Coders.adapterCoder existingAd)},
env))
_ -> err cx "unsupported Hydra type for Avro encoding"
-- | Encode with full environment threading. Returns the adapter and updated environment
encodeTypeWithEnv :: t0 -> Model.Name -> Environment.EncodeEnvironment -> Either Errors.Error (Coders.Adapter Model.Type Schema.Schema Model.Term JsonModel.Value Errors.Error, Environment.EncodeEnvironment)
encodeTypeWithEnv cx name_ env =
Optionals.match (Maps.lookup name_ (Environment.encodeEnvironmentTypeMap env)) (err cx (Strings.concat2 "type not found in type map: " (Literals.printString (Model.unName name_)))) (\typ -> encodeTypeInner cx (Just name_) typ env)
-- | Adapter for all-unit union types (enums)
enumAdapter :: t0 -> Model.Type -> Maybe Model.Name -> M.Map Model.Name Model.Term -> [Model.FieldType] -> Environment.EncodeEnvironment -> Either t1 (Coders.Adapter Model.Type Schema.Schema Model.Term JsonModel.Value Errors.Error, Environment.EncodeEnvironment)
enumAdapter cx typ mName annotations fieldTypes env0 =
let symbols = Lists.map (\ft -> localName (Model.fieldTypeName ft)) fieldTypes
typeName = Optionals.withDefault (typeToName typ) mName
avroAnnotations = hydraAnnotationsToAvro annotations
avroSchema =
Schema.SchemaNamed (Schema.Named {
Schema.namedName = (localName typeName),
Schema.namedNamespace = (nameNamespace typeName),
Schema.namedAliases = Nothing,
Schema.namedDoc = Nothing,
Schema.namedType = (Schema.NamedTypeEnum (Schema.Enum {
Schema.enumSymbols = symbols,
Schema.enumDefault = Nothing})),
Schema.namedAnnotations = avroAnnotations})
adapter_ =
Coders.Adapter {
Coders.adapterIsLossy = False,
Coders.adapterSource = typ,
Coders.adapterTarget = avroSchema,
Coders.adapterCoder = Coders.Coder {
Coders.coderEncode = (\t -> case t of
Model.TermInject v0 ->
let fname = Model.injectionField v0
in (Right (JsonModel.ValueString (localName (Model.fieldName fname))))
_ -> Left (Errors.ErrorOther (Errors.OtherError "expected union term for enum"))),
Coders.coderDecode = (\j -> case j of
JsonModel.ValueString v0 -> Right (Model.TermInject (Model.Injection {
Model.injectionTypeName = typeName,
Model.injectionField = Model.Field {
Model.fieldName = (Model.Name v0),
Model.fieldTerm = Model.TermUnit}})))}}
env1 =
Environment.EncodeEnvironment {
Environment.encodeEnvironmentTypeMap = (Environment.encodeEnvironmentTypeMap env0),
Environment.encodeEnvironmentEmitted = (Maps.insert typeName adapter_ (Environment.encodeEnvironmentEmitted env0))}
in (Right (adapter_, env1))
-- | Construct an error result with a message in context
err :: t0 -> String -> Either Errors.Error t1
err cx msg = Left (Errors.ErrorOther (Errors.OtherError msg))
-- | Extract annotations from a potentially annotated type
extractAnnotations :: Model.Type -> (M.Map Model.Name Model.Term, Model.Type)
extractAnnotations typ =
case typ of
Model.TypeAnnotated v0 ->
let inner = Model.annotatedTypeBody v0
anns = Annotations.getAnnotationMap (Model.annotatedTypeAnnotation v0)
innerResult = extractAnnotations inner
innerAnns = Pairs.first innerResult
bareType = Pairs.second innerResult
in (Maps.union anns innerAnns, bareType)
_ -> (Maps.empty, typ)
-- | Create an adapter for float types
floatAdapter :: t0 -> t1 -> Model.FloatType -> Either t2 (Coders.Adapter t1 Schema.Schema Model.Term JsonModel.Value Errors.Error)
floatAdapter cx typ ft =
let simple =
\target -> \lossy -> \encode -> \decode -> Right (Coders.Adapter {
Coders.adapterIsLossy = lossy,
Coders.adapterSource = typ,
Coders.adapterTarget = target,
Coders.adapterCoder = Coders.Coder {
Coders.coderEncode = encode,
Coders.coderDecode = decode}})
in case ft of
Model.FloatTypeFloat32 -> simple (Schema.SchemaPrimitive Schema.PrimitiveFloat) False (\t -> Eithers.map (\f -> JsonModel.ValueNumber (Literals.float32ToDecimal f)) (ExtractModel.float32 (Graph.Graph {
Graph.graphBoundTerms = Maps.empty,
Graph.graphBoundTypes = Maps.empty,
Graph.graphClassConstraints = Maps.empty,
Graph.graphLambdaVariables = Sets.empty,
Graph.graphMetadata = Maps.empty,
Graph.graphPrimitives = Maps.empty,
Graph.graphSchemaTypes = Maps.empty,
Graph.graphTypeVariables = Sets.empty}) t)) (\j -> case j of
JsonModel.ValueNumber v1 -> Right (Model.TermLiteral (Model.LiteralFloat (Model.FloatValueFloat32 (Literals.decimalToFloat32 v1)))))
Model.FloatTypeFloat64 -> simple (Schema.SchemaPrimitive Schema.PrimitiveDouble) False (\t -> Eithers.map (\d -> JsonModel.ValueNumber (Literals.float64ToDecimal d)) (ExtractModel.float64 (Graph.Graph {
Graph.graphBoundTerms = Maps.empty,
Graph.graphBoundTypes = Maps.empty,
Graph.graphClassConstraints = Maps.empty,
Graph.graphLambdaVariables = Sets.empty,
Graph.graphMetadata = Maps.empty,
Graph.graphPrimitives = Maps.empty,
Graph.graphSchemaTypes = Maps.empty,
Graph.graphTypeVariables = Sets.empty}) t)) (\j -> case j of
JsonModel.ValueNumber v1 -> Right (Model.TermLiteral (Model.LiteralFloat (Model.FloatValueFloat64 (Literals.decimalToFloat64 v1)))))
_ -> simple (Schema.SchemaPrimitive Schema.PrimitiveDouble) True (\t -> case t of
Model.TermLiteral v0 -> case v0 of
Model.LiteralFloat v1 -> Right (JsonModel.ValueNumber (floatValueToDouble v1))) (\j -> case j of
JsonModel.ValueNumber v0 -> Right (Model.TermLiteral (Model.LiteralFloat (Model.FloatValueFloat64 (Literals.decimalToFloat64 v0)))))
-- | Convert any float value to a JSON decimal number
floatValueToDouble :: Model.FloatValue -> Sci.Scientific
floatValueToDouble fv =
case fv of
Model.FloatValueFloat32 v0 -> Literals.float32ToDecimal v0
Model.FloatValueFloat64 v0 -> Literals.float64ToDecimal v0
-- | Fold over field types, building adapters and threading the environment
foldFieldAdapters :: t0 -> [Model.FieldType] -> Environment.EncodeEnvironment -> Either Errors.Error (
[(Model.Name, (Coders.Adapter Model.Type Schema.Schema Model.Term JsonModel.Value Errors.Error))],
Environment.EncodeEnvironment)
foldFieldAdapters cx fieldTypes env0 =
Lists.foldl (\acc -> \ft -> Eithers.bind acc (\accPair ->
let soFar = Pairs.first accPair
env1 = Pairs.second accPair
fname = Model.fieldTypeName ft
ftype = Model.fieldTypeType ft
in (Eithers.bind (encodeTypeInner cx Nothing ftype env1) (\adEnv ->
let ad = Pairs.first adEnv
env2 = Pairs.second adEnv
in (Right (Lists.concat2 soFar [
(fname, ad)], env2)))))) (Right ([], env0)) fieldTypes
-- | Convert Hydra annotations to Avro annotation map
hydraAnnotationsToAvro :: M.Map Model.Name Model.Term -> M.Map String JsonModel.Value
hydraAnnotationsToAvro anns =
Maps.fromList (Lists.map (\entry ->
let k = Pairs.first entry
v = Pairs.second entry
in (Model.unName k, (termToJsonValue v))) (Maps.toList anns))
-- | Encode a single type without a type map (for simple/anonymous types)
hydraAvroAdapter :: t0 -> M.Map Model.Name Model.Type -> Model.Type -> Either Errors.Error (Coders.Adapter Model.Type Schema.Schema Model.Term JsonModel.Value Errors.Error)
hydraAvroAdapter cx typeMap typ =
Eithers.map (\adEnv -> Pairs.first adEnv) (encodeTypeInner cx Nothing typ (emptyEncodeEnvironment typeMap))
-- | Convert a Hydra Name to an Avro qualified name (local name, optional namespace)
hydraNameToAvroName :: Model.Name -> (String, (Maybe String))
hydraNameToAvroName name_ = (localName name_, (nameNamespace name_))
-- | Create an adapter for integer types
integerAdapter :: t0 -> t1 -> Model.IntegerType -> Either t2 (Coders.Adapter t1 Schema.Schema Model.Term JsonModel.Value Errors.Error)
integerAdapter cx typ it =
let simple =
\target -> \lossy -> \encode -> \decode -> Right (Coders.Adapter {
Coders.adapterIsLossy = lossy,
Coders.adapterSource = typ,
Coders.adapterTarget = target,
Coders.adapterCoder = Coders.Coder {
Coders.coderEncode = encode,
Coders.coderDecode = decode}})
in case it of
Model.IntegerTypeInt32 -> simple (Schema.SchemaPrimitive Schema.PrimitiveInt) False (\t -> Eithers.map (\i -> JsonModel.ValueNumber (Literals.bigintToDecimal (Literals.int32ToBigint i))) (ExtractModel.int32 (Graph.Graph {
Graph.graphBoundTerms = Maps.empty,
Graph.graphBoundTypes = Maps.empty,
Graph.graphClassConstraints = Maps.empty,
Graph.graphLambdaVariables = Sets.empty,
Graph.graphMetadata = Maps.empty,
Graph.graphPrimitives = Maps.empty,
Graph.graphSchemaTypes = Maps.empty,
Graph.graphTypeVariables = Sets.empty}) t)) (\j -> case j of
JsonModel.ValueNumber v1 -> Right (Model.TermLiteral (Model.LiteralInteger (Model.IntegerValueInt32 (Literals.bigintToInt32 (Literals.decimalToBigint v1))))))
Model.IntegerTypeInt64 -> simple (Schema.SchemaPrimitive Schema.PrimitiveLong) False (\t -> Eithers.map (\i -> JsonModel.ValueNumber (Literals.bigintToDecimal (Literals.int64ToBigint i))) (ExtractModel.int64 (Graph.Graph {
Graph.graphBoundTerms = Maps.empty,
Graph.graphBoundTypes = Maps.empty,
Graph.graphClassConstraints = Maps.empty,
Graph.graphLambdaVariables = Sets.empty,
Graph.graphMetadata = Maps.empty,
Graph.graphPrimitives = Maps.empty,
Graph.graphSchemaTypes = Maps.empty,
Graph.graphTypeVariables = Sets.empty}) t)) (\j -> case j of
JsonModel.ValueNumber v1 -> Right (Model.TermLiteral (Model.LiteralInteger (Model.IntegerValueInt64 (Literals.bigintToInt64 (Literals.decimalToBigint v1))))))
_ -> simple (Schema.SchemaPrimitive Schema.PrimitiveLong) True (\t -> case t of
Model.TermLiteral v0 -> case v0 of
Model.LiteralInteger v1 -> Right (JsonModel.ValueNumber (integerValueToDouble v1))) (\j -> case j of
JsonModel.ValueNumber v0 -> Right (Model.TermLiteral (Model.LiteralInteger (Model.IntegerValueInt64 (Literals.bigintToInt64 (Literals.decimalToBigint v0))))))
-- | Convert any integer value to a JSON decimal number
integerValueToDouble :: Model.IntegerValue -> Sci.Scientific
integerValueToDouble iv =
case iv of
Model.IntegerValueBigint v0 -> Literals.bigintToDecimal v0
Model.IntegerValueInt8 v0 -> Literals.bigintToDecimal (Literals.int8ToBigint v0)
Model.IntegerValueInt16 v0 -> Literals.bigintToDecimal (Literals.int16ToBigint v0)
Model.IntegerValueInt32 v0 -> Literals.bigintToDecimal (Literals.int32ToBigint v0)
Model.IntegerValueInt64 v0 -> Literals.bigintToDecimal (Literals.int64ToBigint v0)
Model.IntegerValueUint8 v0 -> Literals.bigintToDecimal (Literals.uint8ToBigint v0)
Model.IntegerValueUint16 v0 -> Literals.bigintToDecimal (Literals.uint16ToBigint v0)
Model.IntegerValueUint32 v0 -> Literals.bigintToDecimal (Literals.uint32ToBigint v0)
Model.IntegerValueUint64 v0 -> Literals.bigintToDecimal (Literals.uint64ToBigint v0)
-- | Create an adapter for literal types
literalAdapter :: t0 -> t1 -> Model.LiteralType -> Either t2 (Coders.Adapter t1 Schema.Schema Model.Term JsonModel.Value Errors.Error)
literalAdapter cx typ lt =
let simple =
\target -> \lossy -> \encode -> \decode -> Right (Coders.Adapter {
Coders.adapterIsLossy = lossy,
Coders.adapterSource = typ,
Coders.adapterTarget = target,
Coders.adapterCoder = Coders.Coder {
Coders.coderEncode = encode,
Coders.coderDecode = decode}})
in case lt of
Model.LiteralTypeBoolean -> simple (Schema.SchemaPrimitive Schema.PrimitiveBoolean) False (\t -> case t of
Model.TermLiteral v1 -> case v1 of
Model.LiteralBoolean v2 -> Right (JsonModel.ValueBoolean v2)) (\j -> case j of
JsonModel.ValueBoolean v1 -> Right (Model.TermLiteral (Model.LiteralBoolean v1)))
Model.LiteralTypeString -> simple (Schema.SchemaPrimitive Schema.PrimitiveString) False (\t -> case t of
Model.TermLiteral v1 -> case v1 of
Model.LiteralString v2 -> Right (JsonModel.ValueString v2)) (\j -> case j of
JsonModel.ValueString v1 -> Right (Model.TermLiteral (Model.LiteralString v1)))
Model.LiteralTypeBinary -> simple (Schema.SchemaPrimitive Schema.PrimitiveBytes) False (\t -> case t of
Model.TermLiteral v1 -> case v1 of
Model.LiteralBinary v2 -> Right (JsonModel.ValueString (Literals.binaryToBase64 v2))) (\j -> case j of
JsonModel.ValueString v1 -> Right (Model.TermLiteral (Model.LiteralBinary (Literals.base64ToBinary v1))))
Model.LiteralTypeInteger v0 -> integerAdapter cx typ v0
Model.LiteralTypeFloat v0 -> floatAdapter cx typ v0
-- | Extract the local part of a qualified name
localName :: Model.Name -> String
localName name_ =
let s = Model.unName name_
parts = Strings.splitOn "." s
in (Optionals.withDefault s (Lists.last parts))
-- | Extract the namespace from a qualified name, if any
nameNamespace :: Model.Name -> Maybe String
nameNamespace name_ =
let s = Model.unName name_
parts = Strings.splitOn "." s
in (Logic.ifElse (Equality.equal (Lists.length parts) 1) Nothing (Optionals.map (\ps -> Strings.join "." ps) (Lists.init parts)))
-- | Build a named type adapter (shared between record and union-as-record)
namedTypeAdapter :: t0 -> Model.Type -> Maybe Model.Name -> M.Map Model.Name Model.Term -> [Model.FieldType] -> Environment.EncodeEnvironment -> ([Schema.Field] -> Schema.NamedType) -> (t0 -> Model.Name -> [(Model.Name, (Coders.Adapter Model.Type Schema.Schema Model.Term JsonModel.Value Errors.Error))] -> ((Model.Term -> Either Errors.Error JsonModel.Value), (JsonModel.Value -> Either Errors.Error Model.Term))) -> Either Errors.Error (Coders.Adapter Model.Type Schema.Schema Model.Term JsonModel.Value Errors.Error, Environment.EncodeEnvironment)
namedTypeAdapter cx typ mName annotations fieldTypes env0 mkNamedType mkCoder =
let typeName = Optionals.withDefault (typeToName typ) mName
in (Optionals.match (Maps.lookup typeName (Environment.encodeEnvironmentEmitted env0)) (Eithers.bind (foldFieldAdapters cx fieldTypes env0) (\faResult ->
let fieldAdapters = Pairs.first faResult
env1 = Pairs.second faResult
avroFields = Lists.map buildAvroField fieldAdapters
avroAnnotations = hydraAnnotationsToAvro annotations
avroSchema =
Schema.SchemaNamed (Schema.Named {
Schema.namedName = (localName typeName),
Schema.namedNamespace = (nameNamespace typeName),
Schema.namedAliases = Nothing,
Schema.namedDoc = Nothing,
Schema.namedType = (mkNamedType avroFields),
Schema.namedAnnotations = avroAnnotations})
lossy = Lists.foldl (\b -> \fa -> Logic.or b (Coders.adapterIsLossy (Pairs.second fa))) False fieldAdapters
coderPair = mkCoder cx typeName fieldAdapters
encodeFn = Pairs.first coderPair
decodeFn = Pairs.second coderPair
adapter_ =
Coders.Adapter {
Coders.adapterIsLossy = lossy,
Coders.adapterSource = typ,
Coders.adapterTarget = avroSchema,
Coders.adapterCoder = Coders.Coder {
Coders.coderEncode = encodeFn,
Coders.coderDecode = decodeFn}}
env2 =
Environment.EncodeEnvironment {
Environment.encodeEnvironmentTypeMap = (Environment.encodeEnvironmentTypeMap env1),
Environment.encodeEnvironmentEmitted = (Maps.insert typeName adapter_ (Environment.encodeEnvironmentEmitted env1))}
in (Right (adapter_, env2)))) (\existingAd -> Right (existingAd, env0)))
-- | Build a record term coder from field adapters
recordTermCoder :: t0 -> Model.Name -> [(Model.Name, (Coders.Adapter t1 t2 Model.Term JsonModel.Value Errors.Error))] -> ((Model.Term -> Either Errors.Error JsonModel.Value), (JsonModel.Value -> Either Errors.Error Model.Term))
recordTermCoder cx typeName fieldAdapters =
let encode =
\term -> case term of
Model.TermRecord v0 ->
let fields = Model.recordFields v0
fieldMap = Maps.fromList (Lists.map (\f -> (Model.fieldName f, (Model.fieldTerm f))) fields)
encodeField =
\nameAd ->
let fname = Pairs.first nameAd
ad = Pairs.second nameAd
fTerm = Optionals.withDefault Model.TermUnit (Maps.lookup fname fieldMap)
in (Eithers.map (\jv -> (localName fname, jv)) (Coders.coderEncode (Coders.adapterCoder ad) fTerm))
in (Eithers.map (\pairs -> JsonModel.ValueObject pairs) (Eithers.mapList encodeField fieldAdapters))
_ -> err cx "expected record term"
decode =
\json -> case json of
JsonModel.ValueObject v0 ->
let mm = Maps.fromList v0
decodeField =
\nameAd ->
let fname = Pairs.first nameAd
ad = Pairs.second nameAd
jv = Optionals.withDefault JsonModel.ValueNull (Maps.lookup (localName fname) mm)
in (Eithers.map (\t -> Model.Field {
Model.fieldName = fname,
Model.fieldTerm = t}) (Coders.coderDecode (Coders.adapterCoder ad) jv))
in (Eithers.map (\fields -> Model.TermRecord (Model.Record {
Model.recordTypeName = typeName,
Model.recordFields = fields})) (Eithers.mapList decodeField fieldAdapters))
_ -> err cx "expected JSON object"
in (encode, decode)
-- | Convert a Hydra term to a JSON value (for annotation values)
termToJsonValue :: Model.Term -> JsonModel.Value
termToJsonValue term =
case term of
Model.TermLiteral v0 -> case v0 of
Model.LiteralString v1 -> JsonModel.ValueString v1
Model.LiteralBoolean v1 -> JsonModel.ValueBoolean v1
Model.LiteralInteger v1 -> JsonModel.ValueNumber (integerValueToDouble v1)
Model.LiteralFloat v1 -> JsonModel.ValueNumber (floatValueToDouble v1)
Model.LiteralBinary v1 -> JsonModel.ValueString (Literals.binaryToBase64 v1)
Model.TermList v0 -> JsonModel.ValueArray (Lists.map termToJsonValue v0)
Model.TermMap v0 -> JsonModel.ValueObject (Lists.map (\entry ->
let k = Pairs.first entry
v = Pairs.second entry
in (
case k of
Model.TermLiteral v1 -> case v1 of
Model.LiteralString v2 -> v2
_ -> "<key>"
_ -> "<key>",
(termToJsonValue v))) (Maps.toList v0))
Model.TermRecord v0 -> Logic.ifElse (Lists.isEmpty (Model.recordFields v0)) JsonModel.ValueNull (JsonModel.ValueString "<record>")
_ -> JsonModel.ValueString "<term>"
-- | Generate a default name for an anonymous type
typeToName :: Model.Type -> Model.Name
typeToName t =
case (Strip.deannotateType t) of
Model.TypeRecord _ -> Model.Name "Record"
Model.TypeUnion _ -> Model.Name "Union"
_ -> Model.Name "Unknown"
-- | Adapter for general unions (encoded as records with optional fields)
unionAsRecordAdapter :: t0 -> Model.Type -> Maybe Model.Name -> M.Map Model.Name Model.Term -> [Model.FieldType] -> Environment.EncodeEnvironment -> Either Errors.Error (Coders.Adapter Model.Type Schema.Schema Model.Term JsonModel.Value Errors.Error, Environment.EncodeEnvironment)
unionAsRecordAdapter cx typ mName annotations fieldTypes env0 =
Eithers.bind (foldFieldAdapters cx fieldTypes env0) (\faResult ->
let fieldAdapters = Pairs.first faResult
env1 = Pairs.second faResult
avroFields =
Lists.map (\nameAd ->
let fname = Pairs.first nameAd
ad = Pairs.second nameAd
in Schema.Field {
Schema.fieldName = (localName fname),
Schema.fieldDoc = Nothing,
Schema.fieldType = (Schema.SchemaUnion (Schema.Union [
Schema.SchemaPrimitive Schema.PrimitiveNull,
(Coders.adapterTarget ad)])),
Schema.fieldDefault = (Just JsonModel.ValueNull),
Schema.fieldOrder = Nothing,
Schema.fieldAliases = Nothing,
Schema.fieldAnnotations = Maps.empty}) fieldAdapters
typeName = Optionals.withDefault (typeToName typ) mName
avroAnnotations = hydraAnnotationsToAvro annotations
avroSchema =
Schema.SchemaNamed (Schema.Named {
Schema.namedName = (localName typeName),
Schema.namedNamespace = (nameNamespace typeName),
Schema.namedAliases = Nothing,
Schema.namedDoc = Nothing,
Schema.namedType = (Schema.NamedTypeRecord (Schema.Record {
Schema.recordFields = avroFields})),
Schema.namedAnnotations = avroAnnotations})
adapter_ =
Coders.Adapter {
Coders.adapterIsLossy = True,
Coders.adapterSource = typ,
Coders.adapterTarget = avroSchema,
Coders.adapterCoder = Coders.Coder {
Coders.coderEncode = (\t -> case t of
Model.TermInject v0 ->
let activeName = Model.fieldName (Model.injectionField v0)
activeValue = Model.fieldTerm (Model.injectionField v0)
encodePair =
\nameAd ->
let fname = Pairs.first nameAd
ad = Pairs.second nameAd
in (Logic.ifElse (Equality.equal (Model.unName fname) (Model.unName activeName)) (Eithers.map (\jv -> (localName fname, jv)) (Coders.coderEncode (Coders.adapterCoder ad) activeValue)) (Right (localName fname, JsonModel.ValueNull)))
in (Eithers.map (\pairs -> JsonModel.ValueObject pairs) (Eithers.mapList encodePair fieldAdapters))
_ -> Left (Errors.ErrorOther (Errors.OtherError "expected union term"))),
Coders.coderDecode = (\j -> case j of
JsonModel.ValueObject v0 ->
let mm = Maps.fromList v0
findActive =
\remaining -> Optionals.match (Lists.uncons remaining) (Left (Errors.ErrorOther (Errors.OtherError "no non-null field in union record"))) (\p ->
let head_ = Pairs.first p
rest_ = Pairs.second p
fname = Pairs.first head_
ad = Pairs.second head_
mjv = Maps.lookup (localName fname) mm
in (Optionals.match mjv (findActive rest_) (\jv -> case jv of
JsonModel.ValueNull -> findActive rest_
_ -> Eithers.map (\t -> Model.TermInject (Model.Injection {
Model.injectionTypeName = typeName,
Model.injectionField = Model.Field {
Model.fieldName = fname,
Model.fieldTerm = t}})) (Coders.coderDecode (Coders.adapterCoder ad) jv))))
in (findActive fieldAdapters)
_ -> Left (Errors.ErrorOther (Errors.OtherError "expected JSON object for union-as-record")))}}
env2 =
Environment.EncodeEnvironment {
Environment.encodeEnvironmentTypeMap = (Environment.encodeEnvironmentTypeMap env1),
Environment.encodeEnvironmentEmitted = (Maps.insert typeName adapter_ (Environment.encodeEnvironmentEmitted env1))}
in (Right (adapter_, env2)))