Port UnionConverter to STJ re #43 (#59)

Author: bartelink

CHANGELOG.md

@@ -9,6 +9,9 @@ The `Unreleased` section name is replaced by the expected version of next releas
 ## [Unreleased]
 
 ### Added
+
+- `SystemTextJson.UnionConverter`: Port of `NewtonsoftJson` equivalent started in [#43](https://github.com/jet/FsCodec/pull/43) [#59](https://github.com/jet/FsCodec/pull/59) :pray: [@NickDarvey](https://github.com/NickDarvey) 
+
 ### Changed
 
 - `SystemTextJson`: Target `System.Text.Json` v `6.0.1`, `TypeShape` v `10.0.0` [#68](https://github.com/jet/FsCodec/pull/68)

README.md

@@ -23,10 +23,6 @@ The components within this repository are delivered as multi-targeted Nuget pack
 - [![System.Text.Json Codec NuGet](https://img.shields.io/nuget/v/FsCodec.SystemTextJson.svg)](https://www.nuget.org/packages/FsCodec.SystemTextJson/) `FsCodec.SystemTextJson`: See [#38](https://github.com/jet/FsCodec/pulls/38): drop in replacement that allows one to retarget from `Newtonsoft.Json` to the .NET Core >= v 3.0 default serializer: `System.Text.Json`, solely by changing the referenced namespace.
   - [depends](https://www.fuget.org/packages/FsCodec.SystemTextJson) on `FsCodec`, `System.Text.Json >= 6.0.1`, `TypeShape >= 10`
 
-  Deltas in behavior/functionality vs `FsCodec.NewtonsoftJson`:
-
-  1. [`UnionConverter` is WIP](https://github.com/jet/FsCodec/pull/43)
-
 # Features: `FsCodec`
 
 The purpose of the `FsCodec` package is to provide a minimal interface on which libraries such as Equinox and Propulsion can depend on in order that they can avoid forcing a specific serialization mechanism.

src/FsCodec.SystemTextJson/UnionConverter.fs

@@ -2,6 +2,33 @@
 
 open FSharp.Reflection
 open System
+open System.Reflection
+open System.Text.Json
+
+type IUnionConverterOptions =
+    abstract member Discriminator : string with get
+    abstract member CatchAllCase : string option with get
+
+/// Use this attribute in combination with a JsonConverter/UnionConverter attribute to specify
+/// your own name for a discriminator and/or a catch-all case for a specific discriminated union.
+/// If this attribute is set, its values take precedence over the values set on the converter via its constructor.
+/// Example: <c>[<JsonConverter(typeof<UnionConverter<T>>); JsonUnionConverterOptions("type")>]</c>
+[<AttributeUsage(AttributeTargets.Class ||| AttributeTargets.Struct, AllowMultiple = false, Inherited = false)>]
+type JsonUnionConverterOptionsAttribute(discriminator : string) =
+    inherit Attribute()
+        member val CatchAllCase : string = null with get, set
+    interface IUnionConverterOptions with
+        member _.Discriminator = discriminator
+        member x.CatchAllCase = Option.ofObj x.CatchAllCase
+
+type UnionConverterOptions =
+    {
+        discriminator : string
+        catchAllCase : string option
+    }
+    interface IUnionConverterOptions with
+        member x.Discriminator = x.discriminator
+        member x.CatchAllCase = x.catchAllCase
 
 [<NoComparison; NoEquality>]
 type private Union =
@@ -10,6 +37,7 @@ type private Union =
         tagReader : obj -> int
         fieldReader : (obj -> obj[])[]
         caseConstructor : (obj[] -> obj)[]
+        options : IUnionConverterOptions option
     }
 
 module private Union =
@@ -24,5 +52,99 @@ module private Union =
             tagReader = FSharpValue.PreComputeUnionTagReader(t, true)
             fieldReader = cases |> Array.map (fun c -> FSharpValue.PreComputeUnionReader(c, true))
             caseConstructor = cases |> Array.map (fun c -> FSharpValue.PreComputeUnionConstructor(c, true))
+            options =
+                t.GetCustomAttributes(typeof<JsonUnionConverterOptionsAttribute>, false)
+                |> Array.tryHead // AttributeUsage(AllowMultiple = false)
+                |> Option.map (fun a -> a :?> IUnionConverterOptions)
         }
     let getUnion : Type -> Union = memoize createUnion
+
+    /// Parallels F# behavior wrt how it generates a DU's underlying .NET Type
+    let inline isInlinedIntoUnionItem (t : Type) =
+        t = typeof<string>
+        || (t.IsValueType && t <> typeof<JsonElement>)
+        || t.IsArray
+        || (t.IsGenericType
+           && (typedefof<Option<_>> = t.GetGenericTypeDefinition()
+                || t.GetGenericTypeDefinition().IsValueType)) // Nullable<T>
+
+    let typeHasJsonConverterAttribute_ (t : Type) = t.IsDefined(typeof<Serialization.JsonConverterAttribute>(*, false*))
+    let typeHasJsonConverterAttribute = memoize typeHasJsonConverterAttribute_
+    let typeIsUnionWithConverterAttribute = memoize (fun (t : Type) -> isUnion t && typeHasJsonConverterAttribute_ t)
+
+    let propTypeRequiresConstruction (propertyType : Type) =
+        not (isInlinedIntoUnionItem propertyType)
+        && not (typeHasJsonConverterAttribute propertyType)
+
+    /// Prepare arguments for the Case class ctor based on the kind of case and how F# maps that to a Type
+    /// and/or whether we need to defer to System.Text.Json
+    let mapTargetCaseArgs (element : JsonElement) (options : JsonSerializerOptions) (props : PropertyInfo[]) : obj [] =
+        match props with
+        | [| singleCaseArg |] when propTypeRequiresConstruction singleCaseArg.PropertyType ->
+            [| JsonSerializer.Deserialize(element, singleCaseArg.PropertyType, options) |]
+        | multipleFieldsInCustomCaseType ->
+            [| for fi in multipleFieldsInCustomCaseType ->
+                match element.TryGetProperty fi.Name with
+                | false, _ when fi.PropertyType.IsValueType -> Activator.CreateInstance fi.PropertyType
+                | false, _ -> null
+                | true, el when el.ValueKind = JsonValueKind.Null -> null
+                | true, el -> JsonSerializer.Deserialize(el, fi.PropertyType, options) |]
+
+type UnionConverter<'T>() =
+    inherit Serialization.JsonConverter<'T>()
+
+    static let defaultConverterOptions = { discriminator = "case"; catchAllCase = None } :> IUnionConverterOptions
+
+    let getOptions union = defaultArg union.options defaultConverterOptions
+
+    override _.CanConvert(t : Type) = t = typeof<'T> && Union.isUnion t
+
+    override _.Write(writer, value, options) =
+        let value = box value
+        let union = Union.getUnion typeof<'T>
+        let unionOptions = getOptions union
+        let tag = union.tagReader value
+        let case = union.cases.[tag]
+        let fieldValues = union.fieldReader.[tag] value
+        let fieldInfos = case.GetFields()
+
+        writer.WriteStartObject()
+        writer.WritePropertyName(unionOptions.Discriminator)
+        writer.WriteStringValue(case.Name)
+        for fieldInfo, fieldValue in Seq.zip fieldInfos fieldValues do
+            if fieldValue <> null || options.DefaultIgnoreCondition <> Serialization.JsonIgnoreCondition.Always then
+                let element = JsonSerializer.SerializeToElement(fieldValue, fieldInfo.PropertyType, options)
+                if fieldInfos.Length = 1 && element.ValueKind = JsonValueKind.Object && not (Union.typeIsUnionWithConverterAttribute fieldInfo.PropertyType) then
+                    // flatten the object properties into the same one as the discriminator
+                    for prop in element.EnumerateObject() do
+                        prop.WriteTo writer
+                else
+                    writer.WritePropertyName(fieldInfo.Name)
+                    element.WriteTo writer
+        writer.WriteEndObject()
+
+    override _.Read(reader, t : Type, options) =
+        if reader.TokenType <> JsonTokenType.StartObject then
+            sprintf "Unexpected token when reading Union: %O" reader.TokenType |> JsonException |> raise
+        use document = JsonDocument.ParseValue &reader
+        let union = Union.getUnion typeof<'T>
+        let unionOptions = getOptions union
+        let element = document.RootElement
+
+        let targetCaseIndex =
+            let inputCaseNameValue = element.GetProperty unionOptions.Discriminator |> string
+            let findCaseNamed x = union.cases |> Array.tryFindIndex (fun case -> case.Name = x)
+            match findCaseNamed inputCaseNameValue, unionOptions.CatchAllCase  with
+            | None, None ->
+                sprintf "No case defined for '%s', and no catchAllCase nominated for '%s' on type '%s'"
+                    inputCaseNameValue typeof<UnionConverter<_>>.Name t.FullName |> invalidOp
+            | Some foundIndex, _ -> foundIndex
+            | None, Some catchAllCaseName ->
+                match findCaseNamed catchAllCaseName with
+                | None ->
+                    sprintf "No case defined for '%s', nominated catchAllCase: '%s' not found in type '%s'"
+                        inputCaseNameValue catchAllCaseName t.FullName |> invalidOp
+                | Some foundIndex -> foundIndex
+
+        let targetCaseFields, targetCaseCtor = union.cases.[targetCaseIndex].GetFields(), union.caseConstructor.[targetCaseIndex]
+        targetCaseCtor (Union.mapTargetCaseArgs element options targetCaseFields) :?> 'T

tests/FsCodec.NewtonsoftJson.Tests/Fixtures.fs

@@ -1,7 +1,15 @@
+#if SYSTEM_TEXT_JSON
+module FsCodec.SystemTextJson.Tests.Fixtures
+
+open FsCodec.SystemTextJson // JsonIsomorphism
+open System.Text.Json.Serialization // JsonConverter
+#else
 module FsCodec.NewtonsoftJson.Tests.Fixtures
 
 open FsCodec.NewtonsoftJson // JsonIsomorphism
 open Newtonsoft.Json // JsonConverter
+#endif
+
 open System
 open System.Runtime.Serialization