From 35cd94cba170bf72311d325f189cba9befa0de03 Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Thu, 30 May 2024 12:00:55 +0100 Subject: [PATCH] Add JSON serialisation of DUs (#144) --- ConsumePlugin/GeneratedCatamorphism.fs | 4 +- ConsumePlugin/GeneratedFileSystem.fs | 4 +- ConsumePlugin/GeneratedSerde.fs | 31 ++ ConsumePlugin/ListCata.fs | 4 +- .../SerializationAndDeserialization.fs | 6 + README.md | 3 + WoofWare.Myriad.Plugins/CataGenerator.fs | 16 +- WoofWare.Myriad.Plugins/JsonParseGenerator.fs | 104 +++-- .../JsonSerializeGenerator.fs | 423 ++++++++++++++---- WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs | 18 + .../{ => SynExpr}/SynAttribute.fs | 0 .../{ => SynExpr}/SynExpr.fs | 0 .../SynExpr/SynExprLetOrUseTrivia.fs | 10 + .../{ => SynExpr}/SynType.fs | 0 .../WoofWare.Myriad.Plugins.fsproj | 8 +- 15 files changed, 473 insertions(+), 158 deletions(-) create mode 100644 WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs rename WoofWare.Myriad.Plugins/{ => SynExpr}/SynAttribute.fs (100%) rename WoofWare.Myriad.Plugins/{ => SynExpr}/SynExpr.fs (100%) create mode 100644 WoofWare.Myriad.Plugins/SynExpr/SynExprLetOrUseTrivia.fs rename WoofWare.Myriad.Plugins/{ => SynExpr}/SynType.fs (100%) diff --git a/ConsumePlugin/GeneratedCatamorphism.fs b/ConsumePlugin/GeneratedCatamorphism.fs index 192a327..1acef92 100644 --- a/ConsumePlugin/GeneratedCatamorphism.fs +++ b/ConsumePlugin/GeneratedCatamorphism.fs @@ -60,7 +60,7 @@ module TreeCata = instructions.RemoveAt (instructions.Count - 1) match currentInstruction with - | Instruction.Process__TreeBuilder x -> + | Instruction.Process__TreeBuilder (x) -> match x with | TreeBuilder.Child (arg0_0) -> instructions.Add Instruction.TreeBuilder_Child @@ -68,7 +68,7 @@ module TreeCata = | TreeBuilder.Parent (arg0_0) -> instructions.Add Instruction.TreeBuilder_Parent instructions.Add (Instruction.Process__Tree arg0_0) - | Instruction.Process__Tree x -> + | Instruction.Process__Tree (x) -> match x with | Tree.Const (arg0_0, arg1_0) -> cata.Tree.Const arg0_0 arg1_0 |> treeStack.Add | Tree.Pair (arg0_0, arg1_0, arg2_0) -> diff --git a/ConsumePlugin/GeneratedFileSystem.fs b/ConsumePlugin/GeneratedFileSystem.fs index 4021d70..62c2e8e 100644 --- a/ConsumePlugin/GeneratedFileSystem.fs +++ b/ConsumePlugin/GeneratedFileSystem.fs @@ -41,7 +41,7 @@ module FileSystemItemCata = instructions.RemoveAt (instructions.Count - 1) match currentInstruction with - | Instruction.Process__FileSystemItem x -> + | Instruction.Process__FileSystemItem (x) -> match x with | FileSystemItem.Directory ({ Name = name @@ -116,7 +116,7 @@ module GiftCata = instructions.RemoveAt (instructions.Count - 1) match currentInstruction with - | Instruction.Process__Gift x -> + | Instruction.Process__Gift (x) -> match x with | Gift.Book (arg0_0) -> cata.Gift.Book arg0_0 |> giftStack.Add | Gift.Chocolate (arg0_0) -> cata.Gift.Chocolate arg0_0 |> giftStack.Add diff --git a/ConsumePlugin/GeneratedSerde.fs b/ConsumePlugin/GeneratedSerde.fs index 7dec1c3..0082288 100644 --- a/ConsumePlugin/GeneratedSerde.fs +++ b/ConsumePlugin/GeneratedSerde.fs @@ -149,6 +149,37 @@ module JsonRecordTypeWithBothJsonSerializeExtension = ) node :> _ +namespace ConsumePlugin + +open System +open System.Collections.Generic +open System.Text.Json.Serialization + +/// Module containing JSON serializing extension members for the FirstDu type +[] +module FirstDuJsonSerializeExtension = + /// Extension methods for JSON parsing + type FirstDu with + + /// Serialize to a JSON node + static member toJsonNode (input : FirstDu) : System.Text.Json.Nodes.JsonNode = + let node = System.Text.Json.Nodes.JsonObject () + + match input with + | FirstDu.EmptyCase -> node.Add ("type", System.Text.Json.Nodes.JsonValue.Create "emptyCase") + | FirstDu.Case1 (arg0) -> + node.Add ("type", System.Text.Json.Nodes.JsonValue.Create "case1") + let dataNode = System.Text.Json.Nodes.JsonObject () + dataNode.Add ("data", System.Text.Json.Nodes.JsonValue.Create arg0) + node.Add ("data", dataNode) + | FirstDu.Case2 (arg0, arg1) -> + node.Add ("type", System.Text.Json.Nodes.JsonValue.Create "case2") + let dataNode = System.Text.Json.Nodes.JsonObject () + dataNode.Add ("record", JsonRecordTypeWithBoth.toJsonNode arg0) + dataNode.Add ("i", System.Text.Json.Nodes.JsonValue.Create arg1) + node.Add ("data", dataNode) + + node :> _ namespace ConsumePlugin diff --git a/ConsumePlugin/ListCata.fs b/ConsumePlugin/ListCata.fs index 5c75d8e..0a7ecb3 100644 --- a/ConsumePlugin/ListCata.fs +++ b/ConsumePlugin/ListCata.fs @@ -41,7 +41,7 @@ module MyListCata = instructions.RemoveAt (instructions.Count - 1) match currentInstruction with - | Instruction.Process__MyList x -> + | Instruction.Process__MyList (x) -> match x with | MyList.Nil -> cata.MyList.Nil |> myListStack.Add | MyList.Cons ({ @@ -97,7 +97,7 @@ module MyList2Cata = instructions.RemoveAt (instructions.Count - 1) match currentInstruction with - | Instruction.Process__MyList2 x -> + | Instruction.Process__MyList2 (x) -> match x with | MyList2.Nil -> cata.MyList2.Nil |> myList2Stack.Add | MyList2.Cons (arg0_0, arg1_0) -> diff --git a/ConsumePlugin/SerializationAndDeserialization.fs b/ConsumePlugin/SerializationAndDeserialization.fs index 11f34b6..d4b5336 100644 --- a/ConsumePlugin/SerializationAndDeserialization.fs +++ b/ConsumePlugin/SerializationAndDeserialization.fs @@ -27,3 +27,9 @@ type JsonRecordTypeWithBoth = E : string array F : int[] } + +[] +type FirstDu = + | EmptyCase + | Case1 of data : string + | Case2 of record : JsonRecordTypeWithBoth * i : int diff --git a/README.md b/README.md index f6845c8..35b9d96 100644 --- a/README.md +++ b/README.md @@ -143,6 +143,9 @@ module InnerTypeWithBoth = node ``` +Also includes an *opinionated* serializer for discriminated unions. +(Any such serializer must be opinionated, because JSON does not natively model DUs.) + As in `JsonParse`, you can optionally supply the boolean `true` to the attribute, which will cause Myriad to stamp out an extension method rather than a module with the same name as the type. diff --git a/WoofWare.Myriad.Plugins/CataGenerator.fs b/WoofWare.Myriad.Plugins/CataGenerator.fs index b19f653..c3bbf01 100644 --- a/WoofWare.Myriad.Plugins/CataGenerator.fs +++ b/WoofWare.Myriad.Plugins/CataGenerator.fs @@ -1113,7 +1113,7 @@ module internal CataGenerator = analysis.AssociatedProcessInstruction, None, None, - SynArgPats.Pats [ SynPat.CreateNamed (Ident.Create "x") ], + SynArgPats.create [ Ident.Create "x" ], None, range0 ), @@ -1162,22 +1162,16 @@ module internal CataGenerator = |> Seq.mapi (fun i x -> (i, x)) |> Seq.choose (fun (i, case) -> match case.Description with - | FieldDescription.NonRecursive _ -> SynPat.CreateNamed case.ArgName |> Some - | FieldDescription.ListSelf _ -> SynPat.CreateNamed case.ArgName |> Some + | FieldDescription.NonRecursive _ -> case.ArgName |> Some + | FieldDescription.ListSelf _ -> case.ArgName |> Some | FieldDescription.Self _ -> None ) |> Seq.toList - let lhs = - match lhsNames with - | [] -> [] - | lhsNames -> - SynPat.Tuple (false, lhsNames, List.replicate (lhsNames.Length - 1) range0, range0) - |> SynPat.CreateParen - |> List.singleton + let lhs = SynArgPats.create lhsNames let pat = - SynPat.LongIdent (unionCase.AssociatedInstruction, None, None, SynArgPats.Pats lhs, None, range0) + SynPat.LongIdent (unionCase.AssociatedInstruction, None, None, lhs, None, range0) let populateArgs = unionCase.FlattenedFields diff --git a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs index 09a6d86..7c91e0f 100644 --- a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs @@ -566,61 +566,61 @@ module internal JsonParseGenerator = SynModuleDecl.CreateLet [ binding ] - let createRecordModule (namespaceId : LongIdent) (spec : JsonParseOutputSpec) (typeDefn : SynTypeDefn) = + let createModule (namespaceId : LongIdent) (spec : JsonParseOutputSpec) (typeDefn : SynTypeDefn) = let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) = typeDefn - let (SynComponentInfo (_attributes, _typeParams, _constraints, recordId, _, _preferPostfix, _access, _)) = + let (SynComponentInfo (_attributes, _typeParams, _constraints, ident, _, _preferPostfix, _access, _)) = synComponentInfo - match synTypeDefnRepr with - | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _recordRange), _) -> + let attributes = + if spec.ExtensionMethods then + [ SynAttributeList.Create SynAttribute.autoOpen ] + else + [ + SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) + SynAttributeList.Create SynAttribute.compilationRepresentation + ] - let decls = [ createMaker spec recordId recordFields ] + let xmlDoc = + let fullyQualified = ident |> Seq.map (fun i -> i.idText) |> String.concat "." - let attributes = + let description = if spec.ExtensionMethods then - [ SynAttributeList.Create SynAttribute.autoOpen ] + "extension members" else - [ - SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) - SynAttributeList.Create SynAttribute.compilationRepresentation - ] + "methods" - let xmlDoc = - let fullyQualified = recordId |> Seq.map (fun i -> i.idText) |> String.concat "." + $" Module containing JSON parsing %s{description} for the %s{fullyQualified} type" + |> PreXmlDoc.Create - let description = - if spec.ExtensionMethods then - "extension members" - else - "methods" + let moduleName = + if spec.ExtensionMethods then + match ident with + | [] -> failwith "unexpectedly got an empty identifier for record name" + | ident -> + let expanded = + List.last ident + |> fun i -> i.idText + |> fun s -> s + "JsonParseExtension" + |> Ident.Create - $" Module containing JSON parsing %s{description} for the %s{fullyQualified} type" - |> PreXmlDoc.Create + List.take (List.length ident - 1) ident @ [ expanded ] + else + ident - 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 + let info = + SynComponentInfo.Create (moduleName, attributes = attributes, xmldoc = xmlDoc) - List.take (List.length recordId - 1) recordId @ [ expanded ] - else - recordId + let decls = + match synTypeDefnRepr with + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _recordRange), _) -> + [ createMaker spec ident recordFields ] + | _ -> failwithf "Not a record type" - let info = - SynComponentInfo.Create (moduleName, attributes = attributes, xmldoc = xmlDoc) + let mdl = SynModuleDecl.CreateNestedModule (info, decls) - let mdl = SynModuleDecl.CreateNestedModule (info, decls) - - SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ mdl ]) - | _ -> failwithf "Not a record type" + SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ mdl ]) /// Myriad generator that provides a method (possibly an extension method) for a record type, /// containing a JSON parse function. @@ -634,10 +634,20 @@ type JsonParseGenerator () = let ast, _ = Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head - let records = Ast.extractRecords ast + let recordsAndUnions = + Ast.extractTypeDefn ast + |> List.map (fun (name, defns) -> + defns + |> List.choose (fun defn -> + if Ast.isRecord defn then Some defn + elif Ast.isDu defn then Some defn + else None + ) + |> fun defns -> name, defns + ) - let namespaceAndRecords = - records + let namespaceAndTypes = + recordsAndUnions |> List.choose (fun (ns, types) -> types |> List.choose (fun typeDef -> @@ -665,13 +675,9 @@ type JsonParseGenerator () = ) let modules = - namespaceAndRecords - |> List.collect (fun (ns, records) -> - records - |> List.map (fun (record, spec) -> - let recordModule = JsonParseGenerator.createRecordModule ns spec record - recordModule - ) + namespaceAndTypes + |> List.collect (fun (ns, types) -> + types |> List.map (fun (ty, spec) -> JsonParseGenerator.createModule ns spec ty) ) Output.Ast modules diff --git a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs index d9e80ee..cd16b48 100644 --- a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs @@ -117,9 +117,7 @@ module internal JsonSerializeGenerator = SynExpr.CreateIdentString "arr" ], range0, - { - InKeyword = None - } + SynExprLetOrUseTrivia.empty ) |> SynExpr.createLambda "field" | IDictionaryType (keyType, valueType) @@ -188,9 +186,7 @@ module internal JsonSerializeGenerator = SynExpr.CreateIdentString "ret" ], range0, - { - InKeyword = None - } + SynExprLetOrUseTrivia.empty ) |> SynExpr.createLambda "field" | _ -> @@ -204,7 +200,7 @@ module internal JsonSerializeGenerator = /// propertyName is probably a string literal, but it could be a [] variable /// `node.Add ({propertyName}, {toJsonNode})` - let createSerializeRhs (propertyName : SynExpr) (fieldId : Ident) (fieldType : SynType) : SynExpr = + let createSerializeRhsRecord (propertyName : SynExpr) (fieldId : Ident) (fieldType : SynType) : SynExpr = let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ]) let args = @@ -219,7 +215,24 @@ module internal JsonSerializeGenerator = SynExpr.CreateApp (func, args) - let createMaker (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (fields : SynField list) = + let getPropertyName (fieldId : Ident) (attrs : SynAttribute list) : SynExpr = + let propertyNameAttr = + attrs + |> List.tryFind (fun attr -> attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal)) + + match propertyNameAttr with + | None -> + let sb = StringBuilder fieldId.idText.Length + sb.Append (Char.ToLowerInvariant fieldId.idText.[0]) |> ignore + + if fieldId.idText.Length > 1 then + sb.Append fieldId.idText.[1..] |> ignore + + sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst + | Some name -> name.ArgExpr + + + let recordModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (fields : SynField list) = let xmlDoc = PreXmlDoc.Create " Serialize to a JSON node" let returnInfo = @@ -253,7 +266,7 @@ module internal JsonSerializeGenerator = thisIdOpt ) - let assignments = + let fields = fields |> List.map (fun (SynField (attrs, _, id, fieldType, _, _, _, _, _)) -> let id = @@ -261,26 +274,14 @@ module internal JsonSerializeGenerator = | None -> failwith "didn't get an ID on field" | Some id -> id + attrs, id, fieldType + ) + + let assignments = + fields + |> List.map (fun (attrs, id, fieldType) -> let attrs = attrs |> List.collect (fun l -> l.Attributes) - let propertyNameAttr = - attrs - |> List.tryFind (fun attr -> - attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal) - ) - - let propertyName = - match propertyNameAttr with - | None -> - let sb = StringBuilder id.idText.Length - sb.Append (Char.ToLowerInvariant id.idText.[0]) |> ignore - - if id.idText.Length > 1 then - sb.Append id.idText.[1..] |> ignore - - sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst - | Some name -> name.ArgExpr - let pattern = SynPat.LongIdent ( SynLongIdent.CreateFromLongIdent [ id ], @@ -291,17 +292,14 @@ module internal JsonSerializeGenerator = range0 ) - createSerializeRhs propertyName id fieldType + let propertyName = getPropertyName id attrs + + createSerializeRhsRecord propertyName id fieldType ) let finalConstruction = fields - |> List.map (fun (SynField (_, _, id, _, _, _, _, _, _)) -> - let id = - match id with - | None -> failwith "Expected record field to have an identifying name" - | Some id -> id - + |> List.map (fun (_, id, _) -> (SynLongIdent.CreateFromLongIdent [ id ], true), Some (SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ id ])) ) @@ -331,9 +329,7 @@ module internal JsonSerializeGenerator = SynExpr.Upcast (SynExpr.CreateIdentString "node", SynType.Anon range0, range0) ], range0, - { - InKeyword = None - } + SynExprLetOrUseTrivia.empty ) let pattern = @@ -406,7 +402,247 @@ module internal JsonSerializeGenerator = SynModuleDecl.CreateLet [ binding ] - let createRecordModule + let unionModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (cases : SynUnionCase list) = + let xmlDoc = PreXmlDoc.Create " Serialize to a JSON node" + + let returnInfo = + SynBindingReturnInfo.Create ( + SynType.LongIdent (SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]) + ) + + let inputArg = Ident.Create "input" + let functionName = Ident.Create "toJsonNode" + + 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 ( + memberFlags, + SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty), + thisIdOpt + ) + + let cases = + cases + |> List.map (fun (SynUnionCase (attrs, SynIdent.SynIdent (id, _), caseType, _, _, _, _)) -> + match caseType with + | SynUnionCaseKind.FullType _ -> failwith "WoofWare.Myriad does not support FullType union cases." + | SynUnionCaseKind.Fields fields -> + + let fields = + fields + |> List.map (fun (SynField (attrs, _, id, fieldType, _, _, _, _, _)) -> + match id with + | None -> failwith "WoofWare.Myriad requires all union fields to have names" + | Some id -> + + let attrs = attrs |> List.collect (fun l -> l.Attributes) + attrs, id, fieldType + ) + // As far as I can tell, there's no way to get any attributes here? :shrug: + let attrs = attrs |> List.collect (fun l -> l.Attributes) + attrs, id, fields + ) + + let matchClauses : SynMatchClause list = + cases + |> List.map (fun (attrs, id, caseType) -> + let propertyName = getPropertyName id attrs + + let caseNames = caseType |> List.mapi (fun i _ -> Ident.Create $"arg%i{i}") + + let argPats = SynArgPats.create caseNames + + let pattern = + SynPat.LongIdent ( + SynLongIdent.CreateFromLongIdent (typeName @ [ id ]), + None, + None, + argPats, + None, + range0 + ) + + let typeLine = + let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ]) + + let args = + SynExpr.CreateParenedTuple + [ + SynExpr.CreateConstString "type" + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.CreateString "System.Text.Json.Nodes.JsonValue.Create" + ), + propertyName + ) + ] + + SynExpr.CreateApp (func, args) + + let dataNode = + SynBinding.Let ( + pattern = SynPat.CreateNamed (Ident.Create "dataNode"), + expr = + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ] + ), + SynExpr.CreateConst SynConst.Unit + ) + ) + + let dataBindings = + (caseType, caseNames) + ||> List.zip + |> List.map (fun ((attrs, ident, synType), caseName) -> + let propertyName = getPropertyName ident attrs + let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "dataNode" ; "Add" ]) + let node = SynExpr.CreateApp (serializeNode synType, SynExpr.CreateIdent caseName) + + SynExpr.CreateApp (func, SynExpr.CreateParenedTuple [ propertyName ; node ]) + ) + + let assignToNode = + let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ]) + + let args = + SynExpr.CreateParenedTuple + [ SynExpr.CreateConstString "data" ; SynExpr.CreateIdentString "dataNode" ] + + SynExpr.CreateApp (func, args) + + let dataNode = + SynExpr.LetOrUse ( + false, + false, + [ dataNode ], + SynExpr.CreateSequential (dataBindings @ [ assignToNode ]), + range0, + SynExprLetOrUseTrivia.empty + ) + + let action = + [ + yield typeLine + if not dataBindings.IsEmpty then + yield dataNode + ] + |> SynExpr.CreateSequential + + SynMatchClause.Create (pattern, None, action) + ) + + let assignments = + SynExpr.LetOrUse ( + false, + false, + [ + SynBinding.Let ( + pattern = SynPat.CreateNamed (Ident.Create "node"), + expr = + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ] + ), + SynExpr.CreateConst SynConst.Unit + ) + ) + ], + SynExpr.CreateSequential + [ + SynExpr.CreateMatch (SynExpr.CreateIdent inputArg, matchClauses) + SynExpr.Upcast (SynExpr.CreateIdentString "node", SynType.Anon range0, range0) + ], + range0, + SynExprLetOrUseTrivia.empty + ) + + let pattern = + SynPat.LongIdent ( + SynLongIdent.CreateFromLongIdent [ functionName ], + None, + None, + SynArgPats.Pats + [ + SynPat.CreateTyped ( + SynPat.CreateNamed inputArg, + SynType.LongIdent (SynLongIdent.CreateFromLongIdent typeName) + ) + |> SynPat.CreateParen + ], + None, + range0 + ) + + 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 + } + ) + + let mem = SynMemberDefn.Member (binding, range0) + + 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 createModule (namespaceId : LongIdent) (opens : SynOpenDeclTarget list) (spec : JsonSerializeOutputSpec) @@ -415,60 +651,62 @@ module internal JsonSerializeGenerator = let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) = typeDefn - let (SynComponentInfo (_attributes, _typeParams, _constraints, recordId, _, _preferPostfix, _access, _)) = + let (SynComponentInfo (_attributes, _typeParams, _constraints, ident, _, _preferPostfix, _access, _)) = synComponentInfo - match synTypeDefnRepr with - | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _recordRange), _) -> + let attributes = + if spec.ExtensionMethods then + [ SynAttributeList.Create SynAttribute.autoOpen ] + else + [ + SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) + SynAttributeList.Create SynAttribute.compilationRepresentation + ] - let decls = [ createMaker spec recordId recordFields ] + let xmlDoc = + let fullyQualified = ident |> Seq.map (fun i -> i.idText) |> String.concat "." - let attributes = + let description = if spec.ExtensionMethods then - [ SynAttributeList.Create SynAttribute.autoOpen ] + "extension members" else - [ - SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ()) - SynAttributeList.Create SynAttribute.compilationRepresentation - ] + "methods" - let xmlDoc = - let fullyQualified = recordId |> Seq.map (fun i -> i.idText) |> String.concat "." + $" Module containing JSON serializing %s{description} for the %s{fullyQualified} type" + |> PreXmlDoc.Create - let description = - if spec.ExtensionMethods then - "extension members" - else - "methods" + let moduleName = + if spec.ExtensionMethods then + match ident with + | [] -> failwith "unexpectedly got an empty identifier for type name" + | ident -> + let expanded = + List.last ident + |> fun i -> i.idText + |> fun s -> s + "JsonSerializeExtension" + |> Ident.Create - $" Module containing JSON serializing %s{description} for the %s{fullyQualified} type" - |> PreXmlDoc.Create + List.take (List.length ident - 1) ident @ [ expanded ] + else + ident - 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 + "JsonSerializeExtension" - |> Ident.Create + let info = + SynComponentInfo.Create (moduleName, attributes = attributes, xmldoc = xmlDoc) - List.take (List.length recordId - 1) recordId @ [ expanded ] - else - recordId + let decls = + match synTypeDefnRepr with + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _range), _) -> + [ recordModule spec ident recordFields ] + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_accessibility, unionFields, _range), _) -> + [ unionModule spec ident unionFields ] + | _ -> failwithf "Only record types currently supported." - let info = - SynComponentInfo.Create (moduleName, attributes = attributes, xmldoc = xmlDoc) + let mdl = SynModuleDecl.CreateNestedModule (info, decls) - let mdl = SynModuleDecl.CreateNestedModule (info, decls) - - SynModuleOrNamespace.CreateNamespace ( - namespaceId, - decls = (opens |> List.map SynModuleDecl.CreateOpen) @ [ mdl ] - ) - | _ -> failwithf "Not a record type" + SynModuleOrNamespace.CreateNamespace ( + namespaceId, + decls = (opens |> List.map SynModuleDecl.CreateOpen) @ [ mdl ] + ) /// Myriad generator that provides a method (possibly an extension method) for a record type, /// containing a JSON serialization function. @@ -482,10 +720,20 @@ type JsonSerializeGenerator () = let ast, _ = Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head - let records = Ast.extractRecords ast + let recordsAndUnions = + Ast.extractTypeDefn ast + |> List.map (fun (name, defns) -> + defns + |> List.choose (fun defn -> + if Ast.isRecord defn then Some defn + elif Ast.isDu defn then Some defn + else None + ) + |> fun defns -> name, defns + ) - let namespaceAndRecords = - records + let namespaceAndTypes = + recordsAndUnions |> List.choose (fun (ns, types) -> types |> List.choose (fun typeDef -> @@ -515,13 +763,10 @@ type JsonSerializeGenerator () = let opens = AstHelper.extractOpens ast let modules = - namespaceAndRecords - |> List.collect (fun (ns, records) -> - records - |> List.map (fun (record, spec) -> - let recordModule = JsonSerializeGenerator.createRecordModule ns opens spec record - recordModule - ) + namespaceAndTypes + |> List.collect (fun (ns, types) -> + types + |> List.map (fun (ty, spec) -> JsonSerializeGenerator.createModule ns opens spec ty) ) Output.Ast modules diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs b/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs new file mode 100644 index 0000000..d54b492 --- /dev/null +++ b/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs @@ -0,0 +1,18 @@ +namespace WoofWare.Myriad.Plugins + +open Fantomas.FCS.Syntax +open Fantomas.FCS.Text.Range + +[] +module internal SynArgPats = + let create (caseNames : Ident list) : SynArgPats = + if caseNames.IsEmpty then + SynArgPats.Pats [] + else + + caseNames + |> List.map (fun ident -> SynPat.Named (SynIdent.SynIdent (ident, None), false, None, range0)) + |> fun ps -> SynPat.Tuple (false, ps, List.replicate (ps.Length - 1) range0, range0) + |> fun p -> SynPat.Paren (p, range0) + |> List.singleton + |> SynArgPats.Pats diff --git a/WoofWare.Myriad.Plugins/SynAttribute.fs b/WoofWare.Myriad.Plugins/SynExpr/SynAttribute.fs similarity index 100% rename from WoofWare.Myriad.Plugins/SynAttribute.fs rename to WoofWare.Myriad.Plugins/SynExpr/SynAttribute.fs diff --git a/WoofWare.Myriad.Plugins/SynExpr.fs b/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs similarity index 100% rename from WoofWare.Myriad.Plugins/SynExpr.fs rename to WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynExprLetOrUseTrivia.fs b/WoofWare.Myriad.Plugins/SynExpr/SynExprLetOrUseTrivia.fs new file mode 100644 index 0000000..e78a44c --- /dev/null +++ b/WoofWare.Myriad.Plugins/SynExpr/SynExprLetOrUseTrivia.fs @@ -0,0 +1,10 @@ +namespace WoofWare.Myriad.Plugins + +open Fantomas.FCS.SyntaxTrivia + +[] +module internal SynExprLetOrUseTrivia = + let empty : SynExprLetOrUseTrivia = + { + InKeyword = None + } diff --git a/WoofWare.Myriad.Plugins/SynType.fs b/WoofWare.Myriad.Plugins/SynExpr/SynType.fs similarity index 100% rename from WoofWare.Myriad.Plugins/SynType.fs rename to WoofWare.Myriad.Plugins/SynExpr/SynType.fs diff --git a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj index bb82a48..2c3b36b 100644 --- a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj +++ b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj @@ -27,9 +27,11 @@ - - - + + + + +