Compare commits

...

7 Commits

Author SHA1 Message Date
Patrick Stevens
94b88a4143 Reduce duplication (#149) 2024-05-30 14:28:56 +01:00
Patrick Stevens
ed3ffecb52 Fix and test GitHub release script (#148) 2024-05-30 12:32:40 +00:00
Patrick Stevens
c696dcf31f Fix curl failing logic (#147) 2024-05-30 11:35:30 +00:00
Patrick Stevens
d5bb2726d3 Tighten the tagging logic (#146) 2024-05-30 11:28:43 +00:00
Patrick Stevens
f17290d0f1 Check generation of files is accurate (#145) 2024-05-30 12:10:49 +01:00
Patrick Stevens
35cd94cba1 Add JSON serialisation of DUs (#144) 2024-05-30 12:00:55 +01:00
Patrick Stevens
1b3eb03380 NerdBank.GitVersioning heights (#143) 2024-05-29 00:44:16 +01:00
22 changed files with 628 additions and 251 deletions

View File

@@ -1,3 +1,4 @@
# yaml-language-server: $schema=https://raw.githubusercontent.com/SchemaStore/schemastore/master/src/schemas/json/github-workflow.json
name: .NET
on:
@@ -86,6 +87,27 @@ jobs:
- name: Run Fantomas
run: nix run .#fantomas -- --check .
check-accurate-generations:
runs-on: ubuntu-latest
steps:
- name: Checkout
uses: actions/checkout@v4
with:
fetch-depth: 0 # so that NerdBank.GitVersioning has access to history
- name: Install Nix
uses: cachix/install-nix-action@V27
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
- name: Whitespace change
run: "echo ' ' >> ConsumePlugin/List.fs"
- name: Generate code
run: nix develop --command dotnet build
- name: Run Fantomas
run: nix run .#fantomas -- .
- name: Verify there is no diff
run: git diff --name-only --no-color --exit-code
check-nix-format:
runs-on: ubuntu-latest
steps:
@@ -174,8 +196,27 @@ jobs:
# Verify that there is exactly one nupkg in the artifact that would be NuGet published
run: if [[ $(find packed-attribute -maxdepth 1 -name 'WoofWare.Myriad.Plugins.Attributes.*.nupkg' -printf c | wc -c) -ne "1" ]]; then exit 1; fi
github-release-plugin-dry-run:
needs: [nuget-pack]
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v4
- name: Download NuGet artifact (plugin)
uses: actions/download-artifact@v4
with:
name: nuget-package-plugin
- name: Download NuGet artifact (attribute)
uses: actions/download-artifact@v4
with:
name: nuget-package-attribute
- name: Tag and release plugin
env:
DRY_RUN: 1
GITHUB_TOKEN: mock-token
run: sh .github/workflows/tag.sh
all-required-checks-complete:
needs: [check-dotnet-format, check-nix-format, build, build-nix, linkcheck, flake-check, analyzers, nuget-pack, expected-pack]
needs: [check-dotnet-format, check-nix-format, check-accurate-generations, build, build-nix, linkcheck, flake-check, analyzers, nuget-pack, expected-pack, github-release-plugin-dry-run]
runs-on: ubuntu-latest
steps:
- run: echo "All required checks complete."

View File

@@ -1,6 +1,13 @@
#!/bin/sh
#!/bin/bash
find . -maxdepth 1 -type f -name '*.nupkg' -exec sh -c 'tag=$(basename "$1" .nupkg); git tag "$tag"; git push origin "$tag"' shell {} \;
echo "Dry-run? $DRY_RUN!"
find . -maxdepth 1 -type f ! -name "$(printf "*\n*")" -name '*.nupkg' | while IFS= read -r file
do
tag=$(basename "$file" .nupkg)
git tag "$tag"
${DRY_RUN:+echo} git push origin "$tag"
done
export TAG
TAG=$(find . -maxdepth 1 -type f -name 'WoofWare.Myriad.Plugins.*.nupkg' -exec sh -c 'basename "$1" .nupkg' shell {} \; | grep -v Attributes)
@@ -14,4 +21,100 @@ case "$TAG" in
esac
# target_commitish empty indicates the repo default branch
curl -L -X POST -H "Accept: application/vnd.github+json" -H "Authorization: Bearer $GITHUB_TOKEN" -H "X-GitHub-Api-Version: 2022-11-28" https://api.github.com/repos/Smaug123/WoofWare.Myriad/releases -d '{"tag_name":"'"$TAG"'","target_commitish":"","name":"'"$TAG"'","draft":false,"prerelease":false,"generate_release_notes":false}'
curl_body='{"tag_name":"'"$TAG"'","target_commitish":"","name":"'"$TAG"'","draft":false,"prerelease":false,"generate_release_notes":false}'
echo "cURL body: $curl_body"
failed_output=$(cat <<'EOF'
{
"message": "Validation Failed",
"errors": [
{
"resource": "Release",
"code": "already_exists",
"field": "tag_name"
}
],
"documentation_url": "https://docs.github.com/rest/releases/releases#create-a-release"
}
EOF
)
success_output=$(cat <<'EOF'
{
"url": "https://api.github.com/repos/Smaug123/WoofWare.Myriad/releases/158152116",
"assets_url": "https://api.github.com/repos/Smaug123/WoofWare.Myriad/releases/158152116/assets",
"upload_url": "https://uploads.github.com/repos/Smaug123/WoofWare.Myriad/releases/158152116/assets{?name,label}",
"html_url": "https://github.com/Smaug123/WoofWare.Myriad/releases/tag/WoofWare.Myriad.Plugins.2.1.30",
"id": 158152116,
"author": {
"login": "github-actions[bot]",
"id": 41898282,
"node_id": "MDM6Qm90NDE4OTgyODI=",
"avatar_url": "https://avatars.githubusercontent.com/in/15368?v=4",
"gravatar_id": "",
"url": "https://api.github.com/users/github-actions%5Bbot%5D",
"html_url": "https://github.com/apps/github-actions",
"followers_url": "https://api.github.com/users/github-actions%5Bbot%5D/followers",
"following_url": "https://api.github.com/users/github-actions%5Bbot%5D/following{/other_user}",
"gists_url": "https://api.github.com/users/github-actions%5Bbot%5D/gists{/gist_id}",
"starred_url": "https://api.github.com/users/github-actions%5Bbot%5D/starred{/owner}{/repo}",
"subscriptions_url": "https://api.github.com/users/github-actions%5Bbot%5D/subscriptions",
"organizations_url": "https://api.github.com/users/github-actions%5Bbot%5D/orgs",
"repos_url": "https://api.github.com/users/github-actions%5Bbot%5D/repos",
"events_url": "https://api.github.com/users/github-actions%5Bbot%5D/events{/privacy}",
"received_events_url": "https://api.github.com/users/github-actions%5Bbot%5D/received_events",
"type": "Bot",
"site_admin": false
},
"node_id": "RE_kwDOJfksgc4JbTW0",
"tag_name": "WoofWare.Myriad.Plugins.2.1.30",
"target_commitish": "main",
"name": "WoofWare.Myriad.Plugins.2.1.30",
"draft": false,
"prerelease": false,
"created_at": "2024-05-30T11:00:55Z",
"published_at": "2024-05-30T11:03:02Z",
"assets": [
],
"tarball_url": "https://api.github.com/repos/Smaug123/WoofWare.Myriad/tarball/WoofWare.Myriad.Plugins.2.1.30",
"zipball_url": "https://api.github.com/repos/Smaug123/WoofWare.Myriad/zipball/WoofWare.Myriad.Plugins.2.1.30",
"body": null
}
EOF
)
HANDLE_OUTPUT=''
handle_error() {
ERROR_OUTPUT="$1"
exit_message=$(echo "$ERROR_OUTPUT" | jq -r --exit-status 'if .errors | length == 1 then .errors[0].code else null end')
if [ "$exit_message" = "already_exists" ] ; then
HANDLE_OUTPUT="Did not create GitHub release because it already exists at this version."
else
echo "Unexpected error output from curl: $(cat curl_output.json)"
echo "JQ output: $(exit_message)"
exit 2
fi
}
run_tests() {
handle_error "$failed_output"
if [ "$HANDLE_OUTPUT" != "Did not create GitHub release because it already exists at this version." ]; then
echo "Bad output from handler: $HANDLE_OUTPUT"
exit 3
fi
HANDLE_OUTPUT=''
echo "Tests passed."
}
run_tests
if [ "$DRY_RUN" != 1 ] ; then
if curl --fail-with-body -L -X POST -H "Accept: application/vnd.github+json" -H "Authorization: Bearer $GITHUB_TOKEN" -H "X-GitHub-Api-Version: 2022-11-28" https://api.github.com/repos/Smaug123/WoofWare.Myriad/releases -d "$curl_body" > curl_output.json; then
echo "Curl succeeded."
else
handle_error "$(cat curl_output.json)"
echo "$HANDLE_OUTPUT"
fi
fi

View File

@@ -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) ->

View File

@@ -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

View File

@@ -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
[<AutoOpen>]
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<string> 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<int> arg1)
node.Add ("data", dataNode)
node :> _
namespace ConsumePlugin

View File

@@ -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) ->

View File

@@ -27,3 +27,9 @@ type JsonRecordTypeWithBoth =
E : string array
F : int[]
}
[<WoofWare.Myriad.Plugins.JsonSerialize true>]
type FirstDu =
| EmptyCase
| Case1 of data : string
| Case2 of record : JsonRecordTypeWithBoth * i : int

View File

@@ -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.

View File

@@ -3,5 +3,13 @@
"publicReleaseRefSpec": [
"^refs/heads/main$"
],
"pathFilters": null
}
"pathFilters": [
":/README.md",
":/LICENSE",
":/WoofWare.Myriad.Plugins/logo.png",
":/Directory.Build.props",
":/global.json",
"./",
"^./Test"
]
}

View File

@@ -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

View File

@@ -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<Ident> 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
@@ -566,61 +554,65 @@ 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, 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 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 +626,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 +667,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

View File

@@ -117,15 +117,13 @@ module internal JsonSerializeGenerator =
SynExpr.CreateIdentString "arr"
],
range0,
{
InKeyword = None
}
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
@@ -188,9 +186,7 @@ module internal JsonSerializeGenerator =
SynExpr.CreateIdentString "ret"
],
range0,
{
InKeyword = None
}
SynExprLetOrUseTrivia.empty
)
|> SynExpr.createLambda "field"
| _ ->
@@ -204,22 +200,50 @@ module internal JsonSerializeGenerator =
/// propertyName is probably a string literal, but it could be a [<Literal>] 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 =
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)
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
/// `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 =
@@ -227,7 +251,6 @@ module internal JsonSerializeGenerator =
SynType.LongIdent (SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
)
let inputArg = Ident.Create "input"
let functionName = Ident.Create "toJsonNode"
let inputVal =
@@ -245,7 +268,7 @@ module internal JsonSerializeGenerator =
else
None
let thisIdOpt = if spec.ExtensionMethods then None else Some inputArg
let thisIdOpt = if spec.ExtensionMethods then None else Some inputArgName
SynValData.SynValData (
memberFlags,
@@ -253,62 +276,6 @@ module internal JsonSerializeGenerator =
thisIdOpt
)
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)
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 ],
None,
None,
SynArgPats.Empty,
None,
range0
)
createSerializeRhs 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
(SynLongIdent.CreateFromLongIdent [ id ], true),
Some (SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ id ]))
)
|> AstHelper.instantiateRecord
let assignments = assignments |> SynExpr.CreateSequential
let assignments =
SynExpr.LetOrUse (
false,
@@ -327,13 +294,11 @@ module internal JsonSerializeGenerator =
],
SynExpr.CreateSequential
[
SynExpr.Do (assignments, range0)
populateNode
SynExpr.Upcast (SynExpr.CreateIdentString "node", SynType.Anon range0, range0)
],
range0,
{
InKeyword = None
}
SynExprLetOrUseTrivia.empty
)
let pattern =
@@ -344,7 +309,7 @@ module internal JsonSerializeGenerator =
SynArgPats.Pats
[
SynPat.CreateTyped (
SynPat.CreateNamed inputArg,
SynPat.CreateNamed inputArgName,
SynType.LongIdent (SynLongIdent.CreateFromLongIdent typeName)
)
|> SynPat.CreateParen
@@ -406,7 +371,116 @@ module internal JsonSerializeGenerator =
SynModuleDecl.CreateLet [ binding ]
let createRecordModule
let recordModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (fields : SynField list) =
let inputArg = Ident.Create "input"
let fields = fields |> List.map SynField.extractWithIdent
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 inputArg = Ident.Create "input"
let fields = cases |> List.map SynUnionCase.extract
fields
|> List.map (fun unionCase ->
let propertyName = getPropertyName unionCase.Ident unionCase.Attrs
let caseNames = unionCase.Fields |> List.mapi (fun i _ -> Ident.Create $"arg%i{i}")
let argPats = SynArgPats.create caseNames
let pattern =
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent (typeName @ [ unionCase.Ident ]),
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 =
(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)
(opens : SynOpenDeclTarget list)
(spec : JsonSerializeOutputSpec)
@@ -415,60 +489,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 +558,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 +601,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

View File

@@ -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<Ident> 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 =

View File

@@ -0,0 +1,18 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
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

View File

@@ -0,0 +1,10 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.SyntaxTrivia
[<RequireQualifiedAccess>]
module internal SynExprLetOrUseTrivia =
let empty : SynExprLetOrUseTrivia =
{
InKeyword = None
}

View 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
)

View 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
}

View File

@@ -27,9 +27,13 @@
<Compile Include="List.fs"/>
<Compile Include="Ident.fs" />
<Compile Include="AstHelper.fs"/>
<Compile Include="SynExpr.fs" />
<Compile Include="SynType.fs"/>
<Compile Include="SynAttribute.fs"/>
<Compile Include="SynExpr\SynExpr.fs" />
<Compile Include="SynExpr\SynType.fs" />
<Compile Include="SynExpr\SynAttribute.fs" />
<Compile Include="SynExpr\SynArgPats.fs" />
<Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" />
<Compile Include="SynExpr\SynField.fs" />
<Compile Include="SynExpr\SynUnionCase.fs" />
<Compile Include="RemoveOptionsGenerator.fs"/>
<Compile Include="InterfaceMockGenerator.fs"/>
<Compile Include="JsonSerializeGenerator.fs"/>

View File

@@ -3,5 +3,10 @@
"publicReleaseRefSpec": [
"^refs/heads/main$"
],
"pathFilters": null
}
"pathFilters": [
":/",
":^WoofWare.Myriad.Plugins.Test/",
":^WoofWare.Myriad.Plugins.Attributes/Test/",
":^/.github/"
]
}