From aafee9495a6ec3b222bc43bfdb9bd12911097510 Mon Sep 17 00:00:00 2001
From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com>
Date: Fri, 26 Jan 2024 10:53:08 +0000
Subject: [PATCH] JSON serialization (#69)
---
ConsumePlugin/ConsumePlugin.fsproj | 4 +
ConsumePlugin/GeneratedJson.fs | 3 +-
ConsumePlugin/GeneratedPureGymDto.fs | 1 +
ConsumePlugin/GeneratedRestClient.fs | 1 +
ConsumePlugin/GeneratedSerde.fs | 348 ++++++++++++
ConsumePlugin/GeneratedVault.fs | 1 +
.../SerializationAndDeserialization.fs | 29 +
README.md | 59 +-
.../TestJsonSerialize/TestJsonSerde.fs | 103 ++++
.../WoofWare.Myriad.Plugins.Test.fsproj | 4 +
WoofWare.Myriad.Plugins/AstHelper.fs | 4 +-
WoofWare.Myriad.Plugins/JsonParseGenerator.fs | 4 +-
.../JsonSerializeGenerator.fs | 534 ++++++++++++++++++
WoofWare.Myriad.Plugins/SurfaceBaseline.txt | 5 +
.../WoofWare.Myriad.Plugins.fsproj | 1 +
WoofWare.Myriad.Plugins/version.json | 2 +-
16 files changed, 1097 insertions(+), 6 deletions(-)
create mode 100644 ConsumePlugin/GeneratedSerde.fs
create mode 100644 ConsumePlugin/SerializationAndDeserialization.fs
create mode 100644 WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs
create mode 100644 WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs
diff --git a/ConsumePlugin/ConsumePlugin.fsproj b/ConsumePlugin/ConsumePlugin.fsproj
index 7278c06..393377b 100644
--- a/ConsumePlugin/ConsumePlugin.fsproj
+++ b/ConsumePlugin/ConsumePlugin.fsproj
@@ -35,6 +35,10 @@
Vault.fs
+
+
+ SerializationAndDeserialization.fs
+
diff --git a/ConsumePlugin/GeneratedJson.fs b/ConsumePlugin/GeneratedJson.fs
index ca0132d..58b15a3 100644
--- a/ConsumePlugin/GeneratedJson.fs
+++ b/ConsumePlugin/GeneratedJson.fs
@@ -4,6 +4,7 @@
//------------------------------------------------------------------------------
+
namespace ConsumePlugin
/// Module containing JSON parsing methods for the InnerType type
@@ -123,7 +124,7 @@ namespace ConsumePlugin
/// Module containing JSON parsing extension members for the ToGetExtensionMethod type
[]
module ToGetExtensionMethodJsonParseExtension =
- ///Extension methods for JSON parsing
+ /// Extension methods for JSON parsing
type ToGetExtensionMethod with
/// Parse from a JSON node.
diff --git a/ConsumePlugin/GeneratedPureGymDto.fs b/ConsumePlugin/GeneratedPureGymDto.fs
index 8436efe..e8f119f 100644
--- a/ConsumePlugin/GeneratedPureGymDto.fs
+++ b/ConsumePlugin/GeneratedPureGymDto.fs
@@ -4,6 +4,7 @@
//------------------------------------------------------------------------------
+
namespace PureGym
/// Module containing JSON parsing methods for the GymOpeningHours type
diff --git a/ConsumePlugin/GeneratedRestClient.fs b/ConsumePlugin/GeneratedRestClient.fs
index 39efb85..a089fc3 100644
--- a/ConsumePlugin/GeneratedRestClient.fs
+++ b/ConsumePlugin/GeneratedRestClient.fs
@@ -5,6 +5,7 @@
+
namespace PureGym
open System
diff --git a/ConsumePlugin/GeneratedSerde.fs b/ConsumePlugin/GeneratedSerde.fs
new file mode 100644
index 0000000..32f09e5
--- /dev/null
+++ b/ConsumePlugin/GeneratedSerde.fs
@@ -0,0 +1,348 @@
+//------------------------------------------------------------------------------
+// This code was generated by myriad.
+// Changes to this file will be lost when the code is regenerated.
+//------------------------------------------------------------------------------
+
+
+namespace ConsumePlugin
+
+open System
+open System.Collections.Generic
+open System.Text.Json.Serialization
+
+/// Module containing JSON serializing extension members for the InnerTypeWithBoth type
+[]
+module InnerTypeWithBothJsonSerializeExtension =
+ /// Extension methods for JSON parsing
+ type InnerTypeWithBoth with
+
+ /// Serialize to a JSON node
+ static member toJsonNode (input : InnerTypeWithBoth) : System.Text.Json.Nodes.JsonNode =
+ let node = System.Text.Json.Nodes.JsonObject ()
+
+ do
+ node.Add (("it's-a-me"), System.Text.Json.Nodes.JsonValue.Create input.Thing)
+
+ node.Add (
+ "map",
+ (fun field ->
+ let ret = System.Text.Json.Nodes.JsonObject ()
+
+ for (KeyValue (key, value)) in field do
+ ret.Add (key.ToString (), System.Text.Json.Nodes.JsonValue.Create value)
+
+ ret
+ )
+ input.Map
+ )
+
+ node.Add (
+ "readOnlyDict",
+ (fun field ->
+ let ret = System.Text.Json.Nodes.JsonObject ()
+
+ for (KeyValue (key, value)) in field do
+ ret.Add (
+ key.ToString (),
+ (fun field ->
+ let arr = System.Text.Json.Nodes.JsonArray ()
+
+ for mem in field do
+ arr.Add (System.Text.Json.Nodes.JsonValue.Create mem)
+
+ arr
+ )
+ value
+ )
+
+ ret
+ )
+ input.ReadOnlyDict
+ )
+
+ node.Add (
+ "dict",
+ (fun field ->
+ let ret = System.Text.Json.Nodes.JsonObject ()
+
+ for (KeyValue (key, value)) in field do
+ ret.Add (key.ToString (), System.Text.Json.Nodes.JsonValue.Create value)
+
+ ret
+ )
+ input.Dict
+ )
+
+ node.Add (
+ "concreteDict",
+ (fun field ->
+ let ret = System.Text.Json.Nodes.JsonObject ()
+
+ for (KeyValue (key, value)) in field do
+ ret.Add (key.ToString (), InnerTypeWithBoth.toJsonNode value)
+
+ ret
+ )
+ input.ConcreteDict
+ )
+
+ node :> _
+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 =
+ /// Extension methods for JSON parsing
+ type JsonRecordTypeWithBoth with
+
+ /// Serialize to a JSON node
+ static member toJsonNode (input : JsonRecordTypeWithBoth) : System.Text.Json.Nodes.JsonNode =
+ let node = System.Text.Json.Nodes.JsonObject ()
+
+ do
+ node.Add ("a", System.Text.Json.Nodes.JsonValue.Create input.A)
+ node.Add ("b", System.Text.Json.Nodes.JsonValue.Create input.B)
+
+ node.Add (
+ "c",
+ (fun field ->
+ let arr = System.Text.Json.Nodes.JsonArray ()
+
+ for mem in field do
+ arr.Add (System.Text.Json.Nodes.JsonValue.Create mem)
+
+ arr
+ )
+ input.C
+ )
+
+ node.Add ("d", InnerTypeWithBoth.toJsonNode input.D)
+
+ node.Add (
+ "e",
+ (fun field ->
+ let arr = System.Text.Json.Nodes.JsonArray ()
+
+ for mem in field do
+ arr.Add (System.Text.Json.Nodes.JsonValue.Create mem)
+
+ arr
+ )
+ input.E
+ )
+
+ node.Add (
+ "f",
+ (fun field ->
+ let arr = System.Text.Json.Nodes.JsonArray ()
+
+ for mem in field do
+ arr.Add (System.Text.Json.Nodes.JsonValue.Create mem)
+
+ arr
+ )
+ input.F
+ )
+
+ node :> _
+
+namespace ConsumePlugin
+
+/// Module containing JSON parsing extension members for the InnerTypeWithBoth type
+[]
+module InnerTypeWithBothJsonParseExtension =
+ /// Extension methods for JSON parsing
+ type InnerTypeWithBoth with
+
+ /// Parse from a JSON node.
+ static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : InnerTypeWithBoth =
+ let ConcreteDict =
+ (match node.["concreteDict"] with
+ | null ->
+ raise (
+ System.Collections.Generic.KeyNotFoundException (
+ sprintf "Required key '%s' not found on JSON object" ("concreteDict")
+ )
+ )
+ | v -> v)
+ .AsObject ()
+ |> Seq.map (fun kvp ->
+ let key = (kvp.Key)
+ let value = InnerTypeWithBoth.jsonParse (kvp.Value)
+ key, value
+ )
+ |> Seq.map System.Collections.Generic.KeyValuePair
+ |> System.Collections.Generic.Dictionary
+
+ let Dict =
+ (match node.["dict"] with
+ | null ->
+ raise (
+ System.Collections.Generic.KeyNotFoundException (
+ sprintf "Required key '%s' not found on JSON object" ("dict")
+ )
+ )
+ | v -> v)
+ .AsObject ()
+ |> Seq.map (fun kvp ->
+ let key = (kvp.Key) |> System.Uri
+ let value = (kvp.Value).AsValue().GetValue ()
+ key, value
+ )
+ |> dict
+
+ let ReadOnlyDict =
+ (match node.["readOnlyDict"] with
+ | null ->
+ raise (
+ System.Collections.Generic.KeyNotFoundException (
+ sprintf "Required key '%s' not found on JSON object" ("readOnlyDict")
+ )
+ )
+ | v -> v)
+ .AsObject ()
+ |> Seq.map (fun kvp ->
+ let key = (kvp.Key)
+
+ let value =
+ (kvp.Value).AsArray ()
+ |> Seq.map (fun elt -> elt.AsValue().GetValue ())
+ |> List.ofSeq
+
+ key, value
+ )
+ |> readOnlyDict
+
+ let Map =
+ (match node.["map"] with
+ | null ->
+ raise (
+ System.Collections.Generic.KeyNotFoundException (
+ sprintf "Required key '%s' not found on JSON object" ("map")
+ )
+ )
+ | v -> v)
+ .AsObject ()
+ |> Seq.map (fun kvp ->
+ let key = (kvp.Key)
+ let value = (kvp.Value).AsValue().GetValue () |> System.Uri
+ key, value
+ )
+ |> Map.ofSeq
+
+ let Thing =
+ (match node.[("it's-a-me")] with
+ | null ->
+ raise (
+ System.Collections.Generic.KeyNotFoundException (
+ sprintf "Required key '%s' not found on JSON object" (("it's-a-me"))
+ )
+ )
+ | v -> v)
+ .AsValue()
+ .GetValue ()
+
+ {
+ Thing = Thing
+ Map = Map
+ ReadOnlyDict = ReadOnlyDict
+ Dict = Dict
+ ConcreteDict = ConcreteDict
+ }
+namespace ConsumePlugin
+
+/// Module containing JSON parsing extension members for the JsonRecordTypeWithBoth type
+[]
+module JsonRecordTypeWithBothJsonParseExtension =
+ /// Extension methods for JSON parsing
+ type JsonRecordTypeWithBoth with
+
+ /// Parse from a JSON node.
+ static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : JsonRecordTypeWithBoth =
+ let F =
+ (match node.["f"] with
+ | null ->
+ raise (
+ System.Collections.Generic.KeyNotFoundException (
+ sprintf "Required key '%s' not found on JSON object" ("f")
+ )
+ )
+ | v -> v)
+ .AsArray ()
+ |> Seq.map (fun elt -> elt.AsValue().GetValue ())
+ |> Array.ofSeq
+
+ let E =
+ (match node.["e"] with
+ | null ->
+ raise (
+ System.Collections.Generic.KeyNotFoundException (
+ sprintf "Required key '%s' not found on JSON object" ("e")
+ )
+ )
+ | v -> v)
+ .AsArray ()
+ |> Seq.map (fun elt -> elt.AsValue().GetValue ())
+ |> Array.ofSeq
+
+ let D =
+ InnerTypeWithBoth.jsonParse (
+ match node.["d"] with
+ | null ->
+ raise (
+ System.Collections.Generic.KeyNotFoundException (
+ sprintf "Required key '%s' not found on JSON object" ("d")
+ )
+ )
+ | v -> v
+ )
+
+ let C =
+ (match node.["c"] with
+ | null ->
+ raise (
+ System.Collections.Generic.KeyNotFoundException (
+ sprintf "Required key '%s' not found on JSON object" ("c")
+ )
+ )
+ | v -> v)
+ .AsArray ()
+ |> Seq.map (fun elt -> elt.AsValue().GetValue ())
+ |> List.ofSeq
+
+ let B =
+ (match node.["b"] with
+ | null ->
+ raise (
+ System.Collections.Generic.KeyNotFoundException (
+ sprintf "Required key '%s' not found on JSON object" ("b")
+ )
+ )
+ | v -> v)
+ .AsValue()
+ .GetValue ()
+
+ let A =
+ (match node.["a"] with
+ | null ->
+ raise (
+ System.Collections.Generic.KeyNotFoundException (
+ sprintf "Required key '%s' not found on JSON object" ("a")
+ )
+ )
+ | v -> v)
+ .AsValue()
+ .GetValue ()
+
+ {
+ A = A
+ B = B
+ C = C
+ D = D
+ E = E
+ F = F
+ }
diff --git a/ConsumePlugin/GeneratedVault.fs b/ConsumePlugin/GeneratedVault.fs
index cace90a..30d27e0 100644
--- a/ConsumePlugin/GeneratedVault.fs
+++ b/ConsumePlugin/GeneratedVault.fs
@@ -4,6 +4,7 @@
//------------------------------------------------------------------------------
+
namespace ConsumePlugin
/// Module containing JSON parsing methods for the JwtVaultAuthResponse type
diff --git a/ConsumePlugin/SerializationAndDeserialization.fs b/ConsumePlugin/SerializationAndDeserialization.fs
new file mode 100644
index 0000000..a6fe562
--- /dev/null
+++ b/ConsumePlugin/SerializationAndDeserialization.fs
@@ -0,0 +1,29 @@
+namespace ConsumePlugin
+
+open System
+open System.Collections.Generic
+open System.Text.Json.Serialization
+
+[]
+[]
+type InnerTypeWithBoth =
+ {
+ []
+ Thing : string
+ Map : Map
+ ReadOnlyDict : IReadOnlyDictionary
+ Dict : IDictionary
+ ConcreteDict : Dictionary
+ }
+
+[]
+[]
+type JsonRecordTypeWithBoth =
+ {
+ A : int
+ B : string
+ C : int list
+ D : InnerTypeWithBoth
+ E : string array
+ F : int[]
+ }
diff --git a/README.md b/README.md
index 020c95b..6965258 100644
--- a/README.md
+++ b/README.md
@@ -11,9 +11,15 @@ Some helpers in [Myriad](https://github.com/MoiraeSoftware/myriad/) which might
These are currently somewhat experimental, and I personally am their primary customer.
The `RemoveOptions` generator in particular is extremely half-baked.
+If you would like to ensure that your particular use-case remains unbroken, please do contribute tests to this repository.
+The `ConsumePlugin` assembly contains a number of invocations of these source generators,
+so you just need to add copies of your types to that assembly to ensure that I will at least notice if I break the build;
+and if you add tests to `WoofWare.Myriad.Plugins.Test` then I will also notice if I break the runtime semantics of the generated code.
+
Currently implemented:
* `JsonParse` (to stamp out `jsonParse : JsonNode -> 'T` methods);
+* `JsonSerialize` (to stamp out `toJsonNode : 'T -> JsonNode` methods);
* `RemoveOptions` (to strip `option` modifiers from a type).
* `HttpClient` (to stamp out a [RestEase](https://github.com/canton7/RestEase)-style HTTP client).
* `GenerateMock` (to stamp out a record type corresponding to an interface).
@@ -74,6 +80,11 @@ module JsonRecordType =
{ A = A; B = B; C = C; D = D }
```
+You can optionally supply the boolean `true` to the attribute,
+which will cause Myriad to stamp out an extension method rather than a module with the same name as the type.
+This is useful if you want to reuse the type name as a module name yourself,
+or if you want to apply multiple source generators which each want to use the module name.
+
### What's the point?
`System.Text.Json`, in a `PublishAot` context, relies on C# source generators.
@@ -92,6 +103,52 @@ However, there is *far* more that could be done.
* Make it possible to reject parsing if extra fields are present.
* Generally support all the `System.Text.Json` attributes.
+For an example of using both `JsonParse` and `JsonSerialize` together with complex types, see [the type definitions](./ConsumePlugin/SerializationAndDeserialization.fs) and [tests](./WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs).
+
+## `JsonSerialize`
+
+Takes records like this:
+```fsharp
+[]
+type InnerTypeWithBoth =
+ {
+ []
+ Thing : string
+ ReadOnlyDict : IReadOnlyDictionary
+ }
+```
+
+and stamps out modules like this:
+```fsharp
+module InnerTypeWithBoth =
+ let toJsonNode (input : InnerTypeWithBoth) : System.Text.Json.Nodes.JsonNode =
+ let node = System.Text.Json.Nodes.JsonObject ()
+
+ do
+ node.Add (("it's-a-me"), System.Text.Json.Nodes.JsonValue.Create input.Thing)
+
+ node.Add (
+ "ReadOnlyDict",
+ (fun field ->
+ let ret = System.Text.Json.Nodes.JsonObject ()
+
+ for (KeyValue (key, value)) in field do
+ ret.Add (key.ToString (), System.Text.Json.Nodes.JsonValue.Create value)
+
+ ret
+ ) input.Map
+ )
+
+ node
+```
+
+As in `JsonParse`, you can optionally supply the boolean `true` to the attribute,
+which will cause Myriad to stamp out an extension method rather than a module with the same name as the type.
+
+The same limitations generally apply to `JsonSerialize` as do to `JsonParse`.
+
+For an example of using both `JsonParse` and `JsonSerialize` together with complex types, see [the type definitions](./ConsumePlugin/SerializationAndDeserialization.fs) and [tests](./WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs).
+
## `RemoveOptions`
Takes a record like this:
@@ -275,7 +332,7 @@ For example, [PureGymDto.fs](./ConsumePlugin/PureGymDto.fs) is a real-world set
* In your `.fsproj` file, define a helper variable so that subsequent steps don't all have to be kept in sync:
```xml
- 1.1.5
+ 1.3.5
```
* Take a reference on `WoofWare.Myriad.Plugins`:
diff --git a/WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs b/WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs
new file mode 100644
index 0000000..49431b4
--- /dev/null
+++ b/WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs
@@ -0,0 +1,103 @@
+namespace WoofWare.Myriad.Plugins.Test
+
+open System
+open System.Collections.Generic
+open System.Text.Json.Nodes
+open NUnit.Framework
+open FsCheck
+open FsUnitTyped
+open ConsumePlugin
+
+[]
+module TestJsonSerde =
+
+ let uriGen : Gen =
+ gen {
+ let! suffix = Arb.generate
+ return Uri $"https://example.com/%i{suffix}"
+ }
+
+ let rec innerGen (count : int) : Gen =
+ gen {
+ let! s = Arb.generate>
+ let! mapKeys = Gen.listOf Arb.generate>
+ let mapKeys = mapKeys |> List.map _.Get |> List.distinct
+ let! mapValues = Gen.listOfLength mapKeys.Length uriGen
+ let map = List.zip mapKeys mapValues |> Map.ofList
+
+ let! concreteDictKeys =
+ if count > 0 then
+ Gen.listOf Arb.generate>
+ else
+ Gen.constant []
+
+ let concreteDictKeys =
+ concreteDictKeys
+ |> List.map _.Get
+ |> List.distinct
+ |> fun x -> List.take (min 3 x.Length) x
+
+ let! concreteDictValues =
+ if count > 0 then
+ Gen.listOfLength concreteDictKeys.Length (innerGen (count - 1))
+ else
+ Gen.constant []
+
+ let concreteDict =
+ List.zip concreteDictKeys concreteDictValues
+ |> List.map KeyValuePair
+ |> Dictionary
+
+ let! readOnlyDictKeys = Gen.listOf Arb.generate>
+ let readOnlyDictKeys = readOnlyDictKeys |> List.map _.Get |> List.distinct
+ let! readOnlyDictValues = Gen.listOfLength readOnlyDictKeys.Length (Gen.listOf Arb.generate)
+ let readOnlyDict = List.zip readOnlyDictKeys readOnlyDictValues |> readOnlyDict
+
+ let! dictKeys = Gen.listOf uriGen
+ let! dictValues = Gen.listOfLength dictKeys.Length Arb.generate
+ let dict = List.zip dictKeys dictValues |> dict
+
+ return
+ {
+ Thing = s.Get
+ Map = map
+ ReadOnlyDict = readOnlyDict
+ Dict = dict
+ ConcreteDict = concreteDict
+ }
+ }
+
+ let outerGen : Gen =
+ gen {
+ let! a = Arb.generate
+ let! b = Arb.generate>
+ let! c = Gen.listOf Arb.generate
+ let! depth = Gen.choose (0, 2)
+ let! d = innerGen depth
+ let! e = Gen.arrayOf Arb.generate>
+ let! f = Gen.arrayOf Arb.generate
+
+ return
+ {
+ A = a
+ B = b.Get
+ C = c
+ D = d
+ E = e |> Array.map _.Get
+ F = f
+ }
+ }
+
+ []
+ let ``It just works`` () =
+ let property (o : JsonRecordTypeWithBoth) : bool =
+ o
+ |> JsonRecordTypeWithBoth.toJsonNode
+ |> fun s -> s.ToJsonString ()
+ |> JsonNode.Parse
+ |> JsonRecordTypeWithBoth.jsonParse
+ |> shouldEqual o
+
+ true
+
+ property |> Prop.forAll (Arb.fromGen outerGen) |> Check.QuickThrowOnFailure
diff --git a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj
index 0990990..46742e4 100644
--- a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj
+++ b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj
@@ -40,4 +40,8 @@
+
+
+
+
diff --git a/WoofWare.Myriad.Plugins/AstHelper.fs b/WoofWare.Myriad.Plugins/AstHelper.fs
index dedeb4b..4ac1c75 100644
--- a/WoofWare.Myriad.Plugins/AstHelper.fs
+++ b/WoofWare.Myriad.Plugins/AstHelper.fs
@@ -393,7 +393,9 @@ module internal SynTypePatterns =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
- | [ i ] -> [ "string" ; "float" ; "int" ; "bool" ] |> List.tryFind (fun s -> s = i.idText)
+ | [ i ] ->
+ [ "string" ; "float" ; "int" ; "bool" ; "char" ]
+ |> List.tryFind (fun s -> s = i.idText)
| _ -> None
| _ -> None
diff --git a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs
index 186cbe5..44b1624 100644
--- a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs
+++ b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs
@@ -533,7 +533,7 @@ module internal JsonParseGenerator =
let containingType =
SynTypeDefn.SynTypeDefn (
- SynComponentInfo.Create (typeName, xmldoc = PreXmlDoc.Create "Extension methods for JSON parsing"),
+ SynComponentInfo.Create (typeName, xmldoc = PreXmlDoc.Create " Extension methods for JSON parsing"),
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0),
[ mem ],
None,
@@ -644,7 +644,7 @@ type JsonParseGenerator () =
| SynExpr.Const (SynConst.Unit, _) -> JsonParseAttribute.DefaultIsExtensionMethod
| arg ->
failwith
- $"Unrecognised argument %+A{arg} to []. Literals are not supported. Use `true` or `false` (or unit) only."
+ $"Unrecognised argument %+A{arg} to [<%s{nameof JsonParseAttribute}>]. Literals are not supported. Use `true` or `false` (or unit) only."
let spec =
{
diff --git a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs
new file mode 100644
index 0000000..8782dd4
--- /dev/null
+++ b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs
@@ -0,0 +1,534 @@
+namespace WoofWare.Myriad.Plugins
+
+open System
+open System.Text
+open Fantomas.FCS.Syntax
+open Fantomas.FCS.SyntaxTrivia
+open Fantomas.FCS.Xml
+open Myriad.Core
+
+/// Attribute indicating a record type to which the "Add JSON serializer" Myriad
+/// generator should apply during build.
+/// The purpose of this generator is to create methods (possibly extension methods) of the form
+/// `{TypeName}.toJsonNode : {TypeName} -> System.Text.Json.Nodes.JsonNode`.
+///
+/// If you supply isExtensionMethod = true, you will get extension methods.
+/// These can only be consumed from F#, but the benefit is that they don't use up the module name
+/// (since by default we create a module called "{TypeName}").
+type JsonSerializeAttribute (isExtensionMethod : bool) =
+ inherit Attribute ()
+
+ /// If changing this, *adjust the documentation strings*
+ static member internal DefaultIsExtensionMethod = false
+
+ /// Shorthand for the "isExtensionMethod = false" constructor; see documentation there for details.
+ new () = JsonSerializeAttribute JsonSerializeAttribute.DefaultIsExtensionMethod
+
+type internal JsonSerializeOutputSpec =
+ {
+ ExtensionMethods : bool
+ }
+
+[]
+module internal JsonSerializeGenerator =
+ open Fantomas.FCS.Text.Range
+ open Myriad.Core.Ast
+
+ /// Given `input.Ident`, for example, choose how to add it to the ambient `node`.
+ /// The result is a line like `(fun ident -> InnerType.toJsonNode ident)` or `(fun ident -> JsonValue.Create ident)`.
+ let rec serializeNode (fieldType : SynType) : SynExpr =
+ // TODO: serialization format for DateTime etc
+ match fieldType with
+ | DateOnly
+ | DateTime
+ | NumberType _
+ | PrimitiveType _
+ | Uri ->
+ // JsonValue.Create<{type}>
+ SynExpr.TypeApp (
+ SynExpr.CreateLongIdent (
+ SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ]
+ ),
+ range0,
+ [ fieldType ],
+ [],
+ Some range0,
+ range0,
+ range0
+ )
+ | OptionType ty ->
+ // fun field -> match field with | None -> JsonValue.Create null | Some v -> {serializeNode ty} field
+ SynExpr.CreateMatch (
+ SynExpr.CreateIdentString "field",
+ [
+ SynMatchClause.Create (
+ SynPat.CreateLongIdent (SynLongIdent.CreateString "None", []),
+ None,
+ SynExpr.CreateApp (
+ SynExpr.CreateLongIdent (
+ SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ]
+ ),
+ SynExpr.CreateNull
+ )
+ )
+
+ SynMatchClause.Create (
+ SynPat.CreateLongIdent (
+ SynLongIdent.CreateString "Some",
+ [ SynPat.CreateNamed (Ident.Create "field") ]
+ ),
+ None,
+ SynExpr.CreateApp (serializeNode ty, SynExpr.CreateIdentString "field")
+ )
+ ]
+ )
+ |> SynExpr.createLambda "field"
+ | ArrayType ty
+ | ListType ty ->
+ // fun field ->
+ // let arr = JsonArray ()
+ // for mem in field do arr.Add ({serializeNode} mem)
+ // arr
+ SynExpr.LetOrUse (
+ false,
+ false,
+ [
+ SynBinding.Let (
+ pattern = SynPat.CreateNamed (Ident.Create "arr"),
+ expr =
+ SynExpr.CreateApp (
+ SynExpr.CreateLongIdent (
+ SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonArray" ]
+ ),
+ SynExpr.CreateConst SynConst.Unit
+ )
+ )
+ ],
+ SynExpr.CreateSequential
+ [
+ SynExpr.ForEach (
+ DebugPointAtFor.Yes range0,
+ DebugPointAtInOrTo.Yes range0,
+ SeqExprOnly.SeqExprOnly false,
+ true,
+ SynPat.CreateNamed (Ident.Create "mem"),
+ SynExpr.CreateIdent (Ident.Create "field"),
+ SynExpr.CreateApp (
+ SynExpr.CreateLongIdent (SynLongIdent.Create [ "arr" ; "Add" ]),
+ SynExpr.CreateParen (
+ SynExpr.CreateApp (serializeNode ty, SynExpr.CreateIdentString "mem")
+ )
+ ),
+ range0
+ )
+ SynExpr.CreateIdentString "arr"
+ ],
+ range0,
+ {
+ InKeyword = None
+ }
+ )
+ |> SynExpr.createLambda "field"
+ | IDictionaryType (keyType, valueType)
+ | DictionaryType (keyType, valueType)
+ | IReadOnlyDictionaryType (keyType, valueType)
+ | MapType (keyType, valueType) ->
+ // fun field ->
+ // let ret = JsonObject ()
+ // for (KeyValue(key, value)) in field do
+ // ret.Add (key.ToString (), {serializeNode} value)
+ // ret
+ SynExpr.LetOrUse (
+ false,
+ false,
+ [
+ SynBinding.Let (
+ pattern = SynPat.CreateNamed (Ident.Create "ret"),
+ expr =
+ SynExpr.CreateApp (
+ SynExpr.CreateLongIdent (
+ SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
+ ),
+ SynExpr.CreateConst SynConst.Unit
+ )
+ )
+ ],
+ SynExpr.CreateSequential
+ [
+ SynExpr.ForEach (
+ DebugPointAtFor.Yes range0,
+ DebugPointAtInOrTo.Yes range0,
+ SeqExprOnly.SeqExprOnly false,
+ true,
+ SynPat.CreateParen (
+ SynPat.CreateLongIdent (
+ SynLongIdent.CreateString "KeyValue",
+ [
+ SynPat.CreateParen (
+ SynPat.Tuple (
+ false,
+ [
+ SynPat.CreateNamed (Ident.Create "key")
+ SynPat.CreateNamed (Ident.Create "value")
+ ],
+ [ range0 ],
+ range0
+ )
+ )
+ ]
+ )
+ ),
+ SynExpr.CreateIdent (Ident.Create "field"),
+ SynExpr.CreateApp (
+ SynExpr.CreateLongIdent (SynLongIdent.Create [ "ret" ; "Add" ]),
+ SynExpr.CreateParenedTuple
+ [
+ SynExpr.CreateApp (
+ SynExpr.CreateLongIdent (SynLongIdent.Create [ "key" ; "ToString" ]),
+ SynExpr.CreateConst SynConst.Unit
+ )
+ SynExpr.CreateApp (serializeNode valueType, SynExpr.CreateIdentString "value")
+ ]
+ ),
+ range0
+ )
+ SynExpr.CreateIdentString "ret"
+ ],
+ range0,
+ {
+ InKeyword = None
+ }
+ )
+ |> SynExpr.createLambda "field"
+ | _ ->
+ // {type}.toJsonNode
+ let typeName =
+ match fieldType with
+ | SynType.LongIdent ident -> ident.LongIdent
+ | _ -> failwith $"Unrecognised type: %+A{fieldType}"
+
+ SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent (typeName @ [ Ident.Create "toJsonNode" ]))
+
+ /// propertyName is probably a string literal, but it could be a [] variable
+ /// `node.Add ({propertyName}, {toJsonNode})`
+ let createSerializeRhs (propertyName : SynExpr) (fieldId : Ident) (fieldType : SynType) : SynExpr =
+ let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ])
+
+ let args =
+ SynExpr.CreateParenedTuple
+ [
+ propertyName
+ SynExpr.CreateApp (
+ serializeNode fieldType,
+ SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ Ident.Create "input" ; fieldId ])
+ )
+ ]
+
+ SynExpr.CreateApp (func, args)
+
+ let createMaker (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (fields : SynField list) =
+ let xmlDoc = PreXmlDoc.Create " Serialize to a JSON node"
+
+ let returnInfo =
+ SynBindingReturnInfo.Create (
+ SynType.LongIdent (SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
+ )
+
+ let inputArg = Ident.Create "input"
+ let functionName = Ident.Create "toJsonNode"
+
+ let inputVal =
+ let memberFlags =
+ if spec.ExtensionMethods then
+ {
+ SynMemberFlags.IsInstance = false
+ SynMemberFlags.IsDispatchSlot = false
+ SynMemberFlags.IsOverrideOrExplicitImpl = false
+ SynMemberFlags.IsFinal = false
+ SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
+ SynMemberFlags.MemberKind = SynMemberKind.Member
+ }
+ |> Some
+ else
+ None
+
+ let thisIdOpt = if spec.ExtensionMethods then None else Some inputArg
+
+ SynValData.SynValData (
+ memberFlags,
+ SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty),
+ thisIdOpt
+ )
+
+ let assignments =
+ fields
+ |> List.map (fun (SynField (attrs, _, id, fieldType, _, _, _, _, _)) ->
+ let id =
+ match id with
+ | None -> failwith "didn't get an ID on field"
+ | Some id -> id
+
+ let attrs = attrs |> List.collect (fun l -> l.Attributes)
+
+ let propertyNameAttr =
+ attrs
+ |> List.tryFind (fun attr ->
+ attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal)
+ )
+
+ let propertyName =
+ match propertyNameAttr with
+ | None ->
+ let sb = StringBuilder id.idText.Length
+ sb.Append (Char.ToLowerInvariant id.idText.[0]) |> ignore
+
+ if id.idText.Length > 1 then
+ sb.Append id.idText.[1..] |> ignore
+
+ sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst
+ | Some name -> name.ArgExpr
+
+ let pattern =
+ SynPat.LongIdent (
+ SynLongIdent.CreateFromLongIdent [ id ],
+ None,
+ None,
+ SynArgPats.Empty,
+ None,
+ range0
+ )
+
+ createSerializeRhs propertyName id fieldType
+ )
+
+ let finalConstruction =
+ fields
+ |> List.map (fun (SynField (_, _, id, _, _, _, _, _, _)) ->
+ let id =
+ match id with
+ | None -> failwith "Expected record field to have an identifying name"
+ | Some id -> id
+
+ (SynLongIdent.CreateFromLongIdent [ id ], true),
+ Some (SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ id ]))
+ )
+ |> AstHelper.instantiateRecord
+
+ let assignments = assignments |> SynExpr.CreateSequential
+
+ let assignments =
+ SynExpr.LetOrUse (
+ false,
+ false,
+ [
+ SynBinding.Let (
+ pattern = SynPat.CreateNamed (Ident.Create "node"),
+ expr =
+ SynExpr.CreateApp (
+ SynExpr.CreateLongIdent (
+ SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
+ ),
+ SynExpr.CreateConst SynConst.Unit
+ )
+ )
+ ],
+ SynExpr.CreateSequential
+ [
+ SynExpr.Do (assignments, range0)
+ SynExpr.Upcast (SynExpr.CreateIdentString "node", SynType.Anon range0, range0)
+ ],
+ range0,
+ {
+ InKeyword = None
+ }
+ )
+
+ let pattern =
+ SynPat.LongIdent (
+ SynLongIdent.CreateFromLongIdent [ functionName ],
+ None,
+ None,
+ SynArgPats.Pats
+ [
+ SynPat.CreateTyped (
+ SynPat.CreateNamed inputArg,
+ SynType.LongIdent (SynLongIdent.CreateFromLongIdent typeName)
+ )
+ |> SynPat.CreateParen
+ ],
+ None,
+ range0
+ )
+
+ if spec.ExtensionMethods then
+ let binding =
+ SynBinding.SynBinding (
+ None,
+ SynBindingKind.Normal,
+ false,
+ false,
+ [],
+ xmlDoc,
+ inputVal,
+ pattern,
+ Some returnInfo,
+ assignments,
+ range0,
+ DebugPointAtBinding.NoneAtInvisible,
+ {
+ LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0)
+ InlineKeyword = None
+ EqualsRange = Some range0
+ }
+ )
+
+ let mem = SynMemberDefn.Member (binding, range0)
+
+ let containingType =
+ SynTypeDefn.SynTypeDefn (
+ SynComponentInfo.Create (typeName, xmldoc = PreXmlDoc.Create " Extension methods for JSON parsing"),
+ SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0),
+ [ mem ],
+ None,
+ range0,
+ {
+ LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
+ EqualsRange = None
+ WithKeyword = None
+ }
+ )
+
+ SynModuleDecl.Types ([ containingType ], range0)
+ else
+ let binding =
+ SynBinding.Let (
+ isInline = false,
+ isMutable = false,
+ xmldoc = xmlDoc,
+ returnInfo = returnInfo,
+ expr = assignments,
+ valData = inputVal,
+ pattern = pattern
+ )
+
+ SynModuleDecl.CreateLet [ binding ]
+
+ let createRecordModule
+ (namespaceId : LongIdent)
+ (opens : SynOpenDeclTarget list)
+ (spec : JsonSerializeOutputSpec)
+ (typeDefn : SynTypeDefn)
+ =
+ let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) =
+ typeDefn
+
+ let (SynComponentInfo (_attributes, _typeParams, _constraints, recordId, _, _preferPostfix, _access, _)) =
+ synComponentInfo
+
+ match synTypeDefnRepr with
+ | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _recordRange), _) ->
+
+ let decls = [ createMaker spec recordId recordFields ]
+
+ let attributes =
+ if spec.ExtensionMethods then
+ [ SynAttributeList.Create SynAttribute.autoOpen ]
+ else
+ [
+ SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ())
+ SynAttributeList.Create SynAttribute.compilationRepresentation
+ ]
+
+ let xmlDoc =
+ let fullyQualified = recordId |> Seq.map (fun i -> i.idText) |> String.concat "."
+
+ let description =
+ if spec.ExtensionMethods then
+ "extension members"
+ else
+ "methods"
+
+ $" Module containing JSON serializing %s{description} for the %s{fullyQualified} type"
+ |> PreXmlDoc.Create
+
+ let moduleName =
+ if spec.ExtensionMethods then
+ match recordId with
+ | [] -> failwith "unexpectedly got an empty identifier for record name"
+ | recordId ->
+ let expanded =
+ List.last recordId
+ |> fun i -> i.idText
+ |> fun s -> s + "JsonSerializeExtension"
+ |> Ident.Create
+
+ List.take (List.length recordId - 1) recordId @ [ expanded ]
+ else
+ recordId
+
+ let info =
+ SynComponentInfo.Create (moduleName, attributes = attributes, xmldoc = xmlDoc)
+
+ let mdl = SynModuleDecl.CreateNestedModule (info, decls)
+
+ SynModuleOrNamespace.CreateNamespace (
+ namespaceId,
+ decls = (opens |> List.map SynModuleDecl.CreateOpen) @ [ mdl ]
+ )
+ | _ -> failwithf "Not a record type"
+
+/// Myriad generator that provides a method (possibly an extension method) for a record type,
+/// containing a JSON serialization function.
+[]
+type JsonSerializeGenerator () =
+
+ interface IMyriadGenerator with
+ member _.ValidInputExtensions = [ ".fs" ]
+
+ member _.Generate (context : GeneratorContext) =
+ let ast, _ =
+ Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head
+
+ let records = Ast.extractRecords ast
+
+ let namespaceAndRecords =
+ records
+ |> List.choose (fun (ns, types) ->
+ types
+ |> List.choose (fun typeDef ->
+ match Ast.getAttribute typeDef with
+ | None -> None
+ | Some attr ->
+ let arg =
+ match SynExpr.stripOptionalParen attr.ArgExpr with
+ | SynExpr.Const (SynConst.Bool value, _) -> value
+ | SynExpr.Const (SynConst.Unit, _) -> JsonSerializeAttribute.DefaultIsExtensionMethod
+ | arg ->
+ failwith
+ $"Unrecognised argument %+A{arg} to [<%s{nameof JsonSerializeAttribute}>]. Literals are not supported. Use `true` or `false` (or unit) only."
+
+ let spec =
+ {
+ ExtensionMethods = arg
+ }
+
+ Some (typeDef, spec)
+ )
+ |> function
+ | [] -> None
+ | ty -> Some (ns, ty)
+ )
+
+ let opens = AstHelper.extractOpens ast
+
+ let modules =
+ namespaceAndRecords
+ |> List.collect (fun (ns, records) ->
+ records
+ |> List.map (fun (record, spec) ->
+ let recordModule = JsonSerializeGenerator.createRecordModule ns opens spec record
+ recordModule
+ )
+ )
+
+ Output.Ast modules
diff --git a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt
index 7491d1d..4c59f9d 100644
--- a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt
+++ b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt
@@ -11,6 +11,11 @@ WoofWare.Myriad.Plugins.JsonParseAttribute..ctor [constructor]: bool
WoofWare.Myriad.Plugins.JsonParseAttribute..ctor [constructor]: unit
WoofWare.Myriad.Plugins.JsonParseGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
WoofWare.Myriad.Plugins.JsonParseGenerator..ctor [constructor]: unit
+WoofWare.Myriad.Plugins.JsonSerializeAttribute inherit System.Attribute
+WoofWare.Myriad.Plugins.JsonSerializeAttribute..ctor [constructor]: bool
+WoofWare.Myriad.Plugins.JsonSerializeAttribute..ctor [constructor]: unit
+WoofWare.Myriad.Plugins.JsonSerializeGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
+WoofWare.Myriad.Plugins.JsonSerializeGenerator..ctor [constructor]: unit
WoofWare.Myriad.Plugins.RemoveOptionsAttribute inherit System.Attribute
WoofWare.Myriad.Plugins.RemoveOptionsAttribute..ctor [constructor]: unit
WoofWare.Myriad.Plugins.RemoveOptionsGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
diff --git a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj
index 5f0fa5b..6142f1a 100644
--- a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj
+++ b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj
@@ -29,6 +29,7 @@
+
diff --git a/WoofWare.Myriad.Plugins/version.json b/WoofWare.Myriad.Plugins/version.json
index dd79bd9..4e26454 100644
--- a/WoofWare.Myriad.Plugins/version.json
+++ b/WoofWare.Myriad.Plugins/version.json
@@ -1,5 +1,5 @@
{
- "version": "1.3",
+ "version": "1.4",
"publicReleaseRefSpec": [
"^refs/heads/main$"
],