JSON serialization (#69)

ConsumePlugin/ConsumePlugin.fsproj

@@ -35,6 +35,10 @@
     <Compile Include="GeneratedVault.fs">
       <MyriadFile>Vault.fs</MyriadFile>
     </Compile>
+    <Compile Include="SerializationAndDeserialization.fs" />
+    <Compile Include="GeneratedSerde.fs">
+      <MyriadFile>SerializationAndDeserialization.fs</MyriadFile>
+    </Compile>
   </ItemGroup>
 
   <ItemGroup>

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
 [<AutoOpen>]
 module ToGetExtensionMethodJsonParseExtension =
-    ///Extension methods for JSON parsing
+    /// Extension methods for JSON parsing
     type ToGetExtensionMethod with
 
         /// Parse from a JSON node.

ConsumePlugin/GeneratedPureGymDto.fs

@@ -4,6 +4,7 @@
 //------------------------------------------------------------------------------
 
 
+
 namespace PureGym
 
 /// Module containing JSON parsing methods for the GymOpeningHours type

ConsumePlugin/GeneratedRestClient.fs

@@ -5,6 +5,7 @@
 
 
 
+
 namespace PureGym
 
 open System

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
+[<AutoOpen>]
+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<string> 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<Uri> 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<char> 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<bool> 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
+[<AutoOpen>]
+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<int> input.A)
+                node.Add ("b", System.Text.Json.Nodes.JsonValue.Create<string> 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<int> 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<string> 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<int> mem)
+
+                        arr
+                    )
+                        input.F
+                )
+
+            node :> _
+
+namespace ConsumePlugin
+
+/// Module containing JSON parsing extension members for the InnerTypeWithBoth type
+[<AutoOpen>]
+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<bool> ()
+                    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<char> ())
+                        |> 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<string> () |> 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<string> ()
+
+            {
+                Thing = Thing
+                Map = Map
+                ReadOnlyDict = ReadOnlyDict
+                Dict = Dict
+                ConcreteDict = ConcreteDict
+            }
+namespace ConsumePlugin
+
+/// Module containing JSON parsing extension members for the JsonRecordTypeWithBoth type
+[<AutoOpen>]
+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<int> ())
+                |> 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<string> ())
+                |> 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<int> ())
+                |> 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<string> ()
+
+            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<int> ()
+
+            {
+                A = A
+                B = B
+                C = C
+                D = D
+                E = E
+                F = F
+            }

ConsumePlugin/GeneratedVault.fs

@@ -4,6 +4,7 @@
 //------------------------------------------------------------------------------
 
 
+
 namespace ConsumePlugin
 
 /// Module containing JSON parsing methods for the JwtVaultAuthResponse type

ConsumePlugin/SerializationAndDeserialization.fs

@@ -0,0 +1,29 @@
+namespace ConsumePlugin
+
+open System
+open System.Collections.Generic
+open System.Text.Json.Serialization
+
+[<WoofWare.Myriad.Plugins.JsonParse true>]
+[<WoofWare.Myriad.Plugins.JsonSerialize true>]
+type InnerTypeWithBoth =
+    {
+        [<JsonPropertyName("it's-a-me")>]
+        Thing : string
+        Map : Map<string, Uri>
+        ReadOnlyDict : IReadOnlyDictionary<string, char list>
+        Dict : IDictionary<Uri, bool>
+        ConcreteDict : Dictionary<string, InnerTypeWithBoth>
+    }
+
+[<WoofWare.Myriad.Plugins.JsonParse true>]
+[<WoofWare.Myriad.Plugins.JsonSerialize true>]
+type JsonRecordTypeWithBoth =
+    {
+        A : int
+        B : string
+        C : int list
+        D : InnerTypeWithBoth
+        E : string array
+        F : int[]
+    }

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
+[<WoofWare.Myriad.Plugins.JsonSerialize true>]
+type InnerTypeWithBoth =
+    {
+        [<JsonPropertyName("it's-a-me")>]
+        Thing : string
+        ReadOnlyDict : IReadOnlyDictionary<string, Uri list>
+    }
+```
+
+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<string> 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<Uri> 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
     <PropertyGroup>
-      <WoofWareMyriadPluginVersion>1.1.5</WoofWareMyriadPluginVersion>
+      <WoofWareMyriadPluginVersion>1.3.5</WoofWareMyriadPluginVersion>
     </PropertyGroup>
     ```
 * Take a reference on `WoofWare.Myriad.Plugins`:

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
+
+[<TestFixture>]
+module TestJsonSerde =
+
+    let uriGen : Gen<Uri> =
+        gen {
+            let! suffix = Arb.generate<int>
+            return Uri $"https://example.com/%i{suffix}"
+        }
+
+    let rec innerGen (count : int) : Gen<InnerTypeWithBoth> =
+        gen {
+            let! s = Arb.generate<NonNull<string>>
+            let! mapKeys = Gen.listOf Arb.generate<NonNull<string>>
+            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<NonNull<string>>
+                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<NonNull<string>>
+            let readOnlyDictKeys = readOnlyDictKeys |> List.map _.Get |> List.distinct
+            let! readOnlyDictValues = Gen.listOfLength readOnlyDictKeys.Length (Gen.listOf Arb.generate<char>)
+            let readOnlyDict = List.zip readOnlyDictKeys readOnlyDictValues |> readOnlyDict
+
+            let! dictKeys = Gen.listOf uriGen
+            let! dictValues = Gen.listOfLength dictKeys.Length Arb.generate<bool>
+            let dict = List.zip dictKeys dictValues |> dict
+
+            return
+                {
+                    Thing = s.Get
+                    Map = map
+                    ReadOnlyDict = readOnlyDict
+                    Dict = dict
+                    ConcreteDict = concreteDict
+                }
+        }
+
+    let outerGen : Gen<JsonRecordTypeWithBoth> =
+        gen {
+            let! a = Arb.generate<int>
+            let! b = Arb.generate<NonNull<string>>
+            let! c = Gen.listOf Arb.generate<int>
+            let! depth = Gen.choose (0, 2)
+            let! d = innerGen depth
+            let! e = Gen.arrayOf Arb.generate<NonNull<string>>
+            let! f = Gen.arrayOf Arb.generate<int>
+
+            return
+                {
+                    A = a
+                    B = b.Get
+                    C = c
+                    D = d
+                    E = e |> Array.map _.Get
+                    F = f
+                }
+        }
+
+    [<Test>]
+    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

WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj

@@ -40,4 +40,8 @@
     <ProjectReference Include="..\ConsumePlugin\ConsumePlugin.fsproj"/>
   </ItemGroup>
 
+  <ItemGroup>
+    <Compile Include="TestJsonSerialize\TestJsonSerde.fs" />
+  </ItemGroup>
+
 </Project>

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
 

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 [<JsonParseAttribute>]. 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 =
                                 {

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
+    }
+
+[<RequireQualifiedAccess>]
+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 [<Literal>] 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.
+[<MyriadGenerator("json-serialize")>]
+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<JsonSerializeAttribute> 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

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

WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj

@@ -29,6 +29,7 @@
     <Compile Include="SynAttribute.fs"/>
     <Compile Include="RemoveOptionsGenerator.fs"/>
     <Compile Include="InterfaceMockGenerator.fs" />
+    <Compile Include="JsonSerializeGenerator.fs" />
     <Compile Include="JsonParseGenerator.fs"/>
     <Compile Include="HttpClientGenerator.fs"/>
     <EmbeddedResource Include="version.json"/>

WoofWare.Myriad.Plugins/version.json

@@ -1,5 +1,5 @@
 {
-  "version": "1.3",
+  "version": "1.4",
   "publicReleaseRefSpec": [
     "^refs/heads/main$"
   ],