From 94b88a414376d53ffa0fbb8ea959eba6933afd3f Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Thu, 30 May 2024 14:28:56 +0100 Subject: [PATCH] Reduce duplication (#149) --- WoofWare.Myriad.Plugins/JsonParseGenerator.fs | 48 +- .../JsonSerializeGenerator.fs | 644 +++++++----------- .../RemoveOptionsGenerator.fs | 30 +- WoofWare.Myriad.Plugins/SynExpr/SynField.fs | 39 ++ .../SynExpr/SynUnionCase.fs | 32 + .../WoofWare.Myriad.Plugins.fsproj | 2 + 6 files changed, 350 insertions(+), 445 deletions(-) create mode 100644 WoofWare.Myriad.Plugins/SynExpr/SynField.fs create mode 100644 WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs diff --git a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs index 7c91e0f..a077679 100644 --- a/WoofWare.Myriad.Plugins/JsonParseGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonParseGenerator.fs @@ -357,7 +357,7 @@ module internal JsonParseGenerator = | [ _ ; "JsonNumberHandling" ; "Serialization" ; "Json" ; "Text" ; "System" ] -> true | _ -> false - let createMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynField list) = + let createMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynFieldData list) = let xmlDoc = PreXmlDoc.Create " Parse from a JSON node." let returnInfo = @@ -391,22 +391,15 @@ module internal JsonParseGenerator = let assignments = fields - |> List.map (fun (SynField (attrs, _, id, fieldType, _, _, _, _, _)) -> - let id = - match id with - | None -> failwith "didn't get an ID on field" - | Some id -> id - - let attrs = attrs |> List.collect (fun l -> l.Attributes) - + |> List.map (fun fieldData -> let propertyNameAttr = - attrs + fieldData.Attrs |> List.tryFind (fun attr -> attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal) ) let options = - (JsonParseOption.None, attrs) + (JsonParseOption.None, fieldData.Attrs) ||> List.fold (fun options attr -> if attr.TypeName.AsString.EndsWith ("JsonNumberHandling", StringComparison.Ordinal) then let qualifiedEnumValue = @@ -438,18 +431,18 @@ module internal JsonParseGenerator = let propertyName = match propertyNameAttr with | None -> - let sb = StringBuilder id.idText.Length - sb.Append (Char.ToLowerInvariant id.idText.[0]) |> ignore + let sb = StringBuilder fieldData.Ident.idText.Length + sb.Append (Char.ToLowerInvariant fieldData.Ident.idText.[0]) |> ignore - if id.idText.Length > 1 then - sb.Append id.idText.[1..] |> ignore + if fieldData.Ident.idText.Length > 1 then + sb.Append fieldData.Ident.idText.[1..] |> ignore sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst | Some name -> name.ArgExpr let pattern = SynPat.LongIdent ( - SynLongIdent.CreateFromLongIdent [ id ], + SynLongIdent.CreateFromLongIdent [ fieldData.Ident ], None, None, SynArgPats.Empty, @@ -460,7 +453,7 @@ module internal JsonParseGenerator = SynBinding.Let ( isInline = false, isMutable = false, - expr = createParseRhs options propertyName fieldType, + expr = createParseRhs options propertyName fieldData.Type, valData = inputVal, pattern = pattern ) @@ -468,14 +461,9 @@ module internal JsonParseGenerator = 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 - - (SynLongIdent.CreateFromLongIdent [ id ], true), - Some (SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ id ])) + |> List.map (fun fieldData -> + (SynLongIdent.CreateFromLongIdent [ fieldData.Ident ], true), + Some (SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ fieldData.Ident ])) ) |> AstHelper.instantiateRecord @@ -614,9 +602,13 @@ module internal JsonParseGenerator = let decls = match synTypeDefnRepr with - | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _recordRange), _) -> - [ createMaker spec ident recordFields ] - | _ -> failwithf "Not a record type" + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, fields, _range), _) -> + let fields = fields |> List.map SynField.extractWithIdent + [ createMaker spec ident fields ] + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_accessibility, cases, _range), _) -> + // [ createMaker spec ident cases ] + failwith "Unions are not yet supported" + | _ -> failwithf "Not a record or union type" let mdl = SynModuleDecl.CreateNestedModule (info, decls) diff --git a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs index cd16b48..4c2fe03 100644 --- a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs @@ -120,10 +120,10 @@ module internal JsonSerializeGenerator = SynExprLetOrUseTrivia.empty ) |> SynExpr.createLambda "field" - | IDictionaryType (keyType, valueType) - | DictionaryType (keyType, valueType) - | IReadOnlyDictionaryType (keyType, valueType) - | MapType (keyType, valueType) -> + | IDictionaryType (_keyType, valueType) + | DictionaryType (_keyType, valueType) + | IReadOnlyDictionaryType (_keyType, valueType) + | MapType (_keyType, valueType) -> // fun field -> // let ret = JsonObject () // for (KeyValue(key, value)) in field do @@ -204,14 +204,14 @@ module internal JsonSerializeGenerator = let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ]) let args = - SynExpr.CreateParenedTuple - [ - propertyName - SynExpr.CreateApp ( - serializeNode fieldType, - SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ Ident.Create "input" ; fieldId ]) - ) - ] + [ + propertyName + SynExpr.CreateApp ( + serializeNode fieldType, + SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ Ident.Create "input" ; fieldId ]) + ) + ] + |> SynExpr.CreateParenedTuple SynExpr.CreateApp (func, args) @@ -231,416 +231,254 @@ module internal JsonSerializeGenerator = sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst | Some name -> name.ArgExpr + /// `populateNode` will be inserted before we return the `node` variable. + /// + /// That is, we give you access to a `JsonObject` called `node`, + /// and you have access to a variable `inputArgName` which is of type `typeName`. + /// Your job is to provide a `populateNode` expression which has the side effect + /// of mutating `node` to faithfully reflect the value of `inputArgName`. + let scaffolding + (spec : JsonSerializeOutputSpec) + (typeName : LongIdent) + (inputArgName : Ident) + (populateNode : SynExpr) + : SynModuleDecl + = + let xmlDoc = PreXmlDoc.Create " Serialize to a JSON node" + + let returnInfo = + SynBindingReturnInfo.Create ( + SynType.LongIdent (SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]) + ) + + 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 inputArgName + + SynValData.SynValData ( + memberFlags, + SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty), + thisIdOpt + ) + + 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 + [ + populateNode + 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 inputArgName, + 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 recordModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (fields : SynField 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 fields = fields |> List.map SynField.extractWithIdent - 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 fields = - fields - |> List.map (fun (SynField (attrs, _, id, fieldType, _, _, _, _, _)) -> - let id = - match id with - | 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 pattern = - SynPat.LongIdent ( - SynLongIdent.CreateFromLongIdent [ id ], - None, - None, - SynArgPats.Empty, - None, - range0 - ) - - let propertyName = getPropertyName id attrs - - createSerializeRhsRecord propertyName id fieldType - ) - - let finalConstruction = - fields - |> List.map (fun (_, id, _) -> - (SynLongIdent.CreateFromLongIdent [ id ], true), - Some (SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ id ])) - ) - |> AstHelper.instantiateRecord - - let assignments = assignments |> SynExpr.CreateSequential - - 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.Do (assignments, range0) - 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 ] + fields + |> List.map (fun fieldData -> + let propertyName = getPropertyName fieldData.Ident fieldData.Attrs + createSerializeRhsRecord propertyName fieldData.Ident fieldData.Type + ) + |> SynExpr.CreateSequential + |> fun expr -> SynExpr.Do (expr, range0) + |> scaffolding spec typeName inputArg 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 fields = cases |> List.map SynUnionCase.extract - 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 + fields + |> List.map (fun unionCase -> + let propertyName = getPropertyName unionCase.Ident unionCase.Attrs - let thisIdOpt = if spec.ExtensionMethods then None else Some inputArg + let caseNames = unionCase.Fields |> List.mapi (fun i _ -> Ident.Create $"arg%i{i}") - SynValData.SynValData ( - memberFlags, - SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty), - thisIdOpt - ) + let argPats = SynArgPats.create caseNames - 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 ( + let pattern = + SynPat.LongIdent ( + SynLongIdent.CreateFromLongIdent (typeName @ [ unionCase.Ident ]), None, - SynBindingKind.Normal, - false, - false, - [], - xmlDoc, - inputVal, - pattern, - Some returnInfo, - assignments, - range0, - DebugPointAtBinding.NoneAtInvisible, - { - LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0) - InlineKeyword = None - EqualsRange = Some range0 - } + None, + argPats, + None, + range0 ) - let mem = SynMemberDefn.Member (binding, range0) + let typeLine = + let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ]) - 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 - } - ) + let args = + SynExpr.CreateParenedTuple + [ + SynExpr.CreateConstString "type" + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.CreateString "System.Text.Json.Nodes.JsonValue.Create" + ), + propertyName + ) + ] - SynModuleDecl.Types ([ containingType ], range0) - else - let binding = + SynExpr.CreateApp (func, args) + + let dataNode = SynBinding.Let ( - isInline = false, - isMutable = false, - xmldoc = xmlDoc, - returnInfo = returnInfo, - expr = assignments, - valData = inputVal, - pattern = pattern + pattern = SynPat.CreateNamed (Ident.Create "dataNode"), + expr = + SynExpr.CreateApp ( + SynExpr.CreateLongIdent ( + SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ] + ), + SynExpr.CreateConst SynConst.Unit + ) ) - SynModuleDecl.CreateLet [ binding ] + let dataBindings = + (unionCase.Fields, caseNames) + ||> List.zip + |> List.map (fun (fieldData, caseName) -> + let propertyName = getPropertyName (Option.get fieldData.Ident) fieldData.Attrs + let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "dataNode" ; "Add" ]) + + let node = + SynExpr.CreateApp (serializeNode fieldData.Type, 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) + ) + |> fun clauses -> SynExpr.CreateMatch (SynExpr.CreateIdent inputArg, clauses) + |> scaffolding spec typeName inputArg let createModule (namespaceId : LongIdent) diff --git a/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs b/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs index cd23521..a81f5ba 100644 --- a/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs +++ b/WoofWare.Myriad.Plugins/RemoveOptionsGenerator.fs @@ -63,7 +63,7 @@ module internal RemoveOptionsGenerator = SynModuleDecl.Types ([ typeDecl ], range0) - let createMaker (withOptionsType : LongIdent) (withoutOptionsType : LongIdent) (fields : SynField list) = + let createMaker (withOptionsType : LongIdent) (withoutOptionsType : LongIdent) (fields : SynFieldData list) = let xmlDoc = PreXmlDoc.Create " Remove the optional members of the input." let returnInfo = @@ -81,17 +81,17 @@ module internal RemoveOptionsGenerator = let body = fields - |> List.map (fun (SynField (_, _, id, fieldType, _, _, _, _, _)) -> - let id = - match id with - | None -> failwith "Expected record field to have an identifying name" - | Some id -> id - + |> List.map (fun fieldData -> let accessor = - SynExpr.LongIdent (false, SynLongIdent ([ inputArg ; id ], [ range0 ], []), None, range0) + SynExpr.LongIdent ( + false, + SynLongIdent ([ inputArg ; fieldData.Ident ], [ range0 ], []), + None, + range0 + ) let body = - match fieldType with + match fieldData.Type with | OptionType _ -> SynExpr.CreateApp ( SynExpr.CreateAppInfix ( @@ -111,14 +111,15 @@ module internal RemoveOptionsGenerator = SynExpr.CreateLongIdent (SynLongIdent.CreateString "Option.defaultWith"), SynExpr.CreateLongIdent ( SynLongIdent.CreateFromLongIdent ( - withoutOptionsType @ [ Ident.Create (sprintf "Default%s" id.idText) ] + withoutOptionsType + @ [ Ident.Create (sprintf "Default%s" fieldData.Ident.idText) ] ) ) ) ) | _ -> accessor - (SynLongIdent.CreateFromLongIdent [ id ], true), Some body + (SynLongIdent.CreateFromLongIdent [ fieldData.Ident ], true), Some body ) |> AstHelper.instantiateRecord @@ -160,12 +161,13 @@ module internal RemoveOptionsGenerator = synComponentInfo match synTypeDefnRepr with - | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (accessibility, recordFields, _recordRange), _) -> + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (accessibility, fields, _range), _) -> + let fieldData = fields |> List.map SynField.extractWithIdent let decls = [ - createType (Some doc) accessibility typeParams recordFields - createMaker [ Ident.Create "Short" ] recordId recordFields + createType (Some doc) accessibility typeParams fields + createMaker [ Ident.Create "Short" ] recordId fieldData ] let attributes = diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynField.fs b/WoofWare.Myriad.Plugins/SynExpr/SynField.fs new file mode 100644 index 0000000..257e124 --- /dev/null +++ b/WoofWare.Myriad.Plugins/SynExpr/SynField.fs @@ -0,0 +1,39 @@ +namespace WoofWare.Myriad.Plugins + +open Fantomas.FCS.Syntax + +type internal SynFieldData<'Ident> = + { + Attrs : SynAttribute list + Ident : 'Ident + Type : SynType + } + +[] +module internal SynField = + /// Get the useful information out of a SynField. + let extract (SynField (attrs, _, id, fieldType, _, _, _, _, _)) : SynFieldData = + { + Attrs = attrs |> List.collect (fun l -> l.Attributes) + Ident = id + Type = fieldType + } + + let mapIdent<'a, 'b> (f : 'a -> 'b) (x : SynFieldData<'a>) : SynFieldData<'b> = + let ident = f x.Ident + + { + Attrs = x.Attrs + Ident = ident + Type = x.Type + } + + /// Throws if the field has no identifier. + let extractWithIdent (f : SynField) : SynFieldData = + f + |> extract + |> mapIdent (fun ident -> + match ident with + | None -> failwith "expected field identifier to have a value, but it did not" + | Some i -> i + ) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs b/WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs new file mode 100644 index 0000000..145eaab --- /dev/null +++ b/WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs @@ -0,0 +1,32 @@ +namespace WoofWare.Myriad.Plugins + +open Fantomas.FCS.Syntax + +type internal UnionCase<'Ident> = + { + Fields : SynFieldData<'Ident> list + Attrs : SynAttribute list + Ident : Ident + } + +[] +module internal SynUnionCase = + let extract (SynUnionCase (attrs, id, caseType, _, _, _, _)) : UnionCase = + match caseType with + | SynUnionCaseKind.FullType _ -> failwith "WoofWare.Myriad does not support FullType union cases." + | SynUnionCaseKind.Fields fields -> + + let fields = fields |> List.map SynField.extract + + let id = + match id with + | SynIdent.SynIdent (ident, _) -> ident + + // 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) + + { + Fields = fields + Attrs = attrs + Ident = id + } diff --git a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj index 2c3b36b..de19eab 100644 --- a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj +++ b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj @@ -32,6 +32,8 @@ + +