diff --git a/ConsumePlugin/GeneratedSerde.fs b/ConsumePlugin/GeneratedSerde.fs index 3c57fb7..622b78a 100644 --- a/ConsumePlugin/GeneratedSerde.fs +++ b/ConsumePlugin/GeneratedSerde.fs @@ -291,6 +291,60 @@ module FooJsonSerializeExtension = ) node :> _ +namespace ConsumePlugin + +open System +open System.Collections.Generic +open System.Text.Json.Serialization + +/// Module containing JSON serializing extension members for the CollectRemaining type +[] +module CollectRemainingJsonSerializeExtension = + /// Extension methods for JSON parsing + type CollectRemaining with + + /// Serialize to a JSON node + static member toJsonNode (input : CollectRemaining) : System.Text.Json.Nodes.JsonNode = + let node = System.Text.Json.Nodes.JsonObject () + + do + node.Add ( + "message", + (input.Message + |> (fun field -> + match field with + | None -> null :> System.Text.Json.Nodes.JsonNode + | Some field -> HeaderAndValue.toJsonNode field + )) + ) + + for KeyValue (key, value) in input.Rest do + node.Add (key, id value) + + node :> _ +namespace ConsumePlugin + +open System +open System.Collections.Generic +open System.Text.Json.Serialization + +/// Module containing JSON serializing extension members for the OuterCollectRemaining type +[] +module OuterCollectRemainingJsonSerializeExtension = + /// Extension methods for JSON parsing + type OuterCollectRemaining with + + /// Serialize to a JSON node + static member toJsonNode (input : OuterCollectRemaining) : System.Text.Json.Nodes.JsonNode = + let node = System.Text.Json.Nodes.JsonObject () + + do + for KeyValue (key, value) in input.Others do + node.Add (key, System.Text.Json.Nodes.JsonValue.Create value) + + node.Add ("remaining", (input.Remaining |> CollectRemaining.toJsonNode)) + + node :> _ namespace ConsumePlugin @@ -842,3 +896,83 @@ module FooJsonParseExtension = { Message = arg_0 } +namespace ConsumePlugin + +/// Module containing JSON parsing extension members for the CollectRemaining type +[] +module CollectRemainingJsonParseExtension = + /// Extension methods for JSON parsing + type CollectRemaining with + + /// Parse from a JSON node. + static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : CollectRemaining = + let arg_1 = + let result = + System.Collections.Generic.Dictionary () + + let node = node.AsObject () + + for KeyValue (key, value) in node do + if key = "message" then () else result.Add (key, node.[key]) + + result + + let arg_0 = + match node.["message"] with + | null -> None + | v -> HeaderAndValue.jsonParse v |> Some + + { + Message = arg_0 + Rest = arg_1 + } +namespace ConsumePlugin + +/// Module containing JSON parsing extension members for the OuterCollectRemaining type +[] +module OuterCollectRemainingJsonParseExtension = + /// Extension methods for JSON parsing + type OuterCollectRemaining with + + /// Parse from a JSON node. + static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : OuterCollectRemaining = + let arg_1 = + CollectRemaining.jsonParse ( + match node.["remaining"] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" ("remaining") + ) + ) + | v -> v + ) + + let arg_0 = + let result = System.Collections.Generic.Dictionary () + let node = node.AsObject () + + for KeyValue (key, value) in node do + if key = "remaining" then + () + else + result.Add ( + key, + (match node.[key] with + | null -> + raise ( + System.Collections.Generic.KeyNotFoundException ( + sprintf "Required key '%s' not found on JSON object" (key) + ) + ) + | v -> v) + .AsValue() + .GetValue () + ) + + result + + { + Others = arg_0 + Remaining = arg_1 + } diff --git a/ConsumePlugin/SerializationAndDeserialization.fs b/ConsumePlugin/SerializationAndDeserialization.fs index 96e6fee..66365ef 100644 --- a/ConsumePlugin/SerializationAndDeserialization.fs +++ b/ConsumePlugin/SerializationAndDeserialization.fs @@ -73,3 +73,21 @@ type Foo = { Message : HeaderAndValue option } + +[] +[] +type CollectRemaining = + { + Message : HeaderAndValue option + [] + Rest : Dictionary + } + +[] +[] +type OuterCollectRemaining = + { + [] + Others : Dictionary + Remaining : CollectRemaining + } diff --git a/WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs b/WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs index d67607d..3c6a106 100644 --- a/WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs +++ b/WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs @@ -306,3 +306,166 @@ module TestJsonSerde = for i in counts do i |> shouldBeGreaterThan 0 + + let dict<'a, 'b when 'a : equality> (xs : ('a * 'b) seq) : Dictionary<'a, 'b> = + let result = Dictionary () + + for k, v in xs do + result.Add (k, v) + + result + + let inline makeJsonArr< ^t, ^u when ^u : (static member op_Implicit : ^t -> JsonNode) and ^u :> JsonNode> + (arr : ^t seq) + : JsonNode + = + let result = JsonArray () + + for a in arr do + result.Add a + + result :> JsonNode + + let normalise (d : Dictionary<'a, 'b>) : ('a * 'b) list = + d |> Seq.map (fun (KeyValue (a, b)) -> a, b) |> Seq.toList |> List.sortBy fst + + [] + let ``Can collect extension data`` () = + let str = + """{ + "message": { "header": "hi", "value": "bye" }, + "something": 3, + "arr": ["egg", "toast"], + "str": "whatnot" +}""" + |> JsonNode.Parse + + let expected = + { + Rest = + [ + "something", JsonNode.op_Implicit 3 + "arr", makeJsonArr [| "egg" ; "toast" |] + "str", JsonNode.op_Implicit "whatnot" + ] + |> dict + Message = + Some + { + Header = "hi" + Value = "bye" + } + } + + let actual = CollectRemaining.jsonParse str + + actual.Message |> shouldEqual expected.Message + + normalise actual.Rest + |> List.map (fun (k, v) -> k, v.ToJsonString ()) + |> shouldEqual (normalise expected.Rest |> List.map (fun (k, v) -> k, v.ToJsonString ())) + + [] + let ``Can write out extension data`` () = + let expected = + """{"message":{"header":"hi","value":"bye"},"something":3,"arr":["egg","toast"],"str":"whatnot"}""" + + let toWrite = + { + Rest = + [ + "something", JsonNode.op_Implicit 3 + "arr", makeJsonArr [| "egg" ; "toast" |] + "str", JsonNode.op_Implicit "whatnot" + ] + |> dict + Message = + Some + { + Header = "hi" + Value = "bye" + } + } + + let actual = CollectRemaining.toJsonNode toWrite |> fun s -> s.ToJsonString () + + actual |> shouldEqual expected + + [] + let ``Can collect extension data, nested`` () = + let str = + """{ + "thing": 99, + "baz": -123, + "remaining": { + "message": { "header": "hi", "value": "bye" }, + "something": 3, + "arr": ["egg", "toast"], + "str": "whatnot" + } +}""" + |> JsonNode.Parse + + let expected : OuterCollectRemaining = + { + Remaining = + { + Message = + Some + { + Header = "hi" + Value = "bye" + } + Rest = + [ + "something", JsonNode.op_Implicit 3 + "arr", makeJsonArr [| "egg" ; "toast" |] + "str", JsonNode.op_Implicit "whatnot" + ] + |> dict + } + Others = [ "thing", 99 ; "baz", -123 ] |> dict + } + + let actual = OuterCollectRemaining.jsonParse str + + normalise actual.Others |> shouldEqual (normalise expected.Others) + + let actual = actual.Remaining + let expected = expected.Remaining + + actual.Message |> shouldEqual expected.Message + + normalise actual.Rest + |> List.map (fun (k, v) -> k, v.ToJsonString ()) + |> shouldEqual (normalise expected.Rest |> List.map (fun (k, v) -> k, v.ToJsonString ())) + + [] + let ``Can write out extension data, nested`` () = + let expected = + """{"thing":99,"baz":-123,"remaining":{"message":{"header":"hi","value":"bye"},"something":3,"arr":["egg","toast"],"str":"whatnot"}}""" + + let toWrite : OuterCollectRemaining = + { + Others = [ "thing", 99 ; "baz", -123 ] |> dict + Remaining = + { + Rest = + [ + "something", JsonNode.op_Implicit 3 + "arr", makeJsonArr [| "egg" ; "toast" |] + "str", JsonNode.op_Implicit "whatnot" + ] + |> dict + Message = + Some + { + Header = "hi" + Value = "bye" + } + } + } + + let actual = OuterCollectRemaining.toJsonNode toWrite |> fun s -> s.ToJsonString () + + actual |> shouldEqual expected diff --git a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs index 05e0bd2..764eab7 100644 --- a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs @@ -59,7 +59,7 @@ module internal JsonParseGenerator = | None -> node | Some propertyName -> assertNotNull propertyName node |> SynExpr.callMethod "AsValue" - |> SynExpr.callGenericMethod "GetValue" typeName + |> SynExpr.callGenericMethod (SynLongIdent.createS "GetValue") [ SynType.createLongIdent typeName ] /// {node}.AsObject() /// If `propertyName` is Some, uses `assertNotNull {node}` instead of `{node}`. @@ -279,6 +279,7 @@ module internal JsonParseGenerator = | Measure (_measure, primType) -> parseNumberType options propertyName node primType |> SynExpr.pipeThroughFunction (Measure.getLanguagePrimitivesMeasure primType) + | JsonNode -> node | _ -> // Let's just hope that we've also got our own type annotation! let typeName = @@ -375,9 +376,9 @@ module internal JsonParseGenerator = ) let createRecordMaker (spec : JsonParseOutputSpec) (fields : SynFieldData list) = - let assignments = + let propertyFields = fields - |> List.mapi (fun i fieldData -> + |> List.map (fun fieldData -> let propertyNameAttr = fieldData.Attrs |> List.tryFind (fun attr -> @@ -385,7 +386,12 @@ module internal JsonParseGenerator = .EndsWith ("JsonPropertyName", StringComparison.Ordinal) ) - let options = getParseOptions fieldData.Attrs + let extensionDataAttr = + fieldData.Attrs + |> List.tryFind (fun attr -> + (SynLongIdent.toString attr.TypeName) + .EndsWith ("JsonExtensionData", StringComparison.Ordinal) + ) let propertyName = match propertyNameAttr with @@ -401,8 +407,77 @@ module internal JsonParseGenerator = sb.ToString () |> SynExpr.CreateConst | Some name -> name.ArgExpr + propertyName, extensionDataAttr + ) + + let namedPropertyFields = + propertyFields + |> List.choose (fun (name, extension) -> + match extension with + | Some _ -> None + | None -> Some name + ) + + let isNamedPropertyField = + match namedPropertyFields with + | [] -> SynExpr.CreateConst false + | _ -> + namedPropertyFields + |> List.map (fun fieldName -> SynExpr.equals (SynExpr.createIdent "key") fieldName) + |> List.reduce SynExpr.booleanOr + + let assignments = + List.zip fields propertyFields + |> List.mapi (fun i (fieldData, (propertyName, extensionDataAttr)) -> + let options = getParseOptions fieldData.Attrs + + let accIdent = Ident.create $"arg_%i{i}" + + match extensionDataAttr with + | Some _ -> + // Can't go through the usual parse logic here, because that will try and identify the node that's + // been labelled. The whole point of JsonExtensionData is that there is no such node! + let valType = + match fieldData.Type with + | DictionaryType (String, v) -> v + | _ -> failwith "Expected JsonExtensionData to be Dictionary" + + SynExpr.ifThenElse + isNamedPropertyField + (SynExpr.callMethodArg + "Add" + (SynExpr.tuple + [ + SynExpr.createIdent "key" + createParseRhs options (SynExpr.createIdent "key") valType + ]) + (SynExpr.createIdent "result")) + (SynExpr.CreateConst ()) + |> SynExpr.createForEach + (SynPat.nameWithArgs "KeyValue" [ SynPat.named "key" ; SynPat.named "value" ]) + (SynExpr.createIdent "node") + |> fun forEach -> [ forEach ; SynExpr.createIdent "result" ] + |> SynExpr.sequential + |> SynExpr.createLet + [ + SynBinding.basic + [ Ident.create "result" ] + [] + (SynExpr.typeApp + [ SynType.string ; valType ] + (SynExpr.createLongIdent [ "System" ; "Collections" ; "Generic" ; "Dictionary" ]) + |> SynExpr.applyTo (SynExpr.CreateConst ())) + + SynBinding.basic + [ Ident.create "node" ] + [] + (SynExpr.createIdent "node" |> SynExpr.callMethod "AsObject") + ] + |> SynBinding.basic [ accIdent ] [] + | None -> + createParseRhs options propertyName fieldData.Type - |> SynBinding.basic [ Ident.create $"arg_%i{i}" ] [] + |> SynBinding.basic [ accIdent ] [] ) let finalConstruction = @@ -483,9 +558,7 @@ module internal JsonParseGenerator = |> SynExpr.index property |> assertNotNull property |> SynExpr.pipeThroughFunction ( - SynExpr.createLambda - "v" - (SynExpr.callGenericMethod "GetValue" [ Ident.create "string" ] (SynExpr.createIdent "v")) + SynExpr.createLambda "v" (SynExpr.callGenericMethod' "GetValue" "string" (SynExpr.createIdent "v")) ) |> SynBinding.basic [ Ident.create "ty" ] [] ] diff --git a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs index f47b833..a9181f9 100644 --- a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs @@ -146,6 +146,7 @@ module internal JsonSerializeGenerator = ] |> SynExpr.createLambda "field" |> fun e -> e, false + | JsonNode -> SynExpr.createIdent "id", true | _ -> // {type}.toJsonNode let typeName = @@ -187,6 +188,14 @@ module internal JsonSerializeGenerator = sb.ToString () |> SynExpr.CreateConst | Some name -> name.ArgExpr + let getIsJsonExtension (attrs : SynAttribute list) : bool = + attrs + |> List.tryFind (fun attr -> + (SynLongIdent.toString attr.TypeName) + .EndsWith ("JsonExtensionData", StringComparison.Ordinal) + ) + |> Option.isSome + /// `populateNode` will be inserted before we return the `node` variable. /// /// That is, we give you access to a `JsonObject` called `node`, @@ -256,7 +265,31 @@ module internal JsonSerializeGenerator = fields |> List.map (fun fieldData -> let propertyName = getPropertyName fieldData.Ident fieldData.Attrs - createSerializeRhsRecord propertyName fieldData.Ident fieldData.Type + let isJsonExtension = getIsJsonExtension fieldData.Attrs + + if isJsonExtension then + let valType = + match fieldData.Type with + | DictionaryType (String, v) -> v + | _ -> failwith "Expected JsonExtensionData to be a Dictionary" + + let serialise = fst (serializeNode valType) + + SynExpr.createIdent "node" + |> SynExpr.callMethodArg + "Add" + (SynExpr.tuple + [ + SynExpr.createIdent "key" + SynExpr.applyFunction serialise (SynExpr.createIdent "value") + ]) + |> SynExpr.createForEach + (SynPat.identWithArgs + [ Ident.create "KeyValue" ] + (SynArgPats.create [ SynPat.named "key" ; SynPat.named "value" ])) + (SynExpr.createLongIdent' [ Ident.create "input" ; fieldData.Ident ]) + else + createSerializeRhsRecord propertyName fieldData.Ident fieldData.Type ) |> SynExpr.sequential |> fun expr -> SynExpr.Do (expr, range0) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs b/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs index 98bbd84..d14141f 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs @@ -85,6 +85,11 @@ module internal SynExpr = SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.booleanAnd, a) |> applyTo b + /// {a} || {b} + let booleanOr (a : SynExpr) (b : SynExpr) = + SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.booleanOr, a) + |> applyTo b + /// {a} + {b} let plus (a : SynExpr) (b : SynExpr) = SynExpr.CreateAppInfix ( @@ -136,16 +141,15 @@ module internal SynExpr = 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.DotGet (obj, range0, SynLongIdent.createS meth, range0) - |> typeApp [ SynType.LongIdent (SynLongIdent.create ty) ] + /// {obj}.{meth}() + let callGenericMethod (meth : SynLongIdent) (types : SynType list) (obj : SynExpr) : SynExpr = + SynExpr.DotGet (obj, range0, meth, range0) + |> typeApp types |> applyTo (SynExpr.CreateConst ()) /// {obj}.{meth}() let callGenericMethod' (meth : string) (ty : string) (obj : SynExpr) : SynExpr = - SynExpr.DotGet (obj, range0, SynLongIdent.createS meth, range0) - |> typeApp [ SynType.createLongIdent' [ ty ] ] - |> applyTo (SynExpr.CreateConst ()) + callGenericMethod (SynLongIdent.createS meth) [ SynType.createLongIdent' [ ty ] ] obj let inline index (property : SynExpr) (obj : SynExpr) : SynExpr = SynExpr.DotIndexedGet (obj, property, range0, range0) @@ -237,6 +241,8 @@ module internal SynExpr = let inline createLet (bindings : SynBinding list) (body : SynExpr) : SynExpr = SynExpr.LetOrUse (false, false, bindings, body, range0, SynExprLetOrUseTrivia.empty) + let inline createDo (body : SynExpr) : SynExpr = SynExpr.Do (body, range0) + let inline createMatch (matchOn : SynExpr) (cases : SynMatchClause list) : SynExpr = SynExpr.Match ( DebugPointAtBinding.Yes range0, diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynLongIdent.fs b/WoofWare.Myriad.Plugins/SynExpr/SynLongIdent.fs index 308af7d..39f1769 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynLongIdent.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynLongIdent.fs @@ -36,6 +36,9 @@ module internal SynLongIdent = let booleanAnd = SynLongIdent.SynLongIdent ([ Ident.create "op_BooleanAnd" ], [], [ Some (IdentTrivia.OriginalNotation "&&") ]) + let booleanOr = + SynLongIdent.SynLongIdent ([ Ident.create "op_BooleanOr" ], [], [ Some (IdentTrivia.OriginalNotation "||") ]) + let pipe = SynLongIdent.SynLongIdent ([ Ident.create "op_PipeRight" ], [], [ Some (IdentTrivia.OriginalNotation "|>") ]) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynType.fs b/WoofWare.Myriad.Plugins/SynExpr/SynType.fs index 8a6689b..fcef6b9 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynType.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynType.fs @@ -181,6 +181,18 @@ module internal SynTypePatterns = _) -> Some (ident, outer) | _ -> None + let (|JsonNode|_|) (fieldType : SynType) : unit option = + match fieldType with + | SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) -> + match ident |> List.map (fun i -> i.idText) with + | [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ] + | [ "Text" ; "Json" ; "Nodes" ; "JsonNode" ] + | [ "Json" ; "Nodes" ; "JsonNode" ] + | [ "Nodes" ; "JsonNode" ] + | [ "JsonNode" ] -> Some () + | _ -> None + | _ -> None + let (|DateOnly|_|) (fieldType : SynType) = match fieldType with | SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->