OptionUnionConverter for failure allowed conversions

OptionUnionConverter.fs

// Written in 2018 by Nino Floris (mail@ninofloris.com)
//
// To the extent possible under law, the author(s) have dedicated all copyright and related and neighboring rights
// to this software to the public domain worldwide. This software is distributed without any warranty.
//
// You may have received a copy of the CC0 Public Domain Dedication along with this software.
// If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.

namespace JsonConverters

open System
open Newtonsoft.Json
open Newtonsoft.Json.Linq
open System.Collections.Concurrent
open System.Reflection
open Microsoft.FSharp.Reflection
open Microsoft.FSharpLu.Json

type OptionUnionConverter() =
    inherit Newtonsoft.Json.JsonConverter()

    let stringEq (a:string) (b:string) =
        a.Equals(b, System.StringComparison.OrdinalIgnoreCase)

    let unionConverter = CompactUnionJsonConverter()

    let unionCasesAndFields =
        let cache = ConcurrentDictionary<Type * string, (UnionCaseInfo * PropertyInfo[]) option>()

        let factory (key: Type * string) =
            let unionType, unionCase = key

            FSharpType.GetUnionCases(unionType)
            |> Array.filter (fun (c: UnionCaseInfo) -> stringEq unionCase c.Name)
            |> Array.tryHead
            |> function
            | None -> None
            | Some case ->
                Some (case, case.GetFields())

        fun typ case -> cache.GetOrAdd((typ, case), factory)

    let optionConstructors =
        let cache = ConcurrentDictionary<Type, ((unit -> obj) * (obj -> obj))>()

        let factory (typ: Type) =
            let noneCase, someCase =
                let cases = FSharpType.GetUnionCases(typ)
                cases.[0], cases.[1]
            let none () = FSharpValue.MakeUnion(noneCase, [||])
            let some v  = FSharpValue.MakeUnion(someCase, [|v|])
            none, some

        fun typ -> cache.GetOrAdd(typ, factory)

    let canConvertType =
        let cache = ConcurrentDictionary<Type, bool>()

        let factory (typ: Type) =
            if typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof<unit option> then
                let nestedTyp = typ.GenericTypeArguments.[0]
                FSharpType.IsUnion nestedTyp && (not nestedTyp.IsGenericType || nestedTyp.GetGenericTypeDefinition() <> typedefof<unit option>)
            else false
            
        fun (typ: Type) ->
            // Do not pollute the cache, do a minimal and fast smoke test first
            if typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof<unit option> then
                cache.GetOrAdd(typ, factory)
            else false

    override __.CanConvert(typ) = canConvertType typ

    override __.WriteJson(writer, value, serializer) =
        unionConverter.WriteJson(writer, value, serializer)

    override __.ReadJson(reader, objectType, value, serializer) =
        let caseNone, caseSome = optionConstructors objectType

        let nestedType = objectType.GenericTypeArguments.[0]
        let jToken = Linq.JToken.ReadFrom(reader)
        // Json Null maps to `None`

        // We know for sure our serializer doesn't match Option<Option<'Union>> constructs
        // As we exclude those in CanConvert(), we can directly work on the interesting layer Option<'Union>
        match jToken.Type with
        | Linq.JTokenType.String ->
            let caseName = (jToken :?> JValue).Value :?> string
            match unionCasesAndFields nestedType caseName with
            | None -> caseNone()
            | Some (case, _) -> FSharpValue.MakeUnion(case, [||]) |> caseSome
        | Linq.JTokenType.Object ->
            let jObjectProperties = (jToken :?> JObject).Properties()

            // Construct should match format of { "Case": ["Field1Value", "Field2Value"] }
            // Maybe loosen this a bit so extra unkown properties don't break if there is one that matches.
            if Seq.length jObjectProperties <> 1 then caseNone() else

            let caseProperty = jObjectProperties |> Seq.head
            let caseValue = caseProperty.Value
            let caseName = caseProperty.Name

            if caseValue.Type <> JTokenType.Array then caseNone() else

            match unionCasesAndFields nestedType caseName with
            | Some (case, fields) when caseValue |> Seq.length = fields.Length ->
                let args =
                    if fields.Length = 1 then
                        [|caseProperty.Value.First.ToObject(fields.[0].PropertyType, serializer)|]
                    else
                        fields
                        |> Seq.zip caseProperty.Value
                        |> Seq.map (fun (v,t) -> v.ToObject(t.PropertyType, serializer))
                        |> Seq.toArray

                FSharpValue.MakeUnion(case, args) |> caseSome
            | _ -> caseNone()
        | _ -> caseNone()