From c590db2a65b63c645aa7eb3f4f8be9be2a216e73 Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Thu, 27 Jun 2024 21:23:06 +0100 Subject: [PATCH] JSON enums (#175) --- ConsumePlugin/GeneratedSerde.fs | 51 +++++++++ .../SerializationAndDeserialization.fs | 7 ++ .../TestJsonParse/TestJsonParse.fs | 12 +++ .../TestJsonSerialize/TestJsonSerde.fs | 2 + WoofWare.Myriad.Plugins/AstHelper.fs | 5 + WoofWare.Myriad.Plugins/CataGenerator.fs | 12 +-- WoofWare.Myriad.Plugins/JsonParseGenerator.fs | 67 +++++++++++- .../JsonSerializeGenerator.fs | 100 ++++++++++++++---- WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs | 25 ++--- 9 files changed, 232 insertions(+), 49 deletions(-) diff --git a/ConsumePlugin/GeneratedSerde.fs b/ConsumePlugin/GeneratedSerde.fs index ca6b66e..4604675 100644 --- a/ConsumePlugin/GeneratedSerde.fs +++ b/ConsumePlugin/GeneratedSerde.fs @@ -93,6 +93,24 @@ open System open System.Collections.Generic open System.Text.Json.Serialization +/// Module containing JSON serializing extension members for the SomeEnum type +[] +module SomeEnumJsonSerializeExtension = + /// Extension methods for JSON parsing + type SomeEnum with + + /// Serialize to a JSON node + static member toJsonNode (input : SomeEnum) : System.Text.Json.Nodes.JsonNode = + match input with + | SomeEnum.Blah -> System.Text.Json.Nodes.JsonValue.Create 1 + | SomeEnum.Thing -> System.Text.Json.Nodes.JsonValue.Create 0 + | v -> failwith (sprintf "Unrecognised value for enum: %O" v) +namespace ConsumePlugin + +open System +open System.Collections.Generic +open System.Text.Json.Serialization + /// Module containing JSON serializing extension members for the JsonRecordTypeWithBoth type [] module JsonRecordTypeWithBothJsonSerializeExtension = @@ -184,6 +202,8 @@ module JsonRecordTypeWithBothJsonSerializeExtension = )) ) + node.Add ("enum", (input.Enum |> SomeEnum.toJsonNode)) + node :> _ namespace ConsumePlugin @@ -323,6 +343,24 @@ module InnerTypeWithBothJsonParseExtension = } namespace ConsumePlugin +/// Module containing JSON parsing extension members for the SomeEnum type +[] +module SomeEnumJsonParseExtension = + /// Extension methods for JSON parsing + type SomeEnum with + + /// Parse from a JSON node. + static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : SomeEnum = + match node.GetValueKind () with + | System.Text.Json.JsonValueKind.Number -> node.AsValue().GetValue () |> enum + | System.Text.Json.JsonValueKind.String -> + match node.AsValue().GetValue().ToLowerInvariant () with + | "blah" -> SomeEnum.Blah + | "thing" -> SomeEnum.Thing + | v -> failwith ("Unrecognised value for enum: %i" + v) + | _ -> failwith ("Unrecognised kind for enum of type: " + "SomeEnum") +namespace ConsumePlugin + /// Module containing JSON parsing extension members for the JsonRecordTypeWithBoth type [] module JsonRecordTypeWithBothJsonParseExtension = @@ -331,6 +369,18 @@ module JsonRecordTypeWithBothJsonParseExtension = /// Parse from a JSON node. static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : JsonRecordTypeWithBoth = + let arg_19 = + SomeEnum.jsonParse ( + match node.["enum"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("enum") + ) + ) + | v -> v + ) + let arg_18 = match node.["intMeasureNullable"] with | null -> System.Nullable () @@ -585,6 +635,7 @@ module JsonRecordTypeWithBothJsonParseExtension = Single = arg_16 IntMeasureOption = arg_17 IntMeasureNullable = arg_18 + Enum = arg_19 } namespace ConsumePlugin diff --git a/ConsumePlugin/SerializationAndDeserialization.fs b/ConsumePlugin/SerializationAndDeserialization.fs index e6db5ed..3940f49 100644 --- a/ConsumePlugin/SerializationAndDeserialization.fs +++ b/ConsumePlugin/SerializationAndDeserialization.fs @@ -16,6 +16,12 @@ type InnerTypeWithBoth = ConcreteDict : Dictionary } +[] +[] +type SomeEnum = + | Blah = 1 + | Thing = 0 + [] type measure @@ -42,6 +48,7 @@ type JsonRecordTypeWithBoth = Single : single IntMeasureOption : int option IntMeasureNullable : int Nullable + Enum : SomeEnum } [] diff --git a/WoofWare.Myriad.Plugins.Test/TestJsonParse/TestJsonParse.fs b/WoofWare.Myriad.Plugins.Test/TestJsonParse/TestJsonParse.fs index d3da019..d60fcb7 100644 --- a/WoofWare.Myriad.Plugins.Test/TestJsonParse/TestJsonParse.fs +++ b/WoofWare.Myriad.Plugins.Test/TestJsonParse/TestJsonParse.fs @@ -49,3 +49,15 @@ module TestJsonParse = let actual = s |> JsonNode.Parse |> InnerType.jsonParse actual |> shouldEqual expected + + [] + [] + [] + [] + [] + [] + let ``Can deserialise enum`` (str : string, expected : SomeEnum) = + sprintf "\"%s\"" str + |> JsonNode.Parse + |> SomeEnum.jsonParse + |> shouldEqual expected diff --git a/WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs b/WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs index 7b64bf3..a58ccdc 100644 --- a/WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs +++ b/WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs @@ -91,6 +91,7 @@ module TestJsonSerde = let! single = Arb.generate |> Gen.filter (fun s -> Single.IsFinite (s / 1.0f)) let! intMeasureOption = Arb.generate let! intMeasureNullable = Arb.generate + let! someEnum = Gen.choose (0, 1) return { @@ -113,6 +114,7 @@ module TestJsonSerde = Single = single IntMeasureOption = intMeasureOption IntMeasureNullable = intMeasureNullable + Enum = enum someEnum } } diff --git a/WoofWare.Myriad.Plugins/AstHelper.fs b/WoofWare.Myriad.Plugins/AstHelper.fs index 4321cf4..8df2012 100644 --- a/WoofWare.Myriad.Plugins/AstHelper.fs +++ b/WoofWare.Myriad.Plugins/AstHelper.fs @@ -96,6 +96,11 @@ type internal AdtProduct = [] module internal AstHelper = + let isEnum (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _)) : bool = + match repr with + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Enum _, _) -> true + | _ -> false + let instantiateRecord (fields : (RecordFieldName * SynExpr option) list) : SynExpr = let fields = fields diff --git a/WoofWare.Myriad.Plugins/CataGenerator.fs b/WoofWare.Myriad.Plugins/CataGenerator.fs index 411fe71..c8494eb 100644 --- a/WoofWare.Myriad.Plugins/CataGenerator.fs +++ b/WoofWare.Myriad.Plugins/CataGenerator.fs @@ -1070,17 +1070,11 @@ module internal CataGenerator = body |> SynExpr.createLet [ - SynExpr.TypeApp ( - SynExpr.createIdent "ResizeArray", - range0, + (SynExpr.createIdent "ResizeArray") + |> SynExpr.typeApp [ SynType.var (SynTypar.SynTypar (unionCase.GenericName, TyparStaticReq.None, false)) - ], - [], - Some range0, - range0, - range0 - ) + ] |> SynExpr.applyTo (SynExpr.CreateConst ()) |> SynBinding.basic [ unionCase.StackName ] [] ] diff --git a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs index c04df53..cf92eaf 100644 --- a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs @@ -24,7 +24,7 @@ module internal JsonParseGenerator = JsonNumberHandlingArg = None } - /// (match {indexed} with | null -> raise (System.Collections.Generic.KeyNotFoundException ()) | v -> v) + /// (match {indexed} with | null -> raise (System.Collections.Generic.KeyNotFoundException ({propertyName} not found)) | v -> v) let assertNotNull (propertyName : SynExpr) (indexed : SynExpr) = let raiseExpr = SynExpr.applyFunction @@ -488,6 +488,59 @@ module internal JsonParseGenerator = |> SynBinding.basic [ Ident.create "ty" ] [] ] + let createEnumMaker + (spec : JsonParseOutputSpec) + (typeName : LongIdent) + (fields : (Ident * SynExpr) list) + : SynExpr + = + let numberKind = + [ "System" ; "Text" ; "Json" ; "JsonValueKind" ; "Number" ] + |> List.map Ident.create + + let stringKind = + [ "System" ; "Text" ; "Json" ; "JsonValueKind" ; "String" ] + |> List.map Ident.create + + let fail = + SynExpr.plus + (SynExpr.CreateConst "Unrecognised kind for enum of type: ") + (SynExpr.CreateConst (typeName |> List.map _.idText |> String.concat ".")) + |> SynExpr.paren + |> SynExpr.applyFunction (SynExpr.createIdent "failwith") + + let failString = + SynExpr.plus (SynExpr.CreateConst "Unrecognised value for enum: %i") (SynExpr.createIdent "v") + |> SynExpr.paren + |> SynExpr.applyFunction (SynExpr.createIdent "failwith") + + let parseString = + fields + |> List.map (fun (ident, _) -> + SynMatchClause.create + (SynPat.createConst ( + SynConst.String (ident.idText.ToLowerInvariant (), SynStringKind.Regular, range0) + )) + (SynExpr.createLongIdent' (typeName @ [ ident ])) + ) + |> fun l -> l @ [ SynMatchClause.create (SynPat.named "v") failString ] + |> SynExpr.createMatch ( + asValueGetValue None "string" (SynExpr.createIdent "node") + |> SynExpr.callMethod "ToLowerInvariant" + ) + + [ + SynMatchClause.create + (SynPat.identWithArgs numberKind (SynArgPats.create [])) + (asValueGetValue None "int" (SynExpr.createIdent "node") + |> SynExpr.pipeThroughFunction ( + SynExpr.typeApp [ SynType.createLongIdent typeName ] (SynExpr.createIdent "enum") + )) + SynMatchClause.create (SynPat.identWithArgs stringKind (SynArgPats.create [])) parseString + SynMatchClause.create (SynPat.named "_") fail + ] + |> SynExpr.createMatch (SynExpr.callMethod "GetValueKind" (SynExpr.createIdent "node")) + let createModule (namespaceId : LongIdent) (spec : JsonParseOutputSpec) (typeDefn : SynTypeDefn) = let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) = typeDefn @@ -548,6 +601,13 @@ module internal JsonParseGenerator = |> List.map SynUnionCase.extract |> List.map (UnionCase.mapIdentFields optionGet) |> createUnionMaker spec ident + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Enum (cases, _range), _) -> + cases + |> List.map (fun c -> + match c with + | SynEnumCase.SynEnumCase (_, SynIdent.SynIdent (ident, _), value, _, _, _) -> ident, value + ) + |> createEnumMaker spec ident | _ -> failwithf "Not a record or union type" [ scaffolding spec ident decl ] @@ -569,20 +629,21 @@ type JsonParseGenerator () = let ast, _ = Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head - let recordsAndUnions = + let relevantTypes = Ast.extractTypeDefn ast |> List.map (fun (name, defns) -> defns |> List.choose (fun defn -> if Ast.isRecord defn then Some defn elif Ast.isDu defn then Some defn + elif AstHelper.isEnum defn then Some defn else None ) |> fun defns -> name, defns ) let namespaceAndTypes = - recordsAndUnions + relevantTypes |> List.choose (fun (ns, types) -> types |> List.choose (fun typeDef -> diff --git a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs index 534ee2e..004f8f5 100644 --- a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs @@ -34,15 +34,8 @@ module internal JsonSerializeGenerator = | Guid | Uri -> // JsonValue.Create - SynExpr.TypeApp ( - SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ], - range0, - [ fieldType ], - [], - Some range0, - range0, - range0 - ) + SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ] + |> SynExpr.typeApp [ fieldType ] | NullableType ty -> // fun field -> if field.HasValue then {serializeNode ty} field.Value else JsonValue.Create null SynExpr.applyFunction (serializeNode ty) (SynExpr.createLongIdent [ "field" ; "Value" ]) @@ -238,8 +231,7 @@ module internal JsonSerializeGenerator = |> SynBinding.withXmlDoc xmlDoc |> SynModuleDecl.createLet - let recordModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (fields : SynField list) = - let inputArg = Ident.create "input" + let recordModule (spec : JsonSerializeOutputSpec) (_typeName : LongIdent) (fields : SynField list) = let fields = fields |> List.map SynField.extractWithIdent fields @@ -249,7 +241,6 @@ module internal JsonSerializeGenerator = ) |> SynExpr.sequential |> fun expr -> SynExpr.Do (expr, range0) - |> scaffolding spec typeName inputArg let unionModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (cases : SynUnionCase list) = let inputArg = Ident.create "input" @@ -322,7 +313,68 @@ module internal JsonSerializeGenerator = SynMatchClause.create pattern action ) |> SynExpr.createMatch (SynExpr.createIdent' inputArg) - |> scaffolding spec typeName inputArg + + let enumModule + (spec : JsonSerializeOutputSpec) + (typeName : LongIdent) + (cases : (Ident * SynExpr) list) + : SynModuleDecl + = + let fail = + SynExpr.CreateConst "Unrecognised value for enum: %O" + |> SynExpr.applyFunction (SynExpr.createIdent "sprintf") + |> SynExpr.applyTo (SynExpr.createIdent "v") + |> SynExpr.paren + |> SynExpr.applyFunction (SynExpr.createIdent "failwith") + + let body = + cases + |> List.map (fun (caseName, value) -> + value + |> SynExpr.applyFunction ( + SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ] + ) + |> SynMatchClause.create (SynPat.identWithArgs (typeName @ [ caseName ]) (SynArgPats.create [])) + ) + |> fun l -> l @ [ SynMatchClause.create (SynPat.named "v") fail ] + |> SynExpr.createMatch (SynExpr.createIdent "input") + + let xmlDoc = PreXmlDoc.create "Serialize to a JSON node" + + let returnInfo = + SynLongIdent.createS' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ] + |> SynType.LongIdent + + let functionName = Ident.create "toJsonNode" + + let pattern = + SynPat.named "input" + |> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create typeName)) + + if spec.ExtensionMethods then + let componentInfo = + SynComponentInfo.createLong typeName + |> SynComponentInfo.withDocString (PreXmlDoc.create "Extension methods for JSON parsing") + + let memberDef = + body + |> SynBinding.basic [ functionName ] [ pattern ] + |> SynBinding.withXmlDoc xmlDoc + |> SynBinding.withReturnAnnotation returnInfo + |> SynMemberDefn.staticMember + + let containingType = + SynTypeDefnRepr.augmentation () + |> SynTypeDefn.create componentInfo + |> SynTypeDefn.withMemberDefns [ memberDef ] + + SynModuleDecl.Types ([ containingType ], range0) + else + body + |> SynBinding.basic [ functionName ] [ pattern ] + |> SynBinding.withReturnAnnotation returnInfo + |> SynBinding.withXmlDoc xmlDoc + |> SynModuleDecl.createLet let createModule (namespaceId : LongIdent) @@ -378,14 +430,23 @@ module internal JsonSerializeGenerator = let decls = match synTypeDefnRepr with | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _range), _) -> - [ recordModule spec ident recordFields ] + recordModule spec ident recordFields + |> scaffolding spec ident (Ident.create "input") | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_accessibility, unionFields, _range), _) -> - [ unionModule spec ident unionFields ] - | _ -> failwithf "Only record types currently supported." + unionModule spec ident unionFields + |> scaffolding spec ident (Ident.create "input") + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Enum (cases, _range), _) -> + cases + |> List.map (fun c -> + match c with + | SynEnumCase.SynEnumCase (_, SynIdent.SynIdent (ident, _), value, _, _, _) -> ident, value + ) + |> enumModule spec ident + | ty -> failwithf "Unsupported type: got %O" ty [ yield! opens |> List.map SynModuleDecl.openAny - yield SynModuleDecl.nestedModule info decls + yield decls |> List.singleton |> SynModuleDecl.nestedModule info ] |> SynModuleOrNamespace.createNamespace namespaceId @@ -403,20 +464,21 @@ type JsonSerializeGenerator () = let ast, _ = Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head - let recordsAndUnions = + let relevantTypes = Ast.extractTypeDefn ast |> List.map (fun (name, defns) -> defns |> List.choose (fun defn -> if Ast.isRecord defn then Some defn elif Ast.isDu defn then Some defn + elif AstHelper.isEnum defn then Some defn else None ) |> fun defns -> name, defns ) let namespaceAndTypes = - recordsAndUnions + relevantTypes |> List.choose (fun (ns, types) -> types |> List.choose (fun typeDef -> diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs b/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs index ae69118..8d3c36e 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs @@ -121,29 +121,18 @@ module internal SynExpr = let callMethod (meth : string) (obj : SynExpr) : SynExpr = callMethodArg meth (SynExpr.CreateConst ()) obj + let typeApp (types : SynType list) (operand : SynExpr) = + SynExpr.TypeApp (operand, range0, types, List.replicate (types.Length - 1) range0, Some range0, range0, range0) + let callGenericMethod (meth : string) (ty : LongIdent) (obj : SynExpr) : SynExpr = - SynExpr.TypeApp ( - SynExpr.DotGet (obj, range0, SynLongIdent.createS meth, range0), - range0, - [ SynType.LongIdent (SynLongIdent.create ty) ], - [], - Some range0, - range0, - range0 - ) + SynExpr.DotGet (obj, range0, SynLongIdent.createS meth, range0) + |> typeApp [ SynType.LongIdent (SynLongIdent.create ty) ] |> applyTo (SynExpr.CreateConst ()) /// {obj}.{meth}() let callGenericMethod' (meth : string) (ty : string) (obj : SynExpr) : SynExpr = - SynExpr.TypeApp ( - SynExpr.DotGet (obj, range0, SynLongIdent.createS meth, range0), - range0, - [ SynType.createLongIdent' [ ty ] ], - [], - Some range0, - range0, - range0 - ) + SynExpr.DotGet (obj, range0, SynLongIdent.createS meth, range0) + |> typeApp [ SynType.createLongIdent' [ ty ] ] |> applyTo (SynExpr.CreateConst ()) let inline index (property : SynExpr) (obj : SynExpr) : SynExpr =