Finish DU parsing (#151)

ConsumePlugin/GeneratedSerde.fs

@@ -378,3 +378,83 @@ module JsonRecordTypeWithBothJsonParseExtension =
                 E = arg_4
                 F = arg_5
             }
+namespace ConsumePlugin
+
+/// Module containing JSON parsing extension members for the FirstDu type
+[<AutoOpen>]
+module FirstDuJsonParseExtension =
+    /// Extension methods for JSON parsing
+    type FirstDu with
+
+        /// Parse from a JSON node.
+        static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : FirstDu =
+            let ty =
+                (match node.["type"] with
+                 | null ->
+                     raise (
+                         System.Collections.Generic.KeyNotFoundException (
+                             sprintf "Required key '%s' not found on JSON object" ("type")
+                         )
+                     )
+                 | v -> v)
+                |> (fun v -> v.GetValue<string> ())
+
+            match ty with
+            | "emptyCase" -> FirstDu.EmptyCase
+            | "case1" ->
+                let node =
+                    (match node.["data"] with
+                     | null ->
+                         raise (
+                             System.Collections.Generic.KeyNotFoundException (
+                                 sprintf "Required key '%s' not found on JSON object" ("data")
+                             )
+                         )
+                     | v -> v)
+
+                FirstDu.Case1 (
+                    (match node.["data"] with
+                     | null ->
+                         raise (
+                             System.Collections.Generic.KeyNotFoundException (
+                                 sprintf "Required key '%s' not found on JSON object" ("data")
+                             )
+                         )
+                     | v -> v)
+                        .AsValue()
+                        .GetValue<string> ()
+                )
+            | "case2" ->
+                let node =
+                    (match node.["data"] with
+                     | null ->
+                         raise (
+                             System.Collections.Generic.KeyNotFoundException (
+                                 sprintf "Required key '%s' not found on JSON object" ("data")
+                             )
+                         )
+                     | v -> v)
+
+                FirstDu.Case2 (
+                    JsonRecordTypeWithBoth.jsonParse (
+                        match node.["record"] with
+                        | null ->
+                            raise (
+                                System.Collections.Generic.KeyNotFoundException (
+                                    sprintf "Required key '%s' not found on JSON object" ("record")
+                                )
+                            )
+                        | v -> v
+                    ),
+                    (match node.["i"] with
+                     | null ->
+                         raise (
+                             System.Collections.Generic.KeyNotFoundException (
+                                 sprintf "Required key '%s' not found on JSON object" ("i")
+                             )
+                         )
+                     | v -> v)
+                        .AsValue()
+                        .GetValue<int> ()
+                )
+            | v -> failwith ("Unrecognised 'type' field value: " + v)

ConsumePlugin/SerializationAndDeserialization.fs

@@ -29,6 +29,7 @@ type JsonRecordTypeWithBoth =
     }
 
 [<WoofWare.Myriad.Plugins.JsonSerialize true>]
+[<WoofWare.Myriad.Plugins.JsonParse true>]
 type FirstDu =
     | EmptyCase
     | Case1 of data : string

WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs

@@ -2,10 +2,9 @@ namespace WoofWare.Myriad.Plugins.Test
 
 open System
 open System.Collections.Generic
-open System.IO
-open System.Text
-open System.Text.Json
 open System.Text.Json.Nodes
+open FsCheck.Random
+open Microsoft.FSharp.Reflection
 open NUnit.Framework
 open FsCheck
 open FsUnitTyped
@@ -124,3 +123,82 @@ module TestJsonSerde =
         |> shouldEqual (
             sprintf """{"it\u0027s-a-me":"%s","map":{},"readOnlyDict":{},"dict":{},"concreteDict":{}}""" guidStr
         )
+
+    type Generators =
+        static member TestCase () =
+            { new Arbitrary<InnerTypeWithBoth>() with
+                override x.Generator = innerGen 5
+            }
+
+    let sanitiseInner (r : InnerTypeWithBoth) : InnerTypeWithBoth =
+        {
+            Thing = r.Thing
+            Map = r.Map
+            ReadOnlyDict = r.ReadOnlyDict
+            Dict = r.Dict
+            ConcreteDict = r.ConcreteDict
+        }
+
+    let sanitiseRec (r : JsonRecordTypeWithBoth) : JsonRecordTypeWithBoth =
+        {
+            A = r.A
+            B = if isNull r.B then "<null>" else r.B
+            C =
+                if Object.ReferenceEquals (r.C, (null : obj)) then
+                    []
+                else
+                    r.C
+            D = sanitiseInner r.D
+            E = if isNull r.E then [||] else r.E
+            F =
+                if Object.ReferenceEquals (r.F, (null : obj)) then
+                    [||]
+                else
+                    r.F
+        }
+
+    let duGen =
+        gen {
+            let! case = Gen.choose (0, 2)
+
+            match case with
+            | 0 -> return FirstDu.EmptyCase
+            | 1 ->
+                let! s = Arb.generate<NonNull<string>>
+                return FirstDu.Case1 s.Get
+            | 2 ->
+                let! i = Arb.generate<int>
+                let! record = outerGen
+                return FirstDu.Case2 (record, i)
+            | _ -> return failwith $"unexpected: %i{case}"
+        }
+
+    [<Test>]
+    let ``Discriminated union works`` () =
+        let property (du : FirstDu) : unit =
+            du
+            |> FirstDu.toJsonNode
+            |> fun s -> s.ToJsonString ()
+            |> JsonNode.Parse
+            |> FirstDu.jsonParse
+            |> shouldEqual du
+
+        property |> Prop.forAll (Arb.fromGen duGen) |> Check.QuickThrowOnFailure
+
+    [<Test>]
+    let ``DU generator covers all cases`` () =
+        let rand = Random ()
+        let cases = FSharpType.GetUnionCases typeof<FirstDu>
+        let counts = Array.zeroCreate<int> cases.Length
+
+        let decompose = FSharpValue.PreComputeUnionTagReader typeof<FirstDu>
+
+        Gen.listOf duGen
+        |> Gen.eval 100 (StdGen.StdGen (rand.Next (), rand.Next ()))
+        |> List.iter (fun du ->
+            let tag = decompose du
+            counts.[tag] <- counts.[tag] + 1
+        )
+
+        for i in counts do
+            i |> shouldBeGreaterThan 0

WoofWare.Myriad.Plugins/JsonParseGenerator.fs

@@ -314,9 +314,8 @@ module internal JsonParseGenerator =
     /// propertyName is probably a string literal, but it could be a [<Literal>] variable
     /// The result of this function is the body of a let-binding (not including the LHS of that let-binding).
     let createParseRhs (options : JsonParseOption) (propertyName : SynExpr) (fieldType : SynType) : SynExpr =
-        SynExpr.CreateIdentString "node"
+        let objectToParse = SynExpr.CreateIdentString "node" |> SynExpr.index propertyName
-        |> SynExpr.index propertyName
+        parseNode (Some propertyName) options fieldType objectToParse
-        |> parseNode (Some propertyName) options fieldType
 
     let isJsonNumberHandling (literal : LongIdent) : bool =
         match List.rev literal |> List.map (fun ident -> ident.idText) with
@@ -376,7 +375,34 @@ module internal JsonParseGenerator =
             |> List.singleton
             |> SynModuleDecl.CreateLet
 
-    let createMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynFieldData<Ident> list) =
+    let getParseOptions (fieldAttrs : SynAttribute list) =
+        (JsonParseOption.None, fieldAttrs)
+        ||> List.fold (fun options attr ->
+            if attr.TypeName.AsString.EndsWith ("JsonNumberHandling", StringComparison.Ordinal) then
+                let qualifiedEnumValue =
+                    match SynExpr.stripOptionalParen attr.ArgExpr with
+                    | SynExpr.LongIdent (_, SynLongIdent (ident, _, _), _, _) when isJsonNumberHandling ident ->
+                        // Make sure it's fully qualified
+                        SynExpr.createLongIdent
+                            [
+                                "System"
+                                "Text"
+                                "Json"
+                                "Serialization"
+                                "JsonNumberHandling"
+                                "AllowReadingFromString"
+                            ]
+                    | _ -> attr.ArgExpr
+
+                {
+                    JsonNumberHandlingArg = Some qualifiedEnumValue
+                }
+            else
+                options
+        )
+
+
+    let createRecordMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynFieldData<Ident> list) =
         let assignments =
             fields
             |> List.mapi (fun i fieldData ->
@@ -386,42 +412,18 @@ module internal JsonParseGenerator =
                         attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal)
                     )
 
-                let options =
+                let options = getParseOptions fieldData.Attrs
-                    (JsonParseOption.None, fieldData.Attrs)
-                    ||> List.fold (fun options attr ->
-                        if attr.TypeName.AsString.EndsWith ("JsonNumberHandling", StringComparison.Ordinal) then
-                            let qualifiedEnumValue =
-                                match SynExpr.stripOptionalParen attr.ArgExpr with
-                                | SynExpr.LongIdent (_, SynLongIdent (ident, _, _), _, _) when
-                                    isJsonNumberHandling ident
-                                    ->
-                                    // Make sure it's fully qualified
-                                    SynExpr.createLongIdent
-                                        [
-                                            "System"
-                                            "Text"
-                                            "Json"
-                                            "Serialization"
-                                            "JsonNumberHandling"
-                                            "AllowReadingFromString"
-                                        ]
-                                | _ -> attr.ArgExpr
-
-                            {
-                                JsonNumberHandlingArg = Some qualifiedEnumValue
-                            }
-                        else
-                            options
-                    )
 
                 let propertyName =
                     match propertyNameAttr with
                     | None ->
                         let sb = StringBuilder fieldData.Ident.idText.Length
-                        sb.Append (Char.ToLowerInvariant fieldData.Ident.idText.[0]) |> ignore
+
+                        sb.Append (Char.ToLowerInvariant fieldData.Ident.idText.[0])
+                        |> ignore<StringBuilder>
 
                         if fieldData.Ident.idText.Length > 1 then
-                            sb.Append fieldData.Ident.idText.[1..] |> ignore
+                            sb.Append (fieldData.Ident.idText.Substring 1) |> ignore<StringBuilder>
 
                         sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst
                     | Some name -> name.ArgExpr
@@ -438,15 +440,97 @@ module internal JsonParseGenerator =
             )
             |> AstHelper.instantiateRecord
 
-        let assignments =
+        (finalConstruction, assignments)
-            (finalConstruction, assignments)
+        ||> List.fold (fun final assignment -> SynExpr.createLet [ assignment ] final)
-            ||> List.fold (fun final assignment -> SynExpr.createLet [ assignment ] final)
 
-        assignments |> scaffolding spec typeName
+    let createUnionMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : UnionCase<Ident> list) =
+        fields
+        |> List.map (fun case ->
+            let propertyName = JsonSerializeGenerator.getPropertyName case.Ident case.Attrs
 
+            let body =
+                if case.Fields.IsEmpty then
+                    SynExpr.createLongIdent' (typeName @ [ case.Ident ])
+                else
+                    case.Fields
+                    |> List.map (fun field ->
+                        let propertyName = JsonSerializeGenerator.getPropertyName field.Ident field.Attrs
+                        let options = getParseOptions field.Attrs
+                        createParseRhs options propertyName field.Type
+                    )
+                    |> SynExpr.CreateParenedTuple
+                    |> SynExpr.applyFunction (SynExpr.createLongIdent' (typeName @ [ case.Ident ]))
+                    |> SynExpr.createLet
+                        [
+                            SynExpr.index (SynExpr.CreateConstString "data") (SynExpr.CreateIdentString "node")
+                            |> assertNotNull (SynExpr.CreateConstString "data")
+                            |> SynBinding.basic (SynLongIdent.CreateString "node") []
+                        ]
+
+            match propertyName with
+            | SynExpr.Const (synConst, _) ->
+                SynMatchClause.SynMatchClause (
+                    SynPat.CreateConst synConst,
+                    None,
+                    body,
+                    range0,
+                    DebugPointAtTarget.Yes,
+                    {
+                        ArrowRange = Some range0
+                        BarRange = Some range0
+                    }
+                )
+            | _ ->
+                SynMatchClause.SynMatchClause (
+                    SynPat.CreateNamed (Ident.Create "x"),
+                    Some (SynExpr.equals (SynExpr.CreateIdentString "x") propertyName),
+                    body,
+                    range0,
+                    DebugPointAtTarget.Yes,
+                    {
+                        ArrowRange = Some range0
+                        BarRange = Some range0
+                    }
+                )
+        )
+        |> fun l ->
+            l
+            @ [
+                let fail =
+                    SynExpr.plus
+                        (SynExpr.CreateConstString "Unrecognised 'type' field value: ")
+                        (SynExpr.CreateIdentString "v")
+                    |> SynExpr.CreateParen
+                    |> SynExpr.applyFunction (SynExpr.CreateIdentString "failwith")
+
+                SynMatchClause.SynMatchClause (
+                    SynPat.CreateNamed (Ident.Create "v"),
+                    None,
+                    fail,
+                    range0,
+                    DebugPointAtTarget.Yes,
+                    {
+                        ArrowRange = Some range0
+                        BarRange = Some range0
+                    }
+                )
+            ]
+        |> SynExpr.createMatch (SynExpr.CreateIdentString "ty")
+        |> SynExpr.createLet
+            [
+                let property = SynExpr.CreateConstString "type"
+
+                SynExpr.CreateIdentString "node"
+                |> SynExpr.index property
+                |> assertNotNull property
+                |> SynExpr.pipeThroughFunction (
+                    SynExpr.createLambda
+                        "v"
+                        (SynExpr.callGenericMethod "GetValue" [ Ident.Create "string" ] (SynExpr.CreateIdentString "v"))
+                )
+                |> SynBinding.basic (SynLongIdent.CreateString "ty") []
+            ]
     (*
-
-        static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : FirstDu =
             let ty =
                 match node.["type"] with
                 | null -> raise (System.Collections.Generic.KeyNotFoundException ())
@@ -506,18 +590,28 @@ module internal JsonParseGenerator =
         let info =
             SynComponentInfo.Create (moduleName, attributes = attributes, xmldoc = xmlDoc)
 
-        let decls =
+        let decl =
             match synTypeDefnRepr with
             | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, fields, _range), _) ->
                 let fields = fields |> List.map SynField.extractWithIdent
-                [ createMaker spec ident fields ]
+                createRecordMaker spec ident fields
             | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_accessibility, cases, _range), _) ->
-                let cases = cases |> List.map SynUnionCase.extract
+                let optionGet (i : Ident option) =
-                // [ createMaker spec ident cases ]
+                    match i with
-                failwith "Unions are not yet supported"
+                    | None -> failwith "WoofWare.Myriad requires union cases to have identifiers on each field."
+                    | Some i -> i
+
+                let cases =
+                    cases
+                    |> List.map SynUnionCase.extract
+                    |> List.map (UnionCase.mapIdentFields optionGet)
+
+                createUnionMaker spec ident cases
             | _ -> failwithf "Not a record or union type"
 
-        let mdl = SynModuleDecl.CreateNestedModule (info, decls)
+        let mdl =
+            [ scaffolding spec ident decl ]
+            |> fun d -> SynModuleDecl.CreateNestedModule (info, d)
 
         SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ mdl ])
 

WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs

@@ -9,6 +9,15 @@ type internal UnionCase<'Ident> =
         Ident : Ident
     }
 
+[<RequireQualifiedAccess>]
+module internal UnionCase =
+    let mapIdentFields<'a, 'b> (f : 'a -> 'b) (unionCase : UnionCase<'a>) : UnionCase<'b> =
+        {
+            Fields = unionCase.Fields |> List.map (SynField.mapIdent f)
+            Attrs = unionCase.Attrs
+            Ident = unionCase.Ident
+        }
+
 [<RequireQualifiedAccess>]
 module internal SynUnionCase =
     let extract (SynUnionCase (attrs, id, caseType, _, _, _, _)) : UnionCase<Ident option> =