hydra-ext-0.17.0: src/main/haskell/Hydra/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.Avro.Encoder where
import qualified Hydra.Annotations as Annotations
import qualified Hydra.Ast as Ast
import qualified Hydra.Avro.Environment as Environment
import qualified Hydra.Avro.Schema as Schema
import qualified Hydra.Coders as Coders
import qualified Hydra.Core as Core
import qualified Hydra.Error.Checking as Checking
import qualified Hydra.Error.Core as ErrorCore
import qualified Hydra.Error.Packaging as ErrorPackaging
import qualified Hydra.Errors as Errors
import qualified Hydra.Extract.Core as ExtractCore
import qualified Hydra.Graph as Graph
import qualified Hydra.Json.Model as Model
import qualified Hydra.Overlay.Haskell.Lib.Eithers as Eithers
import qualified Hydra.Overlay.Haskell.Lib.Equality as Equality
import qualified Hydra.Overlay.Haskell.Lib.Lists as Lists
import qualified Hydra.Overlay.Haskell.Lib.Literals as Literals
import qualified Hydra.Overlay.Haskell.Lib.Logic as Logic
import qualified Hydra.Overlay.Haskell.Lib.Maps as Maps
import qualified Hydra.Overlay.Haskell.Lib.Optionals as Optionals
import qualified Hydra.Overlay.Haskell.Lib.Pairs as Pairs
import qualified Hydra.Overlay.Haskell.Lib.Sets as Sets
import qualified Hydra.Overlay.Haskell.Lib.Strings as Strings
import qualified Hydra.Packaging as Packaging
import qualified Hydra.Parsing as Parsing
import qualified Hydra.Paths as Paths
import qualified Hydra.Query as Query
import qualified Hydra.Relational as Relational
import qualified Hydra.Strip as Strip
import qualified Hydra.Tabular as Tabular
import qualified Hydra.Testing as Testing
import qualified Hydra.Topology as Topology
import qualified Hydra.Typed as Typed
import qualified Hydra.Util as Util
import qualified Hydra.Validation as Validation
import qualified Hydra.Variants as Variants
import Prelude hiding (Enum, Ordering, decodeFloat, encodeFloat, fail, map, pure, sum)
import qualified Data.Scientific as Sci
import qualified Data.Map as M
-- | Build an Avro field from a name-adapter pair
buildAvroField :: (Core.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 Core.Name Core.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 Core.Name Core.Type -> Core.Name -> Either Errors.Error (Coders.Adapter Core.Type Schema.Schema Core.Term Model.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 Core.Name -> Core.Type -> Environment.EncodeEnvironment -> Either Errors.Error (Coders.Adapter Core.Type Schema.Schema Core.Term Model.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
Core.TypeUnit -> simpleAdapter (Schema.SchemaPrimitive Schema.PrimitiveNull) False (\_t -> Right Model.ValueNull) (\_j -> Right Core.TermUnit)
Core.TypeLiteral v0 -> Eithers.map (\ad -> (ad, env)) (literalAdapter cx typ v0)
Core.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
Core.TermList v1 -> Eithers.map (\jvs -> Model.ValueArray jvs) (Eithers.mapList (\el -> Coders.coderEncode (Coders.adapterCoder innerAd) el) v1)),
Coders.coderDecode = (\j -> case j of
Model.ValueArray v1 -> Eithers.map (\ts -> Core.TermList ts) (Eithers.mapList (\el -> Coders.coderDecode (Coders.adapterCoder innerAd) el) v1))}},
env1)))
Core.TypeMap v0 ->
let keyType = Core.mapTypeKeys v0
valType = Core.mapTypeValues v0
in case (Strip.deannotateType keyType) of
Core.TypeLiteral v1 -> case v1 of
Core.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
Core.TermMap v3 ->
let encodeEntry =
\entry ->
let k = Pairs.first entry
v = Pairs.second entry
in (Eithers.bind (ExtractCore.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 -> Model.ValueObject (pairs)) (Eithers.mapList encodeEntry (Maps.toList v3)))),
Coders.coderDecode = (\j -> case j of
Model.ValueObject v3 ->
let decodeEntry =
\entry ->
let k = Pairs.first entry
v = Pairs.second entry
in (Eithers.map (\vTerm -> (Core.TermLiteral (Core.LiteralString k), vTerm)) (Coders.coderDecode (Coders.adapterCoder valAd) v))
in (Eithers.map (\pairs -> Core.TermMap (Maps.fromList pairs)) (Eithers.mapList decodeEntry v3)))}},
env1)))
_ -> err cx "Avro maps require string keys"
_ -> err cx "Avro maps require string keys"
Core.TypeRecord v0 -> namedTypeAdapter cx typ mName annotations v0 env (\avroFields -> Schema.NamedTypeRecord (Schema.Record {
Schema.recordFields = avroFields})) recordTermCoder
Core.TypeUnion v0 ->
let allUnit =
Lists.foldl (\b -> \ft -> Logic.and b (case (Core.fieldTypeType ft) of
Core.TypeUnit -> True
_ -> False)) True v0
in (Logic.ifElse allUnit (enumAdapter cx typ mName annotations v0 env) (unionAsRecordAdapter cx typ mName annotations v0 env))
Core.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
Core.TermOptional v1 -> Optionals.cases v1 (Right Model.ValueNull) (\inner -> Coders.coderEncode (Coders.adapterCoder innerAd) inner)),
Coders.coderDecode = (\j -> case j of
Model.ValueNull -> Right (Core.TermOptional Nothing)
_ -> Eithers.map (\t -> Core.TermOptional (Just t)) (Coders.coderDecode (Coders.adapterCoder innerAd) j))}},
env1)))
Core.TypeWrap v0 -> encodeTypeInner cx mName v0 env
Core.TypeVariable v0 -> Optionals.cases (Maps.lookup v0 (Environment.encodeEnvironmentEmitted env)) (Optionals.cases (Maps.lookup v0 (Environment.encodeEnvironmentTypeMap env)) (err cx (Strings.cat2 "referenced type not found: " (Core.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 -> Core.Name -> Environment.EncodeEnvironment -> Either Errors.Error (Coders.Adapter Core.Type Schema.Schema Core.Term Model.Value Errors.Error, Environment.EncodeEnvironment)
encodeTypeWithEnv cx name_ env =
Optionals.cases (Maps.lookup name_ (Environment.encodeEnvironmentTypeMap env)) (err cx (Strings.cat2 "type not found in type map: " (Literals.showString (Core.unName name_)))) (\typ -> encodeTypeInner cx (Just name_) typ env)
-- | Adapter for all-unit union types (enums)
enumAdapter :: t0 -> Core.Type -> Maybe Core.Name -> M.Map Core.Name Core.Term -> [Core.FieldType] -> Environment.EncodeEnvironment -> Either t1 (Coders.Adapter Core.Type Schema.Schema Core.Term Model.Value Errors.Error, Environment.EncodeEnvironment)
enumAdapter cx typ mName annotations fieldTypes env0 =
let symbols = Lists.map (\ft -> localName (Core.fieldTypeName ft)) fieldTypes
typeName = Optionals.fromOptional (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
Core.TermInject v0 ->
let fname = Core.injectionField v0
in (Right (Model.ValueString (localName (Core.fieldName fname))))
_ -> err cx "expected union term for enum"),
Coders.coderDecode = (\j -> case j of
Model.ValueString v0 -> Right (Core.TermInject (Core.Injection {
Core.injectionTypeName = typeName,
Core.injectionField = Core.Field {
Core.fieldName = (Core.Name v0),
Core.fieldTerm = Core.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 :: Core.Type -> (M.Map Core.Name Core.Term, Core.Type)
extractAnnotations typ =
case typ of
Core.TypeAnnotated v0 ->
let inner = Core.annotatedTypeBody v0
anns = Annotations.getAnnotationMap (Core.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 -> Core.FloatType -> Either t2 (Coders.Adapter t1 Schema.Schema Core.Term Model.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
Core.FloatTypeFloat32 -> simple (Schema.SchemaPrimitive Schema.PrimitiveFloat) False (\t -> Eithers.map (\f -> Model.ValueNumber (Literals.float32ToDecimal f)) (ExtractCore.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
Model.ValueNumber v1 -> Right (Core.TermLiteral (Core.LiteralFloat (Core.FloatValueFloat32 (Literals.decimalToFloat32 v1)))))
Core.FloatTypeFloat64 -> simple (Schema.SchemaPrimitive Schema.PrimitiveDouble) False (\t -> Eithers.map (\d -> Model.ValueNumber (Literals.float64ToDecimal d)) (ExtractCore.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
Model.ValueNumber v1 -> Right (Core.TermLiteral (Core.LiteralFloat (Core.FloatValueFloat64 (Literals.decimalToFloat64 v1)))))
_ -> simple (Schema.SchemaPrimitive Schema.PrimitiveDouble) True (\t -> case t of
Core.TermLiteral v0 -> case v0 of
Core.LiteralFloat v1 -> Right (Model.ValueNumber (floatValueToDouble v1))) (\j -> case j of
Model.ValueNumber v0 -> Right (Core.TermLiteral (Core.LiteralFloat (Core.FloatValueFloat64 (Literals.decimalToFloat64 v0)))))
-- | Convert any float value to a JSON decimal number
floatValueToDouble :: Core.FloatValue -> Sci.Scientific
floatValueToDouble fv =
case fv of
Core.FloatValueFloat32 v0 -> Literals.float32ToDecimal v0
Core.FloatValueFloat64 v0 -> Literals.float64ToDecimal v0
-- | Fold over field types, building adapters and threading the environment
foldFieldAdapters :: t0 -> [Core.FieldType] -> Environment.EncodeEnvironment -> Either Errors.Error ([(Core.Name, (Coders.Adapter Core.Type Schema.Schema Core.Term Model.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 = Core.fieldTypeName ft
ftype = Core.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 Core.Name Core.Term -> M.Map String Model.Value
hydraAnnotationsToAvro anns =
Maps.fromList (Lists.map (\entry ->
let k = Pairs.first entry
v = Pairs.second entry
in (Core.unName k, (termToJsonValue v))) (Maps.toList anns))
-- | Encode a single type without a type map (for simple/anonymous types)
hydraAvroAdapter :: t0 -> M.Map Core.Name Core.Type -> Core.Type -> Either Errors.Error (Coders.Adapter Core.Type Schema.Schema Core.Term Model.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 :: Core.Name -> (String, (Maybe String))
hydraNameToAvroName name_ = (localName name_, (nameNamespace name_))
-- | Create an adapter for integer types
integerAdapter :: t0 -> t1 -> Core.IntegerType -> Either t2 (Coders.Adapter t1 Schema.Schema Core.Term Model.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
Core.IntegerTypeInt32 -> simple (Schema.SchemaPrimitive Schema.PrimitiveInt) False (\t -> Eithers.map (\i -> Model.ValueNumber (Literals.bigintToDecimal (Literals.int32ToBigint i))) (ExtractCore.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
Model.ValueNumber v1 -> Right (Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueInt32 (Literals.bigintToInt32 (Literals.decimalToBigint v1))))))
Core.IntegerTypeInt64 -> simple (Schema.SchemaPrimitive Schema.PrimitiveLong) False (\t -> Eithers.map (\i -> Model.ValueNumber (Literals.bigintToDecimal (Literals.int64ToBigint i))) (ExtractCore.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
Model.ValueNumber v1 -> Right (Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueInt64 (Literals.bigintToInt64 (Literals.decimalToBigint v1))))))
_ -> simple (Schema.SchemaPrimitive Schema.PrimitiveLong) True (\t -> case t of
Core.TermLiteral v0 -> case v0 of
Core.LiteralInteger v1 -> Right (Model.ValueNumber (integerValueToDouble v1))) (\j -> case j of
Model.ValueNumber v0 -> Right (Core.TermLiteral (Core.LiteralInteger (Core.IntegerValueInt64 (Literals.bigintToInt64 (Literals.decimalToBigint v0))))))
-- | Convert any integer value to a JSON decimal number
integerValueToDouble :: Core.IntegerValue -> Sci.Scientific
integerValueToDouble iv =
case iv of
Core.IntegerValueBigint v0 -> Literals.bigintToDecimal v0
Core.IntegerValueInt8 v0 -> Literals.bigintToDecimal (Literals.int8ToBigint v0)
Core.IntegerValueInt16 v0 -> Literals.bigintToDecimal (Literals.int16ToBigint v0)
Core.IntegerValueInt32 v0 -> Literals.bigintToDecimal (Literals.int32ToBigint v0)
Core.IntegerValueInt64 v0 -> Literals.bigintToDecimal (Literals.int64ToBigint v0)
Core.IntegerValueUint8 v0 -> Literals.bigintToDecimal (Literals.uint8ToBigint v0)
Core.IntegerValueUint16 v0 -> Literals.bigintToDecimal (Literals.uint16ToBigint v0)
Core.IntegerValueUint32 v0 -> Literals.bigintToDecimal (Literals.uint32ToBigint v0)
Core.IntegerValueUint64 v0 -> Literals.bigintToDecimal (Literals.uint64ToBigint v0)
-- | Create an adapter for literal types
literalAdapter :: t0 -> t1 -> Core.LiteralType -> Either t2 (Coders.Adapter t1 Schema.Schema Core.Term Model.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
Core.LiteralTypeBoolean -> simple (Schema.SchemaPrimitive Schema.PrimitiveBoolean) False (\t -> case t of
Core.TermLiteral v1 -> case v1 of
Core.LiteralBoolean v2 -> Right (Model.ValueBoolean v2)) (\j -> case j of
Model.ValueBoolean v1 -> Right (Core.TermLiteral (Core.LiteralBoolean v1)))
Core.LiteralTypeString -> simple (Schema.SchemaPrimitive Schema.PrimitiveString) False (\t -> case t of
Core.TermLiteral v1 -> case v1 of
Core.LiteralString v2 -> Right (Model.ValueString v2)) (\j -> case j of
Model.ValueString v1 -> Right (Core.TermLiteral (Core.LiteralString v1)))
Core.LiteralTypeBinary -> simple (Schema.SchemaPrimitive Schema.PrimitiveBytes) False (\t -> case t of
Core.TermLiteral v1 -> case v1 of
Core.LiteralBinary v2 -> Right (Model.ValueString (Literals.binaryToString v2))) (\j -> case j of
Model.ValueString v1 -> Right (Core.TermLiteral (Core.LiteralBinary (Literals.stringToBinary v1))))
Core.LiteralTypeInteger v0 -> integerAdapter cx typ v0
Core.LiteralTypeFloat v0 -> floatAdapter cx typ v0
-- | Extract the local part of a qualified name
localName :: Core.Name -> String
localName name_ =
let s = Core.unName name_
parts = Strings.splitOn "." s
in (Optionals.fromOptional s (Lists.maybeLast parts))
-- | Extract the namespace from a qualified name, if any
nameNamespace :: Core.Name -> Maybe String
nameNamespace name_ =
let s = Core.unName name_
parts = Strings.splitOn "." s
in (Logic.ifElse (Equality.equal (Lists.length parts) 1) Nothing (Optionals.map (\ps -> Strings.intercalate "." ps) (Lists.maybeInit parts)))
-- | Build a named type adapter (shared between record and union-as-record)
namedTypeAdapter :: t0 -> Core.Type -> Maybe Core.Name -> M.Map Core.Name Core.Term -> [Core.FieldType] -> Environment.EncodeEnvironment -> ([Schema.Field] -> Schema.NamedType) -> (t0 -> Core.Name -> [(Core.Name, (Coders.Adapter Core.Type Schema.Schema Core.Term Model.Value Errors.Error))] -> (
(Core.Term -> Either Errors.Error Model.Value),
(Model.Value -> Either Errors.Error Core.Term))) -> Either Errors.Error (Coders.Adapter Core.Type Schema.Schema Core.Term Model.Value Errors.Error, Environment.EncodeEnvironment)
namedTypeAdapter cx typ mName annotations fieldTypes env0 mkNamedType mkCoder =
let typeName = Optionals.fromOptional (typeToName typ) mName
in (Optionals.cases (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 -> Core.Name -> [(Core.Name, (Coders.Adapter t1 t2 Core.Term Model.Value Errors.Error))] -> (
(Core.Term -> Either Errors.Error Model.Value),
(Model.Value -> Either Errors.Error Core.Term))
recordTermCoder cx typeName fieldAdapters =
let encode =
\term -> case term of
Core.TermRecord v0 ->
let fields = Core.recordFields v0
fieldMap = Maps.fromList (Lists.map (\f -> (Core.fieldName f, (Core.fieldTerm f))) fields)
encodeField =
\nameAd ->
let fname = Pairs.first nameAd
ad = Pairs.second nameAd
fTerm = Optionals.fromOptional Core.TermUnit (Maps.lookup fname fieldMap)
in (Eithers.map (\jv -> (localName fname, jv)) (Coders.coderEncode (Coders.adapterCoder ad) fTerm))
in (Eithers.map (\pairs -> Model.ValueObject (pairs)) (Eithers.mapList encodeField fieldAdapters))
_ -> err cx "expected record term"
decode =
\json -> case json of
Model.ValueObject v0 ->
let decodeField =
\nameAd ->
let fname = Pairs.first nameAd
ad = Pairs.second nameAd
jv = Optionals.fromOptional Model.ValueNull (Maps.lookup (localName fname) (Maps.fromList v0))
in (Eithers.map (\t -> Core.Field {
Core.fieldName = fname,
Core.fieldTerm = t}) (Coders.coderDecode (Coders.adapterCoder ad) jv))
in (Eithers.map (\fields -> Core.TermRecord (Core.Record {
Core.recordTypeName = typeName,
Core.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 :: Core.Term -> Model.Value
termToJsonValue term =
case term of
Core.TermLiteral v0 -> case v0 of
Core.LiteralString v1 -> Model.ValueString v1
Core.LiteralBoolean v1 -> Model.ValueBoolean v1
Core.LiteralInteger v1 -> Model.ValueNumber (integerValueToDouble v1)
Core.LiteralFloat v1 -> Model.ValueNumber (floatValueToDouble v1)
Core.LiteralBinary v1 -> Model.ValueString (Literals.binaryToString v1)
Core.TermList v0 -> Model.ValueArray (Lists.map termToJsonValue v0)
Core.TermMap v0 -> Model.ValueObject ((Lists.map (\entry ->
let k = Pairs.first entry
v = Pairs.second entry
in (
case k of
Core.TermLiteral v1 -> case v1 of
Core.LiteralString v2 -> v2
_ -> "<key>"
_ -> "<key>",
(termToJsonValue v))) (Maps.toList v0)))
Core.TermRecord v0 -> Logic.ifElse (Lists.null (Core.recordFields v0)) Model.ValueNull (Model.ValueString "<record>")
_ -> Model.ValueString "<term>"
-- | Generate a default name for an anonymous type
typeToName :: Core.Type -> Core.Name
typeToName t =
case (Strip.deannotateType t) of
Core.TypeRecord _ -> Core.Name "Record"
Core.TypeUnion _ -> Core.Name "Union"
_ -> Core.Name "Unknown"
-- | Adapter for general unions (encoded as records with optional fields)
unionAsRecordAdapter :: t0 -> Core.Type -> Maybe Core.Name -> M.Map Core.Name Core.Term -> [Core.FieldType] -> Environment.EncodeEnvironment -> Either Errors.Error (Coders.Adapter Core.Type Schema.Schema Core.Term Model.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 Model.ValueNull),
Schema.fieldOrder = Nothing,
Schema.fieldAliases = Nothing,
Schema.fieldAnnotations = Maps.empty}) fieldAdapters
typeName = Optionals.fromOptional (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
Core.TermInject v0 ->
let activeName = Core.fieldName (Core.injectionField v0)
activeValue = Core.fieldTerm (Core.injectionField v0)
encodePair =
\nameAd ->
let fname = Pairs.first nameAd
ad = Pairs.second nameAd
in (Logic.ifElse (Equality.equal (Core.unName fname) (Core.unName activeName)) (Eithers.map (\jv -> (localName fname, jv)) (Coders.coderEncode (Coders.adapterCoder ad) activeValue)) (Right (localName fname, Model.ValueNull)))
in (Eithers.map (\pairs -> Model.ValueObject (pairs)) (Eithers.mapList encodePair fieldAdapters))
_ -> err cx "expected union term"),
Coders.coderDecode = (\j -> case j of
Model.ValueObject v0 ->
let findActive =
\remaining -> Optionals.cases (Lists.uncons remaining) (err cx "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) (Maps.fromList v0)
in (Optionals.cases mjv (findActive rest_) (\jv -> case jv of
Model.ValueNull -> findActive rest_
_ -> Eithers.map (\t -> Core.TermInject (Core.Injection {
Core.injectionTypeName = typeName,
Core.injectionField = Core.Field {
Core.fieldName = fname,
Core.fieldTerm = t}})) (Coders.coderDecode (Coders.adapterCoder ad) jv))))
in (findActive fieldAdapters)
_ -> err cx "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)))