Allow JSON parsing to happen in an extension method (#63)

ConsumePlugin/GeneratedJson.fs

@@ -108,3 +108,68 @@ module JsonRecordType =
             E = E
             F = F
         }
+namespace ConsumePlugin
+
+/// Module containing JSON parsing extension members for the ToGetExtensionMethod type
+[<AutoOpen>]
+module ToGetExtensionMethodJsonParseExtension =
+    ///Extension methods for JSON parsing
+    type ToGetExtensionMethod with
+
+        /// Parse from a JSON node.
+        static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : ToGetExtensionMethod =
+            let Sailor =
+                (match node.["sailor"] with
+                 | null ->
+                     raise (
+                         System.Collections.Generic.KeyNotFoundException (
+                             sprintf "Required key '%s' not found on JSON object" ("sailor")
+                         )
+                     )
+                 | v -> v)
+                    .AsValue()
+                    .GetValue<float> ()
+
+            let Soldier =
+                (match node.["soldier"] with
+                 | null ->
+                     raise (
+                         System.Collections.Generic.KeyNotFoundException (
+                             sprintf "Required key '%s' not found on JSON object" ("soldier")
+                         )
+                     )
+                 | v -> v)
+                    .AsValue()
+                    .GetValue<string> ()
+                |> System.Uri
+
+            let Tailor =
+                (match node.["tailor"] with
+                 | null ->
+                     raise (
+                         System.Collections.Generic.KeyNotFoundException (
+                             sprintf "Required key '%s' not found on JSON object" ("tailor")
+                         )
+                     )
+                 | v -> v)
+                    .AsValue()
+                    .GetValue<int> ()
+
+            let Tinker =
+                (match node.["tinker"] with
+                 | null ->
+                     raise (
+                         System.Collections.Generic.KeyNotFoundException (
+                             sprintf "Required key '%s' not found on JSON object" ("tinker")
+                         )
+                     )
+                 | v -> v)
+                    .AsValue()
+                    .GetValue<string> ()
+
+            {
+                Tinker = Tinker
+                Tailor = Tailor
+                Soldier = Soldier
+                Sailor = Sailor
+            }

ConsumePlugin/JsonRecord.fs

@@ -28,3 +28,16 @@ type JsonRecordType =
         E : string array
         F : int[]
     }
+
+[<WoofWare.Myriad.Plugins.JsonParse true>]
+type ToGetExtensionMethod =
+    {
+        Tinker : string
+        Tailor : int
+        Soldier : System.Uri
+        Sailor : float
+    }
+
+[<RequireQualifiedAccess>]
+module ToGetExtensionMethod =
+    let thisModuleWouldClash = 3

Directory.Build.props

@@ -6,8 +6,8 @@
     <DisableImplicitLibraryPacksFolder>true</DisableImplicitLibraryPacksFolder>
     <DisableImplicitNuGetFallbackFolder>true</DisableImplicitNuGetFallbackFolder>
     <TreatWarningsAsErrors>true</TreatWarningsAsErrors>
-    <WarnOn>FS3559</WarnOn>
     <DebugType>embedded</DebugType>
+    <WarnOn>FS3388,FS3559</WarnOn>
   </PropertyGroup>
   <ItemGroup>
     <PackageReference Include="Nerdbank.GitVersioning" Version="3.6.133" PrivateAssets="all"/>

WoofWare.Myriad.Plugins.Test/TestJsonParse/TestExtensionMethod.fs

@@ -0,0 +1,26 @@
+namespace WoofWare.Myriad.Plugins.Test
+
+open System
+open System.Text.Json.Nodes
+open ConsumePlugin
+open NUnit.Framework
+open FsUnitTyped
+
+[<TestFixture>]
+module TestExtensionMethod =
+
+    [<Test>]
+    let ``Parse via extension method`` () =
+        let json =
+            """{"tinker": "job", "tailor": 3, "soldier": "https://example.com", "sailor": 3.1}"""
+            |> JsonNode.Parse
+
+        let expected =
+            {
+                Tinker = "job"
+                Tailor = 3
+                Soldier = Uri "https://example.com"
+                Sailor = 3.1
+            }
+
+        ToGetExtensionMethod.jsonParse json |> shouldEqual expected

WoofWare.Myriad.Plugins.Test/TestJsonParse/TestJsonParse.fs

@@ -32,3 +32,18 @@ module TestJsonParse =
 
         let actual = s |> JsonNode.Parse |> JsonRecordType.jsonParse
         actual |> shouldEqual expected
+
+    [<Test>]
+    let ``Inner example`` () =
+        let s =
+            """{
+    "something": "oh hi"
+}"""
+
+        let expected =
+            {
+                Thing = "oh hi"
+            }
+
+        let actual = s |> JsonNode.Parse |> InnerType.jsonParse
+        actual |> shouldEqual expected

WoofWare.Myriad.Plugins.Test/TestMockGenerator/TestMockGenerator.fs

@@ -14,6 +14,7 @@ module TestMockGenerator =
             { PublicTypeMock.Empty with
                 Mem1 = fun (s, count) -> List.replicate count s
             }
+            :> _
 
         let _ =
             Assert.Throws<NotImplementedException> (fun () -> mock.Mem2 "hi" |> ignore<int>)
@@ -28,6 +29,7 @@ module TestMockGenerator =
                 Mem2 = fun (i, s) c -> String.concat $"%c{c}" (List.replicate i s)
                 Mem3 = fun (i, s) c -> String.concat $"%c{c}" (List.replicate i s)
             }
+            :> _
 
         mock.Mem1 3 'a' |> shouldEqual "aaa"
         mock.Mem2 (3, "hi") 'a' |> shouldEqual "hiahiahi"

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

@@ -11,6 +11,7 @@
     <Compile Include="PureGymDtos.fs"/>
     <Compile Include="TestJsonParse\TestJsonParse.fs" />
     <Compile Include="TestJsonParse\TestPureGymJson.fs" />
+    <Compile Include="TestJsonParse\TestExtensionMethod.fs" />
     <Compile Include="TestHttpClient\TestPureGymRestApi.fs" />
     <Compile Include="TestHttpClient\TestPathParam.fs" />
     <Compile Include="TestHttpClient\TestReturnTypes.fs" />

WoofWare.Myriad.Plugins/JsonParseGenerator.fs

@@ -9,11 +9,26 @@ open Myriad.Core
 
 /// Attribute indicating a record type to which the "Add JSON parse" Myriad
 /// generator should apply during build.
-/// The purpose of this generator is to create methods of the form
+/// The purpose of this generator is to create methods (possibly extension methods) of the form
 /// `{TypeName}.jsonParse : System.Text.Json.Nodes.JsonNode -> {TypeName}`.
-type JsonParseAttribute () =
+///
+/// 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 JsonParseAttribute (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 () = JsonParseAttribute JsonParseAttribute.DefaultIsExtensionMethod
+
+type internal JsonParseOutputSpec =
+    {
+        ExtensionMethods : bool
+    }
+
 [<RequireQualifiedAccess>]
 module internal JsonParseGenerator =
     open Fantomas.FCS.Text.Range
@@ -227,7 +242,7 @@ module internal JsonParseGenerator =
         | [ _ ; "JsonNumberHandling" ; "Serialization" ; "Json" ; "Text" ; "System" ] -> true
         | _ -> false
 
-    let createMaker (typeName : LongIdent) (fields : SynField list) =
+    let createMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynField list) =
         let xmlDoc = PreXmlDoc.Create " Parse from a JSON node."
 
         let returnInfo =
@@ -237,10 +252,26 @@ module internal JsonParseGenerator =
         let functionName = Ident.Create "jsonParse"
 
         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 (
-                None,
+                memberFlags,
                 SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty),
-                Some inputArg
+                thisIdOpt
             )
 
         let assignments =
@@ -367,20 +398,60 @@ module internal JsonParseGenerator =
                 range0
             )
 
-        let binding =
-            SynBinding.Let (
-                isInline = false,
-                isMutable = false,
-                xmldoc = xmlDoc,
-                returnInfo = returnInfo,
-                expr = assignments,
-                valData = inputVal,
-                pattern = pattern
-            )
+        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
+                    }
+                )
 
-        SynModuleDecl.CreateLet [ binding ]
+            let mem = SynMemberDefn.Member (binding, range0)
 
-    let createRecordModule (namespaceId : LongIdent) (typeDefn : SynTypeDefn) =
+            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) (spec : JsonParseOutputSpec) (typeDefn : SynTypeDefn) =
         let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) =
             typeDefn
 
@@ -390,30 +461,54 @@ module internal JsonParseGenerator =
         match synTypeDefnRepr with
         | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _recordRange), _) ->
 
-            let decls = [ createMaker recordId recordFields ]
+            let decls = [ createMaker spec recordId recordFields ]
 
             let attributes =
-                [
-                    SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ())
-                    SynAttributeList.Create SynAttribute.compilationRepresentation
-                ]
+                if spec.ExtensionMethods then
+                    [ SynAttributeList.Create SynAttribute.autoOpen ]
+                else
+                    [
+                        SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ())
+                        SynAttributeList.Create SynAttribute.compilationRepresentation
+                    ]
 
             let xmlDoc =
-                recordId
-                |> Seq.map (fun i -> i.idText)
-                |> String.concat "."
-                |> sprintf " Module containing JSON parsing methods for the %s type"
+                let fullyQualified = recordId |> Seq.map (fun i -> i.idText) |> String.concat "."
+
+                let description =
+                    if spec.ExtensionMethods then
+                        "extension members"
+                    else
+                        "methods"
+
+                $" Module containing JSON parsing %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 + "JsonParseExtension"
+                            |> Ident.Create
+
+                        List.take (List.length recordId - 1) recordId @ [ expanded ]
+                else
+                    recordId
+
             let info =
-                SynComponentInfo.Create (recordId, attributes = attributes, xmldoc = xmlDoc)
+                SynComponentInfo.Create (moduleName, attributes = attributes, xmldoc = xmlDoc)
 
             let mdl = SynModuleDecl.CreateNestedModule (info, decls)
 
             SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ mdl ])
         | _ -> failwithf "Not a record type"
 
-/// Myriad generator that provides a JSON parse function for a record type.
+/// Myriad generator that provides a method (possibly an extension method) for a record type,
+/// containing a JSON parse function.
 [<MyriadGenerator("json-parse")>]
 type JsonParseGenerator () =
 
@@ -429,17 +524,37 @@ type JsonParseGenerator () =
             let namespaceAndRecords =
                 records
                 |> List.choose (fun (ns, types) ->
-                    match types |> List.filter Ast.hasAttribute<JsonParseAttribute> with
-                    | [] -> None
-                    | types -> Some (ns, types)
+                    types
+                    |> List.choose (fun typeDef ->
+                        match Ast.getAttribute<JsonParseAttribute> typeDef with
+                        | None -> None
+                        | Some attr ->
+                            let arg =
+                                match SynExpr.stripOptionalParen attr.ArgExpr with
+                                | SynExpr.Const (SynConst.Bool value, _) -> value
+                                | 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."
+
+                            let spec =
+                                {
+                                    ExtensionMethods = arg
+                                }
+
+                            Some (typeDef, spec)
+                    )
+                    |> function
+                        | [] -> None
+                        | ty -> Some (ns, ty)
                 )
 
             let modules =
                 namespaceAndRecords
                 |> List.collect (fun (ns, records) ->
                     records
-                    |> List.map (fun record ->
-                        let recordModule = JsonParseGenerator.createRecordModule ns record
+                    |> List.map (fun (record, spec) ->
+                        let recordModule = JsonParseGenerator.createRecordModule ns spec record
                         recordModule
                     )
                 )

WoofWare.Myriad.Plugins/SurfaceBaseline.txt

@@ -7,6 +7,7 @@ WoofWare.Myriad.Plugins.HttpClientGenerator..ctor [constructor]: unit
 WoofWare.Myriad.Plugins.InterfaceMockGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
 WoofWare.Myriad.Plugins.InterfaceMockGenerator..ctor [constructor]: unit
 WoofWare.Myriad.Plugins.JsonParseAttribute inherit System.Attribute
+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/SynAttribute.fs

@@ -20,3 +20,12 @@ module internal SynAttribute =
             AppliesToGetterAndSetter = false
             Range = range0
         }
+
+    let internal autoOpen : SynAttribute =
+        {
+            TypeName = SynLongIdent.CreateString "AutoOpen"
+            ArgExpr = SynExpr.CreateConst SynConst.Unit
+            Target = None
+            AppliesToGetterAndSetter = false
+            Range = range0
+        }

WoofWare.Myriad.Plugins/SynExpr.fs

@@ -102,9 +102,9 @@ module internal SynExpr =
             b
         )
 
-    let stripOptionalParen (expr : SynExpr) : SynExpr =
+    let rec stripOptionalParen (expr : SynExpr) : SynExpr =
         match expr with
-        | SynExpr.Paren (expr, _, _, _) -> expr
+        | SynExpr.Paren (expr, _, _, _) -> stripOptionalParen expr
         | expr -> expr
 
     /// Given e.g. "byte", returns "System.Byte".

WoofWare.Myriad.Plugins/version.json

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