mirror of
https://github.com/Smaug123/WoofWare.Myriad
synced 2025-10-06 20:48:40 +00:00
Reduce duplication (#149)
This commit is contained in:
@@ -357,7 +357,7 @@ module internal JsonParseGenerator =
|
|||||||
| [ _ ; "JsonNumberHandling" ; "Serialization" ; "Json" ; "Text" ; "System" ] -> true
|
| [ _ ; "JsonNumberHandling" ; "Serialization" ; "Json" ; "Text" ; "System" ] -> true
|
||||||
| _ -> false
|
| _ -> false
|
||||||
|
|
||||||
let createMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynField list) =
|
let createMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynFieldData<Ident> list) =
|
||||||
let xmlDoc = PreXmlDoc.Create " Parse from a JSON node."
|
let xmlDoc = PreXmlDoc.Create " Parse from a JSON node."
|
||||||
|
|
||||||
let returnInfo =
|
let returnInfo =
|
||||||
@@ -391,22 +391,15 @@ module internal JsonParseGenerator =
|
|||||||
|
|
||||||
let assignments =
|
let assignments =
|
||||||
fields
|
fields
|
||||||
|> List.map (fun (SynField (attrs, _, id, fieldType, _, _, _, _, _)) ->
|
|> List.map (fun fieldData ->
|
||||||
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)
|
|
||||||
|
|
||||||
let propertyNameAttr =
|
let propertyNameAttr =
|
||||||
attrs
|
fieldData.Attrs
|
||||||
|> List.tryFind (fun attr ->
|
|> List.tryFind (fun attr ->
|
||||||
attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal)
|
attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal)
|
||||||
)
|
)
|
||||||
|
|
||||||
let options =
|
let options =
|
||||||
(JsonParseOption.None, attrs)
|
(JsonParseOption.None, fieldData.Attrs)
|
||||||
||> List.fold (fun options attr ->
|
||> List.fold (fun options attr ->
|
||||||
if attr.TypeName.AsString.EndsWith ("JsonNumberHandling", StringComparison.Ordinal) then
|
if attr.TypeName.AsString.EndsWith ("JsonNumberHandling", StringComparison.Ordinal) then
|
||||||
let qualifiedEnumValue =
|
let qualifiedEnumValue =
|
||||||
@@ -438,18 +431,18 @@ module internal JsonParseGenerator =
|
|||||||
let propertyName =
|
let propertyName =
|
||||||
match propertyNameAttr with
|
match propertyNameAttr with
|
||||||
| None ->
|
| None ->
|
||||||
let sb = StringBuilder id.idText.Length
|
let sb = StringBuilder fieldData.Ident.idText.Length
|
||||||
sb.Append (Char.ToLowerInvariant id.idText.[0]) |> ignore
|
sb.Append (Char.ToLowerInvariant fieldData.Ident.idText.[0]) |> ignore
|
||||||
|
|
||||||
if id.idText.Length > 1 then
|
if fieldData.Ident.idText.Length > 1 then
|
||||||
sb.Append id.idText.[1..] |> ignore
|
sb.Append fieldData.Ident.idText.[1..] |> ignore
|
||||||
|
|
||||||
sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst
|
sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst
|
||||||
| Some name -> name.ArgExpr
|
| Some name -> name.ArgExpr
|
||||||
|
|
||||||
let pattern =
|
let pattern =
|
||||||
SynPat.LongIdent (
|
SynPat.LongIdent (
|
||||||
SynLongIdent.CreateFromLongIdent [ id ],
|
SynLongIdent.CreateFromLongIdent [ fieldData.Ident ],
|
||||||
None,
|
None,
|
||||||
None,
|
None,
|
||||||
SynArgPats.Empty,
|
SynArgPats.Empty,
|
||||||
@@ -460,7 +453,7 @@ module internal JsonParseGenerator =
|
|||||||
SynBinding.Let (
|
SynBinding.Let (
|
||||||
isInline = false,
|
isInline = false,
|
||||||
isMutable = false,
|
isMutable = false,
|
||||||
expr = createParseRhs options propertyName fieldType,
|
expr = createParseRhs options propertyName fieldData.Type,
|
||||||
valData = inputVal,
|
valData = inputVal,
|
||||||
pattern = pattern
|
pattern = pattern
|
||||||
)
|
)
|
||||||
@@ -468,14 +461,9 @@ module internal JsonParseGenerator =
|
|||||||
|
|
||||||
let finalConstruction =
|
let finalConstruction =
|
||||||
fields
|
fields
|
||||||
|> List.map (fun (SynField (_, _, id, _, _, _, _, _, _)) ->
|
|> List.map (fun fieldData ->
|
||||||
let id =
|
(SynLongIdent.CreateFromLongIdent [ fieldData.Ident ], true),
|
||||||
match id with
|
Some (SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ fieldData.Ident ]))
|
||||||
| None -> failwith "Expected record field to have an identifying name"
|
|
||||||
| Some id -> id
|
|
||||||
|
|
||||||
(SynLongIdent.CreateFromLongIdent [ id ], true),
|
|
||||||
Some (SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ id ]))
|
|
||||||
)
|
)
|
||||||
|> AstHelper.instantiateRecord
|
|> AstHelper.instantiateRecord
|
||||||
|
|
||||||
@@ -614,9 +602,13 @@ module internal JsonParseGenerator =
|
|||||||
|
|
||||||
let decls =
|
let decls =
|
||||||
match synTypeDefnRepr with
|
match synTypeDefnRepr with
|
||||||
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, recordFields, _recordRange), _) ->
|
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, fields, _range), _) ->
|
||||||
[ createMaker spec ident recordFields ]
|
let fields = fields |> List.map SynField.extractWithIdent
|
||||||
| _ -> failwithf "Not a record type"
|
[ 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)
|
let mdl = SynModuleDecl.CreateNestedModule (info, decls)
|
||||||
|
|
||||||
|
@@ -120,10 +120,10 @@ module internal JsonSerializeGenerator =
|
|||||||
SynExprLetOrUseTrivia.empty
|
SynExprLetOrUseTrivia.empty
|
||||||
)
|
)
|
||||||
|> SynExpr.createLambda "field"
|
|> SynExpr.createLambda "field"
|
||||||
| IDictionaryType (keyType, valueType)
|
| IDictionaryType (_keyType, valueType)
|
||||||
| DictionaryType (keyType, valueType)
|
| DictionaryType (_keyType, valueType)
|
||||||
| IReadOnlyDictionaryType (keyType, valueType)
|
| IReadOnlyDictionaryType (_keyType, valueType)
|
||||||
| MapType (keyType, valueType) ->
|
| MapType (_keyType, valueType) ->
|
||||||
// fun field ->
|
// fun field ->
|
||||||
// let ret = JsonObject ()
|
// let ret = JsonObject ()
|
||||||
// for (KeyValue(key, value)) in field do
|
// for (KeyValue(key, value)) in field do
|
||||||
@@ -204,14 +204,14 @@ module internal JsonSerializeGenerator =
|
|||||||
let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ])
|
let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ])
|
||||||
|
|
||||||
let args =
|
let args =
|
||||||
SynExpr.CreateParenedTuple
|
[
|
||||||
[
|
propertyName
|
||||||
propertyName
|
SynExpr.CreateApp (
|
||||||
SynExpr.CreateApp (
|
serializeNode fieldType,
|
||||||
serializeNode fieldType,
|
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ Ident.Create "input" ; fieldId ])
|
||||||
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ Ident.Create "input" ; fieldId ])
|
)
|
||||||
)
|
]
|
||||||
]
|
|> SynExpr.CreateParenedTuple
|
||||||
|
|
||||||
SynExpr.CreateApp (func, args)
|
SynExpr.CreateApp (func, args)
|
||||||
|
|
||||||
@@ -231,416 +231,254 @@ module internal JsonSerializeGenerator =
|
|||||||
sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst
|
sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst
|
||||||
| Some name -> name.ArgExpr
|
| 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 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 inputArg = Ident.Create "input"
|
||||||
let functionName = Ident.Create "toJsonNode"
|
let fields = fields |> List.map SynField.extractWithIdent
|
||||||
|
|
||||||
let inputVal =
|
fields
|
||||||
let memberFlags =
|
|> List.map (fun fieldData ->
|
||||||
if spec.ExtensionMethods then
|
let propertyName = getPropertyName fieldData.Ident fieldData.Attrs
|
||||||
{
|
createSerializeRhsRecord propertyName fieldData.Ident fieldData.Type
|
||||||
SynMemberFlags.IsInstance = false
|
)
|
||||||
SynMemberFlags.IsDispatchSlot = false
|
|> SynExpr.CreateSequential
|
||||||
SynMemberFlags.IsOverrideOrExplicitImpl = false
|
|> fun expr -> SynExpr.Do (expr, range0)
|
||||||
SynMemberFlags.IsFinal = false
|
|> scaffolding spec typeName inputArg
|
||||||
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 ]
|
|
||||||
|
|
||||||
let unionModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (cases : SynUnionCase list) =
|
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 inputArg = Ident.Create "input"
|
||||||
let functionName = Ident.Create "toJsonNode"
|
let fields = cases |> List.map SynUnionCase.extract
|
||||||
|
|
||||||
let inputVal =
|
fields
|
||||||
let memberFlags =
|
|> List.map (fun unionCase ->
|
||||||
if spec.ExtensionMethods then
|
let propertyName = getPropertyName unionCase.Ident unionCase.Attrs
|
||||||
{
|
|
||||||
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
|
let caseNames = unionCase.Fields |> List.mapi (fun i _ -> Ident.Create $"arg%i{i}")
|
||||||
|
|
||||||
SynValData.SynValData (
|
let argPats = SynArgPats.create caseNames
|
||||||
memberFlags,
|
|
||||||
SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty),
|
|
||||||
thisIdOpt
|
|
||||||
)
|
|
||||||
|
|
||||||
let cases =
|
let pattern =
|
||||||
cases
|
SynPat.LongIdent (
|
||||||
|> List.map (fun (SynUnionCase (attrs, SynIdent.SynIdent (id, _), caseType, _, _, _, _)) ->
|
SynLongIdent.CreateFromLongIdent (typeName @ [ unionCase.Ident ]),
|
||||||
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,
|
None,
|
||||||
SynBindingKind.Normal,
|
None,
|
||||||
false,
|
argPats,
|
||||||
false,
|
None,
|
||||||
[],
|
range0
|
||||||
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 typeLine =
|
||||||
|
let func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ])
|
||||||
|
|
||||||
let containingType =
|
let args =
|
||||||
SynTypeDefn.SynTypeDefn (
|
SynExpr.CreateParenedTuple
|
||||||
SynComponentInfo.Create (typeName, xmldoc = PreXmlDoc.Create " Extension methods for JSON parsing"),
|
[
|
||||||
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0),
|
SynExpr.CreateConstString "type"
|
||||||
[ mem ],
|
SynExpr.CreateApp (
|
||||||
None,
|
SynExpr.CreateLongIdent (
|
||||||
range0,
|
SynLongIdent.CreateString "System.Text.Json.Nodes.JsonValue.Create"
|
||||||
{
|
),
|
||||||
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
|
propertyName
|
||||||
EqualsRange = None
|
)
|
||||||
WithKeyword = None
|
]
|
||||||
}
|
|
||||||
)
|
|
||||||
|
|
||||||
SynModuleDecl.Types ([ containingType ], range0)
|
SynExpr.CreateApp (func, args)
|
||||||
else
|
|
||||||
let binding =
|
let dataNode =
|
||||||
SynBinding.Let (
|
SynBinding.Let (
|
||||||
isInline = false,
|
pattern = SynPat.CreateNamed (Ident.Create "dataNode"),
|
||||||
isMutable = false,
|
expr =
|
||||||
xmldoc = xmlDoc,
|
SynExpr.CreateApp (
|
||||||
returnInfo = returnInfo,
|
SynExpr.CreateLongIdent (
|
||||||
expr = assignments,
|
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
|
||||||
valData = inputVal,
|
),
|
||||||
pattern = pattern
|
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
|
let createModule
|
||||||
(namespaceId : LongIdent)
|
(namespaceId : LongIdent)
|
||||||
|
@@ -63,7 +63,7 @@ module internal RemoveOptionsGenerator =
|
|||||||
|
|
||||||
SynModuleDecl.Types ([ typeDecl ], range0)
|
SynModuleDecl.Types ([ typeDecl ], range0)
|
||||||
|
|
||||||
let createMaker (withOptionsType : LongIdent) (withoutOptionsType : LongIdent) (fields : SynField list) =
|
let createMaker (withOptionsType : LongIdent) (withoutOptionsType : LongIdent) (fields : SynFieldData<Ident> list) =
|
||||||
let xmlDoc = PreXmlDoc.Create " Remove the optional members of the input."
|
let xmlDoc = PreXmlDoc.Create " Remove the optional members of the input."
|
||||||
|
|
||||||
let returnInfo =
|
let returnInfo =
|
||||||
@@ -81,17 +81,17 @@ module internal RemoveOptionsGenerator =
|
|||||||
|
|
||||||
let body =
|
let body =
|
||||||
fields
|
fields
|
||||||
|> List.map (fun (SynField (_, _, id, fieldType, _, _, _, _, _)) ->
|
|> List.map (fun fieldData ->
|
||||||
let id =
|
|
||||||
match id with
|
|
||||||
| None -> failwith "Expected record field to have an identifying name"
|
|
||||||
| Some id -> id
|
|
||||||
|
|
||||||
let accessor =
|
let accessor =
|
||||||
SynExpr.LongIdent (false, SynLongIdent ([ inputArg ; id ], [ range0 ], []), None, range0)
|
SynExpr.LongIdent (
|
||||||
|
false,
|
||||||
|
SynLongIdent ([ inputArg ; fieldData.Ident ], [ range0 ], []),
|
||||||
|
None,
|
||||||
|
range0
|
||||||
|
)
|
||||||
|
|
||||||
let body =
|
let body =
|
||||||
match fieldType with
|
match fieldData.Type with
|
||||||
| OptionType _ ->
|
| OptionType _ ->
|
||||||
SynExpr.CreateApp (
|
SynExpr.CreateApp (
|
||||||
SynExpr.CreateAppInfix (
|
SynExpr.CreateAppInfix (
|
||||||
@@ -111,14 +111,15 @@ module internal RemoveOptionsGenerator =
|
|||||||
SynExpr.CreateLongIdent (SynLongIdent.CreateString "Option.defaultWith"),
|
SynExpr.CreateLongIdent (SynLongIdent.CreateString "Option.defaultWith"),
|
||||||
SynExpr.CreateLongIdent (
|
SynExpr.CreateLongIdent (
|
||||||
SynLongIdent.CreateFromLongIdent (
|
SynLongIdent.CreateFromLongIdent (
|
||||||
withoutOptionsType @ [ Ident.Create (sprintf "Default%s" id.idText) ]
|
withoutOptionsType
|
||||||
|
@ [ Ident.Create (sprintf "Default%s" fieldData.Ident.idText) ]
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
| _ -> accessor
|
| _ -> accessor
|
||||||
|
|
||||||
(SynLongIdent.CreateFromLongIdent [ id ], true), Some body
|
(SynLongIdent.CreateFromLongIdent [ fieldData.Ident ], true), Some body
|
||||||
)
|
)
|
||||||
|> AstHelper.instantiateRecord
|
|> AstHelper.instantiateRecord
|
||||||
|
|
||||||
@@ -160,12 +161,13 @@ module internal RemoveOptionsGenerator =
|
|||||||
synComponentInfo
|
synComponentInfo
|
||||||
|
|
||||||
match synTypeDefnRepr with
|
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 =
|
let decls =
|
||||||
[
|
[
|
||||||
createType (Some doc) accessibility typeParams recordFields
|
createType (Some doc) accessibility typeParams fields
|
||||||
createMaker [ Ident.Create "Short" ] recordId recordFields
|
createMaker [ Ident.Create "Short" ] recordId fieldData
|
||||||
]
|
]
|
||||||
|
|
||||||
let attributes =
|
let attributes =
|
||||||
|
39
WoofWare.Myriad.Plugins/SynExpr/SynField.fs
Normal file
39
WoofWare.Myriad.Plugins/SynExpr/SynField.fs
Normal file
@@ -0,0 +1,39 @@
|
|||||||
|
namespace WoofWare.Myriad.Plugins
|
||||||
|
|
||||||
|
open Fantomas.FCS.Syntax
|
||||||
|
|
||||||
|
type internal SynFieldData<'Ident> =
|
||||||
|
{
|
||||||
|
Attrs : SynAttribute list
|
||||||
|
Ident : 'Ident
|
||||||
|
Type : SynType
|
||||||
|
}
|
||||||
|
|
||||||
|
[<RequireQualifiedAccess>]
|
||||||
|
module internal SynField =
|
||||||
|
/// Get the useful information out of a SynField.
|
||||||
|
let extract (SynField (attrs, _, id, fieldType, _, _, _, _, _)) : SynFieldData<Ident option> =
|
||||||
|
{
|
||||||
|
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<Ident> =
|
||||||
|
f
|
||||||
|
|> extract
|
||||||
|
|> mapIdent (fun ident ->
|
||||||
|
match ident with
|
||||||
|
| None -> failwith "expected field identifier to have a value, but it did not"
|
||||||
|
| Some i -> i
|
||||||
|
)
|
32
WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs
Normal file
32
WoofWare.Myriad.Plugins/SynExpr/SynUnionCase.fs
Normal file
@@ -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
|
||||||
|
}
|
||||||
|
|
||||||
|
[<RequireQualifiedAccess>]
|
||||||
|
module internal SynUnionCase =
|
||||||
|
let extract (SynUnionCase (attrs, id, caseType, _, _, _, _)) : UnionCase<Ident option> =
|
||||||
|
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
|
||||||
|
}
|
@@ -32,6 +32,8 @@
|
|||||||
<Compile Include="SynExpr\SynAttribute.fs" />
|
<Compile Include="SynExpr\SynAttribute.fs" />
|
||||||
<Compile Include="SynExpr\SynArgPats.fs" />
|
<Compile Include="SynExpr\SynArgPats.fs" />
|
||||||
<Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" />
|
<Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" />
|
||||||
|
<Compile Include="SynExpr\SynField.fs" />
|
||||||
|
<Compile Include="SynExpr\SynUnionCase.fs" />
|
||||||
<Compile Include="RemoveOptionsGenerator.fs"/>
|
<Compile Include="RemoveOptionsGenerator.fs"/>
|
||||||
<Compile Include="InterfaceMockGenerator.fs"/>
|
<Compile Include="InterfaceMockGenerator.fs"/>
|
||||||
<Compile Include="JsonSerializeGenerator.fs"/>
|
<Compile Include="JsonSerializeGenerator.fs"/>
|
||||||
|
Reference in New Issue
Block a user