Port UnionConverter to STJ

src/FsCodec.SystemTextJson/JsonOptionConverter.fs

@@ -1,4 +1,4 @@
-namespace FsCodec.SystemTextJson.Converters
+namespace FsCodec.SystemTextJson
 
 open System
 open System.Linq.Expressions

src/FsCodec.SystemTextJson/JsonRecordConverter.fs

@@ -1,4 +1,4 @@
-namespace FsCodec.SystemTextJson.Converters
+namespace FsCodec.SystemTextJson
 
 open FSharp.Reflection
 open System

src/FsCodec.SystemTextJson/JsonSerializerElementExtensions.fs

@@ -7,20 +7,31 @@ open System.Text.Json
 
 [<AutoOpen>]
 module internal JsonSerializerExtensions =
+#if NETSTANDARD2_0
+    let private write (element : JsonElement )=
+        let bufferWriter = ArrayBufferWriter<byte>()
+        (
+            use jsonWriter = new Utf8JsonWriter(bufferWriter)
+            element.WriteTo(jsonWriter)
+        )
+        bufferWriter.WrittenSpan
+#endif
+
     type JsonSerializer with
         static member SerializeToElement(value: 'T, [<Optional; DefaultParameterValue(null)>] ?options: JsonSerializerOptions) =
             let span = ReadOnlySpan.op_Implicit(JsonSerializer.SerializeToUtf8Bytes(value, defaultArg options null))
             JsonSerializer.Deserialize<JsonElement>(span)
 
         static member DeserializeElement<'T>(element: JsonElement, [<Optional; DefaultParameterValue(null)>] ?options: JsonSerializerOptions) =
 #if NETSTANDARD2_0
-            let json = element.GetRawText()
-            JsonSerializer.Deserialize<'T>(json, defaultArg options null)
+            JsonSerializer.Deserialize<'T>(write element, defaultArg options null)
+#else
+            JsonSerializer.Deserialize<'T>(element.GetRawText(), defaultArg options null)
+#endif
+
+        static member DeserializeElement(element : JsonElement, t : Type, [<Optional; DefaultParameterValue(null)>] ?options: JsonSerializerOptions) =
+#if NETSTANDARD2_0
+            JsonSerializer.Deserialize(write element, t, defaultArg options null)
 #else
-            let bufferWriter = ArrayBufferWriter<byte>()
-            (
-                use jsonWriter = new Utf8JsonWriter(bufferWriter)
-                element.WriteTo(jsonWriter)
-            )
-            JsonSerializer.Deserialize<'T>(bufferWriter.WrittenSpan, defaultArg options null)
+            JsonSerializer.Deserialize(element.GetRawText(), t, defaultArg options null)
 #endif

src/FsCodec.SystemTextJson/Options.fs

@@ -8,8 +8,7 @@ open System.Text.Json.Serialization
 type Options private () =
 
     static let defaultConverters : JsonConverter[] =
-        [|  Converters.JsonOptionConverter()
-            Converters.JsonRecordConverter() |]
+        [| JsonOptionConverter(); JsonRecordConverter() |]
 
     /// Creates a default set of serializer options used by Json serialization. When used with no args, same as `JsonSerializerOptions()`
     static member CreateDefault

src/FsCodec.SystemTextJson/TypeSafeEnumConverter.fs

@@ -1,5 +1,6 @@
 namespace FsCodec.SystemTextJson
 
+open FsCodec.SystemTextJson
 open System
 open System.Collections.Generic
 open System.Text.Json

src/FsCodec.SystemTextJson/UnionConverter.fs

@@ -1,15 +1,47 @@
 namespace FsCodec.SystemTextJson
 
+open FsCodec.SystemTextJson
+open FsCodec.SystemTextJson.Core
 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
+
+/// <summary>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>); JsonUnionConverterOptions("type")>]</c></summary>
+/// <remarks>Not inherited because JsonConverters don't get inherited right now.
+/// https://github.com/dotnet/runtime/issues/30427#issuecomment-610080138</remarks>
+[<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 =
+type internal Union =
     {
         cases: UnionCaseInfo[]
         tagReader: obj -> int
         fieldReader: (obj -> obj[])[]
         caseConstructor: (obj[] -> obj)[]
+        options: IUnionConverterOptions option
     }
 
 module private Union =
@@ -23,5 +55,115 @@ 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)
             } |> Some
     let tryGetUnion : Type -> Union option = memoize _tryGetUnion
+
+
+    /// Paralells F# behavior wrt how it generates a DU's underlying .NET Type
+    let inline isInlinedIntoUnionItem (t : Type) =
+        t = typeof<string>
+        //|| t.IsValueType
+        || t.IsArray
+        || (t.IsGenericType
+           && (typedefof<Option<_>> = t.GetGenericTypeDefinition()
+                || t.GetGenericTypeDefinition().IsValueType)) // Nullable<T>
+
+    let typeHasJsonConverterAttribute = memoize (fun (t : Type) -> t.IsDefined(typeof<Serialization.JsonConverterAttribute>, false))
+
+    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 (props : PropertyInfo[]) : obj [] =
+        match props with
+        | [| singleCaseArg |] when propTypeRequiresConstruction singleCaseArg.PropertyType ->
+            [| JsonSerializer.DeserializeElement (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.DeserializeElement (el, fi.PropertyType, options) |]
+
+type UnionConverter<'T> (converterOptions) =
+    inherit Serialization.JsonConverter<'T>()
+
+    static let defaultConverterOptions = { discriminator = "case"; catchAllCase = None }
+
+    let getOptions union =
+        converterOptions :> IUnionConverterOptions
+        |> defaultArg union.options
+
+    new() = UnionConverter<'T>(defaultConverterOptions)
+    new(discriminator: string, catchAllCase: string) = // Compatibility with Newtonsoft UnionConverter constructor
+        UnionConverter<'T>({ discriminator = discriminator; catchAllCase = Option.ofObj catchAllCase})
+
+    override __.CanConvert(_) = Union.tryGetUnion (typeof<'T>) |> Option.isSome
+
+    override __.Write(writer, value, options) =
+        let value = box value
+        let union = Union.tryGetUnion (typeof<'T>) |> Option.get
+        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)
+
+        match fieldInfos with
+        | [| fi |] ->
+            match fieldValues.[0] with
+            | null when options.IgnoreNullValues -> ()
+            | fv ->
+                let element = JsonSerializer.SerializeToElement(fv, options)
+                match element.ValueKind with
+                | JsonValueKind.Object ->
+                    // flatten the object properties into the same one as the discriminator
+                    for prop in element.EnumerateObject() do
+                        prop.WriteTo writer
+                | _ ->
+                    writer.WritePropertyName(fi.Name)
+                    element.WriteTo writer
+        | _ ->
+            for fieldInfo, fieldValue in Seq.zip fieldInfos fieldValues do
+                if fieldValue <> null || not options.IgnoreNullValues then
+                    writer.WritePropertyName(fieldInfo.Name)
+                    JsonSerializer.Serialize(writer, fieldValue, options)
+
+        writer.WriteEndObject()
+
+    override __.Read(reader, t : Type, options) =
+        reader.ValidateTokenType(JsonTokenType.StartObject)
+        use document = JsonDocument.ParseValue &reader
+        let union = Union.tryGetUnion (typeof<'T>) |> Option.get
+        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.SystemTextJson.Tests/FsCodec.SystemTextJson.Tests.fsproj

@@ -23,11 +23,13 @@
   </ItemGroup>
 
   <ItemGroup>
+    <Compile Include="Samples.fs" />
     <Compile Include="PicklerTests.fs" />
     <Compile Include="CodecTests.fs" />
     <Compile Include="SerdesTests.fs" />
     <Compile Include="UmxInteropTests.fs" />
     <Compile Include="TypeSafeEnumConverterTests.fs" />
+    <Compile Include="UnionConverterTests.fs" />
     <None Include="Examples.fsx" />
     <Compile Include="InteropTests.fs" />
   </ItemGroup>

tests/FsCodec.SystemTextJson.Tests/PicklerTests.fs

@@ -1,7 +1,6 @@
 module FsCodec.SystemTextJson.Tests.PicklerTests
 
 open FsCodec.SystemTextJson
-open FsCodec.SystemTextJson.Converters
 open Swensen.Unquote
 open System
 open System.Text.Json

tests/FsCodec.SystemTextJson.Tests/Samples.fs

@@ -0,0 +1,59 @@
+module FsCodec.SystemTextJson.Tests.Samples
+
+open FsCodec.SystemTextJson
+open System
+open System.Runtime.Serialization
+open System.Text.Json.Serialization
+
+/// Endows any type that inherits this class with standard .NET comparison semantics using a supplied token identifier
+[<AbstractClass>]
+type Comparable<'TComp, 'Token when 'TComp :> Comparable<'TComp, 'Token> and 'Token : comparison>(token : 'Token) =
+    member private __.Token = token // I can haz protected?
+    override x.Equals y = match y with :? Comparable<'TComp, 'Token> as y -> x.Token = y.Token | _ -> false
+    override __.GetHashCode() = hash token
+    interface IComparable with
+        member x.CompareTo y =
+            match y with
+            | :? Comparable<'TComp, 'Token> as y -> compare x.Token y.Token
+            | _ -> invalidArg "y" "invalid comparand"
+
+/// SkuId strongly typed id
+[<Sealed; JsonConverter(typeof<SkuIdJsonConverter>); AutoSerializable(false); StructuredFormatDisplay("{Value}")>]
+// (Internally a string for most efficient copying semantics)
+type SkuId private (id : string) =
+    inherit Comparable<SkuId, string>(id)
+    [<IgnoreDataMember>] // Prevent swashbuckle inferring there's a "value" field
+    member __.Value = id
+    override __.ToString () = id
+    new (guid: Guid) = SkuId (guid.ToString("N"))
+    // NB tests (specifically, empty) lean on having a ctor of this shape
+    new() = SkuId(Guid.NewGuid())
+    // NB for validation [and XSS] purposes we prove it translatable to a Guid
+    static member Parse(input: string) = SkuId (Guid.Parse input)
+/// Represent as a Guid.ToString("N") output externally
+and SkuIdJsonConverter() =
+    inherit JsonIsomorphism<SkuId, string>()
+    /// Renders as per Guid.ToString("N")
+    override __.Pickle value = value.Value
+    /// Input must be a Guid.Parseable value
+    override __.UnPickle input = SkuId.Parse input
+
+/// CartId strongly typed id
+[<Sealed; JsonConverter(typeof<CartIdJsonConverter>); AutoSerializable(false); StructuredFormatDisplay("{Value}")>]
+// (Internally a string for most efficient copying semantics)
+type CartId private (id : string) =
+    inherit Comparable<CartId, string>(id)
+    [<IgnoreDataMember>] // Prevent swashbuckle inferring there's a "value" field
+    member __.Value = id
+    override __.ToString () = id
+    // NB tests lean on having a ctor of this shape
+    new (guid: Guid) = CartId (guid.ToString("N"))
+    // NB for validation [and XSS] purposes we must prove it translatable to a Guid
+    static member Parse(input: string) = CartId (Guid.Parse input)
+/// Represent as a Guid.ToString("N") output externally
+and CartIdJsonConverter() =
+    inherit JsonIsomorphism<CartId, string>()
+    /// Renders as per Guid.ToString("N")
+    override __.Pickle value = value.Value
+    /// Input must be a Guid.Parseable value
+    override __.UnPickle input = CartId.Parse input

tests/FsCodec.SystemTextJson.Tests/SerdesTests.fs

@@ -24,7 +24,7 @@ module StjCharacterization =
                 | Choice2Of2 m -> m.Contains "Deserialization of reference types without parameterless constructor is not supported. Type 'FsCodec.SystemTextJson.Tests.SerdesTests+Record'" @>
 
     let [<Fact>] ``OOTB STJ options`` () =
-        let ootbOptionsWithRecordConverter = Options.CreateDefault(converters = [|Converters.JsonRecordConverter()|])
+        let ootbOptionsWithRecordConverter = Options.CreateDefault(converters = [|JsonRecordConverter()|])
         let value = { a = 1; b = Some "str" }
         let ser =  Serdes.Serialize(value, ootbOptions)
         test <@ ser = """{"a":1,"b":{"Value":"str"}}""" @>
@@ -40,8 +40,7 @@ module StjCharacterization =
     // - and is not in alignment with the FsCodec.NewtonsoftJson default options
     // see https://github.com/dotnet/runtime/issues/28567#issuecomment-53581752 for lowdown
     let asRequiredForExamples : System.Text.Json.Serialization.JsonConverter [] =
-        [| Converters.JsonOptionConverter()
-           Converters.JsonRecordConverter() |]
+        [| JsonOptionConverter(); JsonRecordConverter() |]
     type OverescapedOptions() as this =
         inherit TheoryData<System.Text.Json.JsonSerializerOptions>()