Compare commits

...

24 Commits

Author SHA1 Message Date
Patrick Stevens
85929d49d5 Support units of measure in JsonParse (#170) 2024-06-24 23:23:23 +01:00
dependabot[bot]
db4694f6e7 Bump actions/attest-build-provenance from 1.0.0 to 1.3.2 (#169)
Bumps [actions/attest-build-provenance](https://github.com/actions/attest-build-provenance) from 1.0.0 to 1.3.2.
- [Release notes](https://github.com/actions/attest-build-provenance/releases)
- [Changelog](https://github.com/actions/attest-build-provenance/blob/main/RELEASE.md)
- [Commits](897ed5eab6...bdd51370e0)

---
updated-dependencies:
- dependency-name: actions/attest-build-provenance
  dependency-type: direct:production
  update-type: version-update:semver-minor
...

Signed-off-by: dependabot[bot] <support@github.com>
Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com>
2024-06-24 18:55:05 +01:00
Patrick Stevens
669eccbdef Nudge README to bump the pipeline (#168) 2024-06-17 23:17:34 +01:00
Patrick Stevens
1bb87e55da Attest contents of packages (#167) 2024-06-17 23:08:36 +01:00
Patrick Stevens
4901e7cdf4 Add visibility modifiers in JsonParse/Serialize (#165) 2024-06-15 21:03:59 +01:00
dependabot[bot]
68bd4bc1fd Bump fantomas from 6.3.7 to 6.3.9 (#162)
* Bump fantomas from 6.3.7 to 6.3.9

Bumps [fantomas](https://github.com/fsprojects/fantomas) from 6.3.7 to 6.3.9.
- [Release notes](https://github.com/fsprojects/fantomas/releases)
- [Changelog](https://github.com/fsprojects/fantomas/blob/main/CHANGELOG.md)
- [Commits](https://github.com/fsprojects/fantomas/compare/v6.3.7...v6.3.9)

---
updated-dependencies:
- dependency-name: fantomas
  dependency-type: direct:production
  update-type: version-update:semver-patch
...

Signed-off-by: dependabot[bot] <support@github.com>

* Deps

---------

Signed-off-by: dependabot[bot] <support@github.com>
Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com>
Co-authored-by: Smaug123 <3138005+Smaug123@users.noreply.github.com>
2024-06-10 18:04:02 +01:00
dependabot[bot]
8da0fd01fe Bump Nerdbank.GitVersioning from 3.6.133 to 3.6.139 (#164)
* Bump ApiSurface from 4.0.40 to 4.0.41

Bumps [ApiSurface](https://github.com/G-Research/ApiSurface) from 4.0.40 to 4.0.41.
- [Release notes](https://github.com/G-Research/ApiSurface/releases)
- [Commits](https://github.com/G-Research/ApiSurface/compare/ApiSurface.4.0.40...ApiSurface.4.0.41)

---
updated-dependencies:
- dependency-name: ApiSurface
  dependency-type: direct:production
  update-type: version-update:semver-patch
...

Signed-off-by: dependabot[bot] <support@github.com>

* Bump Nerdbank.GitVersioning from 3.6.133 to 3.6.139

Bumps [Nerdbank.GitVersioning](https://github.com/dotnet/Nerdbank.GitVersioning) from 3.6.133 to 3.6.139.
- [Release notes](https://github.com/dotnet/Nerdbank.GitVersioning/releases)
- [Commits](https://github.com/dotnet/Nerdbank.GitVersioning/compare/v3.6.133...v3.6.139)

---
updated-dependencies:
- dependency-name: Nerdbank.GitVersioning
  dependency-type: direct:production
  update-type: version-update:semver-patch
...

Signed-off-by: dependabot[bot] <support@github.com>

* Deps

---------

Signed-off-by: dependabot[bot] <support@github.com>
Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com>
Co-authored-by: Smaug123 <3138005+Smaug123@users.noreply.github.com>
2024-06-10 12:25:03 +01:00
Patrick Stevens
18c7a2e920 Continuous integration to true (#161) 2024-06-09 10:56:11 +01:00
Patrick Stevens
f371ee59fe Say which mock function wasn't implemented (#160) 2024-06-04 18:36:49 +01:00
dependabot[bot]
f8296e54bc Bump fantomas from 6.3.4 to 6.3.7 (#158)
* Bump fantomas from 6.3.4 to 6.3.7

Bumps [fantomas](https://github.com/fsprojects/fantomas) from 6.3.4 to 6.3.7.
- [Release notes](https://github.com/fsprojects/fantomas/releases)
- [Changelog](https://github.com/fsprojects/fantomas/blob/main/CHANGELOG.md)
- [Commits](https://github.com/fsprojects/fantomas/compare/v6.3.4...v6.3.7)

---
updated-dependencies:
- dependency-name: fantomas
  dependency-type: direct:production
  update-type: version-update:semver-patch
...

Signed-off-by: dependabot[bot] <support@github.com>

* Upgrade Fantomas

---------

Signed-off-by: dependabot[bot] <support@github.com>
Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com>
Co-authored-by: Smaug123 <3138005+Smaug123@users.noreply.github.com>
2024-06-03 18:31:24 +01:00
Patrick Stevens
adf497c5db Tidy up a bit more (#156) 2024-06-01 15:57:53 +01:00
Patrick Stevens
04ecbe6002 Simplify flake (#155) 2024-05-31 21:58:33 +01:00
Patrick Stevens
7b14e52e9d Use our DSLs a bit more (#154) 2024-05-31 19:20:28 +01:00
Patrick Stevens
8e47f39efc Make more extensive use of our own DSLs (#153) 2024-05-31 16:54:05 +00:00
Patrick Stevens
6942ba42b9 Update changelog (#152) 2024-05-30 22:37:05 +01:00
Patrick Stevens
b98080690d Finish DU parsing (#151) 2024-05-30 22:27:15 +01:00
Patrick Stevens
81b7e5361d Another grand refactor (#150) 2024-05-30 20:34:53 +01:00
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
64 changed files with 3773 additions and 3777 deletions

View File

@@ -3,7 +3,7 @@
"isRoot": true,
"tools": {
"fantomas": {
"version": "6.3.4",
"version": "6.3.9",
"commands": [
"fantomas"
]

14
.github/workflows/assert-contents.sh vendored Normal file
View File

@@ -0,0 +1,14 @@
#!/bin/bash
echo "Unzipping version from NuGet"
ls from-nuget.nupkg
mkdir from-nuget && cp from-nuget.nupkg from-nuget/zip.zip && cd from-nuget && unzip zip.zip && rm zip.zip && cd - || exit 1
echo "Unzipping version from local build"
ls packed/
mkdir from-local && cp packed/*.nupkg from-local/zip.zip && cd from-local && unzip zip.zip && rm zip.zip && cd - || exit 1
cd from-local && find . -type f -exec sha256sum {} \; | sort > ../from-local.txt && cd .. || exit 1
cd from-nuget && find . -type f -and -not -name '.signature.p7s' -exec sha256sum {} \; | sort > ../from-nuget.txt && cd .. || exit 1
diff from-local.txt from-nuget.txt

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,17 +196,78 @@ 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."
nuget-publish:
attestation-attribute:
runs-on: ubuntu-latest
needs: [all-required-checks-complete]
if: ${{ !github.event.repository.fork && github.ref == 'refs/heads/main' }}
permissions:
id-token: write
attestations: write
contents: read
steps:
- name: Download NuGet artifact
uses: actions/download-artifact@v4
with:
name: nuget-package-attribute
path: packed
- name: Attest Build Provenance
uses: actions/attest-build-provenance@bdd51370e0416ac948727f861e03c2f05d32d78e # v1.3.2
with:
subject-path: "packed/*.nupkg"
attestation-plugin:
runs-on: ubuntu-latest
needs: [all-required-checks-complete]
if: ${{ !github.event.repository.fork && github.ref == 'refs/heads/main' }}
permissions:
id-token: write
attestations: write
contents: read
steps:
- name: Download NuGet artifact
uses: actions/download-artifact@v4
with:
name: nuget-package-plugin
path: packed
- name: Attest Build Provenance
uses: actions/attest-build-provenance@bdd51370e0416ac948727f861e03c2f05d32d78e # v1.3.2
with:
subject-path: "packed/*.nupkg"
nuget-publish-attribute:
runs-on: ubuntu-latest
if: ${{ !github.event.repository.fork && github.ref == 'refs/heads/main' }}
needs: [all-required-checks-complete]
environment: main-deploy
permissions:
id-token: write
attestations: write
contents: read
steps:
- uses: actions/checkout@v4
- name: Install Nix
@@ -192,20 +275,73 @@ jobs:
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
- name: Download NuGet artifact (plugin)
uses: actions/download-artifact@v4
with:
name: nuget-package-plugin
path: packed-plugin
- name: Publish to NuGet (plugin)
run: nix develop --command dotnet nuget push "packed-plugin/WoofWare.Myriad.Plugins.*.nupkg" --api-key ${{ secrets.NUGET_API_KEY }} --source https://api.nuget.org/v3/index.json --skip-duplicate
- name: Download NuGet artifact (attribute)
- name: Download NuGet artifact
uses: actions/download-artifact@v4
with:
name: nuget-package-attribute
path: packed-attribute
- name: Publish to NuGet (attribute)
run: nix develop --command dotnet nuget push "packed-attribute/WoofWare.Myriad.Plugins.Attributes.*.nupkg" --api-key ${{ secrets.NUGET_API_KEY }} --source https://api.nuget.org/v3/index.json --skip-duplicate
path: packed
- name: Publish to NuGet
id: publish-success
env:
NUGET_API_KEY: ${{ secrets.NUGET_API_KEY }}
run: 'nix develop --command bash ./.github/workflows/nuget-push.sh "packed/WoofWare.Myriad.Plugins.Attributes.*.nupkg"'
- name: Wait for availability
if: steps.publish-success.outputs.result == 'published'
env:
PACKAGE_VERSION: ${{ steps.publish-success.outputs.version }}
run: 'echo "$PACKAGE_VERSION" && while ! curl -L --fail -o from-nuget.nupkg "https://www.nuget.org/api/v2/package/WoofWare.Myriad.Plugins.Attributes/$PACKAGE_VERSION" ; do sleep 10; done'
# Astonishingly, NuGet.org considers it to be "more secure" to tamper with my package after upload (https://devblogs.microsoft.com/nuget/introducing-repository-signatures/).
# So we have to *re-attest* it after it's uploaded. Mind-blowing.
- name: Assert package contents
if: steps.publish-success.outputs.result == 'published'
run: 'bash ./.github/workflows/assert-contents.sh'
- name: Attest Build Provenance
if: steps.publish-success.outputs.result == 'published'
uses: actions/attest-build-provenance@bdd51370e0416ac948727f861e03c2f05d32d78e # v1.3.2
with:
subject-path: "from-nuget.nupkg"
nuget-publish-plugin:
runs-on: ubuntu-latest
if: ${{ !github.event.repository.fork && github.ref == 'refs/heads/main' }}
needs: [all-required-checks-complete]
environment: main-deploy
permissions:
id-token: write
attestations: write
contents: read
steps:
- uses: actions/checkout@v4
- name: Install Nix
uses: cachix/install-nix-action@V27
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
- name: Download NuGet artifact
uses: actions/download-artifact@v4
with:
name: nuget-package-plugin
path: packed
- name: Publish to NuGet
id: publish-success
env:
NUGET_API_KEY: ${{ secrets.NUGET_API_KEY }}
run: 'nix develop --command bash ./.github/workflows/nuget-push.sh "packed/WoofWare.Myriad.Plugins.*.nupkg"'
- name: Wait for availability
if: steps.publish-success.outputs.result == 'published'
env:
PACKAGE_VERSION: ${{ steps.publish-success.outputs.version }}
run: 'echo "$PACKAGE_VERSION" && while ! curl -L --fail -o from-nuget.nupkg "https://www.nuget.org/api/v2/package/WoofWare.Myriad.Plugins/$PACKAGE_VERSION" ; do sleep 10; done'
# Astonishingly, NuGet.org considers it to be "more secure" to tamper with my package after upload (https://devblogs.microsoft.com/nuget/introducing-repository-signatures/).
# So we have to *re-attest* it after it's uploaded. Mind-blowing.
- name: Assert package contents
if: steps.publish-success.outputs.result == 'published'
run: 'bash ./.github/workflows/assert-contents.sh'
- name: Attest Build Provenance
if: steps.publish-success.outputs.result == 'published'
uses: actions/attest-build-provenance@bdd51370e0416ac948727f861e03c2f05d32d78e # v1.3.2
with:
subject-path: "from-nuget.nupkg"
github-release-plugin:
runs-on: ubuntu-latest

24
.github/workflows/nuget-push.sh vendored Normal file
View File

@@ -0,0 +1,24 @@
#!/bin/bash
SOURCE_NUPKG=$(find . -type f -name '*.nupkg')
PACKAGE_VERSION=$(basename "$SOURCE_NUPKG" | rev | cut -d '.' -f 2-4 | rev)
echo "version=$PACKAGE_VERSION" >> "$GITHUB_OUTPUT"
tmp=$(mktemp)
if ! dotnet nuget push "$SOURCE_NUPKG" --api-key "$NUGET_API_KEY" --source https://api.nuget.org/v3/index.json > "$tmp" ; then
cat "$tmp"
if grep 'already exists and cannot be modified' "$tmp" ; then
echo "result=skipped" >> "$GITHUB_OUTPUT"
exit 0
else
echo "Unexpected failure to upload"
exit 1
fi
fi
cat "$tmp"
echo "result=published" >> "$GITHUB_OUTPUT"

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

24
.gitignore vendored
View File

@@ -1,12 +1,12 @@
bin/
obj/
/packages/
riderModule.iml
/_ReSharper.Caches/
.idea/
*.sln.DotSettings.user
.DS_Store
result
.analyzerpackages/
analysis.sarif
.direnv/
bin/
obj/
/packages/
riderModule.iml
/_ReSharper.Caches/
.idea/
*.sln.DotSettings.user
.DS_Store
result
.analyzerpackages/
analysis.sarif
.direnv/

View File

@@ -1,5 +1,19 @@
Notable changes are recorded here.
# WoofWare.Myriad.Plugins 2.1.45, WoofWare.Myriad.Plugins.Attributes 3.1.7
The NuGet packages are now attested to through [GitHub Attestations](https://github.blog/2024-05-02-introducing-artifact-attestations-now-in-public-beta/).
You can run `gh attestation verify ~/.nuget/packages/woofware.myriad.plugins/2.1.45/woofware.myriad.plugins.2.1.45.nupkg -o Smaug123`, for example, to verify with GitHub that the GitHub Actions pipeline on this repository produced a nupkg file with the same hash as the one you were served from NuGet.
# WoofWare.Myriad.Plugins 2.1.33
`JsonParse` can now deserialize the discriminated unions which `JsonSerialize` wrote out.
# WoofWare.Myriad.Plugins 2.1.32, WoofWare.Myriad.Plugins.Attributes 3.1.4
`JsonSerialize` can now serialize many discriminated unions.
(This operation is inherently opinionated, because JSON does not model discriminated unions.)
# WoofWare.Myriad.Plugins 2.1.20, WoofWare.Myriad.Plugins.Attributes 3.0.1
We now bundle copies of the RestEase attributes in `WoofWare.Myriad.Plugins.Attributes`, in case you don't want to take a dependency on RestEase.

View File

@@ -92,13 +92,13 @@ module TreeCata =
let arg0_0 = treeStack.[treeStack.Count - 1]
treeStack.RemoveAt (treeStack.Count - 1)
cata.TreeBuilder.Parent arg0_0 |> treeBuilderStack.Add
| Instruction.Tree_Pair (arg2_0) ->
| Instruction.Tree_Pair arg2_0 ->
let arg0_0 = treeStack.[treeStack.Count - 1]
treeStack.RemoveAt (treeStack.Count - 1)
let arg1_0 = treeStack.[treeStack.Count - 1]
treeStack.RemoveAt (treeStack.Count - 1)
cata.Tree.Pair arg0_0 arg1_0 arg2_0 |> treeStack.Add
| Instruction.Tree_Sequential (arg0_0) ->
| Instruction.Tree_Sequential arg0_0 ->
let arg0_0_len = arg0_0
let arg0_0 =

View File

@@ -129,7 +129,7 @@ module GiftCata =
| Gift.WithACard (arg0_0, message) ->
instructions.Add (Instruction.Gift_WithACard (message))
instructions.Add (Instruction.Process__Gift arg0_0)
| Instruction.Gift_Wrapped (arg1_0) ->
| Instruction.Gift_Wrapped arg1_0 ->
let arg0_0 = giftStack.[giftStack.Count - 1]
giftStack.RemoveAt (giftStack.Count - 1)
cata.Gift.Wrapped arg0_0 arg1_0 |> giftStack.Add
@@ -137,7 +137,7 @@ module GiftCata =
let arg0_0 = giftStack.[giftStack.Count - 1]
giftStack.RemoveAt (giftStack.Count - 1)
cata.Gift.Boxed arg0_0 |> giftStack.Add
| Instruction.Gift_WithACard (message) ->
| Instruction.Gift_WithACard message ->
let arg0_0 = giftStack.[giftStack.Count - 1]
giftStack.RemoveAt (giftStack.Count - 1)
cata.Gift.WithACard arg0_0 message |> giftStack.Add

View File

@@ -4,16 +4,42 @@
//------------------------------------------------------------------------------
namespace ConsumePlugin
open System.Text.Json.Serialization
/// Module containing JSON serializing methods for the InternalTypeNotExtensionSerial type
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module internal InternalTypeNotExtensionSerial =
/// Serialize to a JSON node
let toJsonNode (input : InternalTypeNotExtensionSerial) : System.Text.Json.Nodes.JsonNode =
let node = System.Text.Json.Nodes.JsonObject ()
do node.Add ((Literals.something), System.Text.Json.Nodes.JsonValue.Create<string> input.InternalThing2)
node :> _
namespace ConsumePlugin
open System.Text.Json.Serialization
/// Module containing JSON serializing extension members for the InternalTypeExtension type
[<AutoOpen>]
module internal InternalTypeExtensionJsonSerializeExtension =
/// Extension methods for JSON parsing
type InternalTypeExtension with
/// Serialize to a JSON node
static member toJsonNode (input : InternalTypeExtension) : System.Text.Json.Nodes.JsonNode =
let node = System.Text.Json.Nodes.JsonObject ()
do node.Add ((Literals.something), System.Text.Json.Nodes.JsonValue.Create<string> input.ExternalThing)
node :> _
namespace ConsumePlugin
/// Module containing JSON parsing methods for the InnerType type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module InnerType =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : InnerType =
let Thing =
let arg_0 =
(match node.[(Literals.something)] with
| null ->
raise (
@@ -26,17 +52,16 @@ module InnerType =
.GetValue<string> ()
{
Thing = Thing
Thing = arg_0
}
namespace ConsumePlugin
/// Module containing JSON parsing methods for the JsonRecordType type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JsonRecordType =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JsonRecordType =
let F =
let arg_5 =
(match node.["f"] with
| null ->
raise (
@@ -49,7 +74,7 @@ module JsonRecordType =
|> Seq.map (fun elt -> elt.AsValue().GetValue<int> ())
|> Array.ofSeq
let E =
let arg_4 =
(match node.["e"] with
| null ->
raise (
@@ -62,7 +87,7 @@ module JsonRecordType =
|> Seq.map (fun elt -> elt.AsValue().GetValue<string> ())
|> Array.ofSeq
let D =
let arg_3 =
InnerType.jsonParse (
match node.["d"] with
| null ->
@@ -74,7 +99,7 @@ module JsonRecordType =
| v -> v
)
let C =
let arg_2 =
(match node.["hi"] with
| null ->
raise (
@@ -87,7 +112,7 @@ module JsonRecordType =
|> Seq.map (fun elt -> elt.AsValue().GetValue<int> ())
|> List.ofSeq
let B =
let arg_1 =
(match node.["another-thing"] with
| null ->
raise (
@@ -99,7 +124,7 @@ module JsonRecordType =
.AsValue()
.GetValue<string> ()
let A =
let arg_0 =
(match node.["a"] with
| null ->
raise (
@@ -112,15 +137,62 @@ module JsonRecordType =
.GetValue<int> ()
{
A = A
B = B
C = C
D = D
E = E
F = F
A = arg_0
B = arg_1
C = arg_2
D = arg_3
E = arg_4
F = arg_5
}
namespace ConsumePlugin
/// Module containing JSON parsing methods for the InternalTypeNotExtension type
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module internal InternalTypeNotExtension =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : InternalTypeNotExtension =
let arg_0 =
(match node.[(Literals.something)] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ((Literals.something))
)
)
| v -> v)
.AsValue()
.GetValue<string> ()
{
InternalThing = arg_0
}
namespace ConsumePlugin
/// Module containing JSON parsing extension members for the InternalTypeExtension type
[<AutoOpen>]
module internal InternalTypeExtensionJsonParseExtension =
/// Extension methods for JSON parsing
type InternalTypeExtension with
/// Parse from a JSON node.
static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : InternalTypeExtension =
let arg_0 =
(match node.[(Literals.something)] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ((Literals.something))
)
)
| v -> v)
.AsValue()
.GetValue<string> ()
{
ExternalThing = arg_0
}
namespace ConsumePlugin
/// Module containing JSON parsing extension members for the ToGetExtensionMethod type
[<AutoOpen>]
module ToGetExtensionMethodJsonParseExtension =
@@ -129,9 +201,9 @@ module ToGetExtensionMethodJsonParseExtension =
/// Parse from a JSON node.
static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : ToGetExtensionMethod =
let Whiskey = System.Numerics.BigInteger.Parse (node.["whiskey"].ToJsonString ())
let arg_20 = System.Numerics.BigInteger.Parse (node.["whiskey"].ToJsonString ())
let Victor =
let arg_19 =
(match node.["victor"] with
| null ->
raise (
@@ -143,7 +215,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.Char> ()
let Uniform =
let arg_18 =
(match node.["uniform"] with
| null ->
raise (
@@ -155,7 +227,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.Decimal> ()
let Tango =
let arg_17 =
(match node.["tango"] with
| null ->
raise (
@@ -167,7 +239,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.SByte> ()
let Quebec =
let arg_16 =
(match node.["quebec"] with
| null ->
raise (
@@ -179,7 +251,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.Byte> ()
let Papa =
let arg_15 =
(match node.["papa"] with
| null ->
raise (
@@ -191,7 +263,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.Byte> ()
let Oscar =
let arg_14 =
(match node.["oscar"] with
| null ->
raise (
@@ -203,7 +275,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.SByte> ()
let November =
let arg_13 =
(match node.["november"] with
| null ->
raise (
@@ -215,7 +287,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.UInt16> ()
let Mike =
let arg_12 =
(match node.["mike"] with
| null ->
raise (
@@ -227,7 +299,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.Int16> ()
let Lima =
let arg_11 =
(match node.["lima"] with
| null ->
raise (
@@ -239,7 +311,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.UInt32> ()
let Kilo =
let arg_10 =
(match node.["kilo"] with
| null ->
raise (
@@ -251,7 +323,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.Int32> ()
let Juliette =
let arg_9 =
(match node.["juliette"] with
| null ->
raise (
@@ -263,7 +335,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.UInt32> ()
let India =
let arg_8 =
(match node.["india"] with
| null ->
raise (
@@ -275,7 +347,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<int> ()
let Hotel =
let arg_7 =
(match node.["hotel"] with
| null ->
raise (
@@ -287,7 +359,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.UInt64> ()
let Golf =
let arg_6 =
(match node.["golf"] with
| null ->
raise (
@@ -299,7 +371,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.Int64> ()
let Foxtrot =
let arg_5 =
(match node.["foxtrot"] with
| null ->
raise (
@@ -311,7 +383,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.Double> ()
let Echo =
let arg_4 =
(match node.["echo"] with
| null ->
raise (
@@ -323,7 +395,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.Single> ()
let Delta =
let arg_3 =
(match node.["delta"] with
| null ->
raise (
@@ -335,7 +407,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<System.Single> ()
let Charlie =
let arg_2 =
(match node.["charlie"] with
| null ->
raise (
@@ -347,7 +419,7 @@ module ToGetExtensionMethodJsonParseExtension =
.AsValue()
.GetValue<float> ()
let Bravo =
let arg_1 =
(match node.["bravo"] with
| null ->
raise (
@@ -360,7 +432,7 @@ module ToGetExtensionMethodJsonParseExtension =
.GetValue<string> ()
|> System.Uri
let Alpha =
let arg_0 =
(match node.["alpha"] with
| null ->
raise (
@@ -373,25 +445,25 @@ module ToGetExtensionMethodJsonParseExtension =
.GetValue<string> ()
{
Alpha = Alpha
Bravo = Bravo
Charlie = Charlie
Delta = Delta
Echo = Echo
Foxtrot = Foxtrot
Golf = Golf
Hotel = Hotel
India = India
Juliette = Juliette
Kilo = Kilo
Lima = Lima
Mike = Mike
November = November
Oscar = Oscar
Papa = Papa
Quebec = Quebec
Tango = Tango
Uniform = Uniform
Victor = Victor
Whiskey = Whiskey
Alpha = arg_0
Bravo = arg_1
Charlie = arg_2
Delta = arg_3
Echo = arg_4
Foxtrot = arg_5
Golf = arg_6
Hotel = arg_7
India = arg_8
Juliette = arg_9
Kilo = arg_10
Lima = arg_11
Mike = arg_12
November = arg_13
Oscar = arg_14
Papa = arg_15
Quebec = arg_16
Tango = arg_17
Uniform = arg_18
Victor = arg_19
Whiskey = arg_20
}

View File

@@ -19,9 +19,9 @@ type internal PublicTypeMock =
/// An implementation where every method throws.
static member Empty : PublicTypeMock =
{
Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem3 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem1 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem1"))
Mem2 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem2"))
Mem3 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem3"))
}
interface IPublicType with
@@ -44,9 +44,9 @@ type public PublicTypeInternalFalseMock =
/// An implementation where every method throws.
static member Empty : PublicTypeInternalFalseMock =
{
Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem3 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem1 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem1"))
Mem2 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem2"))
Mem3 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem3"))
}
interface IPublicTypeInternalFalse with
@@ -68,8 +68,8 @@ type internal InternalTypeMock =
/// An implementation where every method throws.
static member Empty : InternalTypeMock =
{
Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem1 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem1"))
Mem2 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem2"))
}
interface InternalType with
@@ -90,8 +90,8 @@ type private PrivateTypeMock =
/// An implementation where every method throws.
static member Empty : PrivateTypeMock =
{
Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem1 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem1"))
Mem2 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem2"))
}
interface PrivateType with
@@ -112,8 +112,8 @@ type private PrivateTypeInternalFalseMock =
/// An implementation where every method throws.
static member Empty : PrivateTypeInternalFalseMock =
{
Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem1 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem1"))
Mem2 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem2"))
}
interface PrivateTypeInternalFalse with
@@ -133,7 +133,7 @@ type internal VeryPublicTypeMock<'a, 'b> =
/// An implementation where every method throws.
static member Empty () : VeryPublicTypeMock<'a, 'b> =
{
Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem1 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem1"))
}
interface VeryPublicType<'a, 'b> with
@@ -157,12 +157,12 @@ type internal CurriedMock<'a> =
/// An implementation where every method throws.
static member Empty () : CurriedMock<'a> =
{
Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem3 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem4 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem5 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem6 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem1 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem1"))
Mem2 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem2"))
Mem3 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem3"))
Mem4 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem4"))
Mem5 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem5"))
Mem6 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem6"))
}
interface Curried<'a> with
@@ -195,9 +195,9 @@ type internal TypeWithInterfaceMock =
/// An implementation where every method throws.
static member Empty : TypeWithInterfaceMock =
{
Dispose = (fun _ -> ())
Mem1 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Mem2 = (fun x -> raise (System.NotImplementedException "Unimplemented mock function"))
Dispose = (fun () -> ())
Mem1 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem1"))
Mem2 = (fun _ -> raise (System.NotImplementedException "Unimplemented mock function: Mem2"))
}
interface TypeWithInterface with

View File

@@ -41,12 +41,11 @@ module MemberJsonSerializeExtension =
namespace PureGym
/// Module containing JSON parsing methods for the GymOpeningHours type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module GymOpeningHours =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymOpeningHours =
let OpeningHours =
let arg_1 =
(match node.["openingHours"] with
| null ->
raise (
@@ -59,7 +58,7 @@ module GymOpeningHours =
|> Seq.map (fun elt -> elt.AsValue().GetValue<string> ())
|> List.ofSeq
let IsAlwaysOpen =
let arg_0 =
(match node.["isAlwaysOpen"] with
| null ->
raise (
@@ -72,18 +71,17 @@ module GymOpeningHours =
.GetValue<bool> ()
{
IsAlwaysOpen = IsAlwaysOpen
OpeningHours = OpeningHours
IsAlwaysOpen = arg_0
OpeningHours = arg_1
}
namespace PureGym
/// Module containing JSON parsing methods for the GymAccessOptions type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module GymAccessOptions =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymAccessOptions =
let QrCodeAccess =
let arg_1 =
(match node.["qrCodeAccess"] with
| null ->
raise (
@@ -95,7 +93,7 @@ module GymAccessOptions =
.AsValue()
.GetValue<bool> ()
let PinAccess =
let arg_0 =
(match node.["pinAccess"] with
| null ->
raise (
@@ -108,18 +106,17 @@ module GymAccessOptions =
.GetValue<bool> ()
{
PinAccess = PinAccess
QrCodeAccess = QrCodeAccess
PinAccess = arg_0
QrCodeAccess = arg_1
}
namespace PureGym
/// Module containing JSON parsing methods for the GymLocation type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module GymLocation =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymLocation =
let Latitude =
let arg_1 =
try
(match node.["latitude"] with
| null ->
@@ -151,8 +148,9 @@ module GymLocation =
reraise ()
else
reraise ()
|> LanguagePrimitives.FloatWithMeasure
let Longitude =
let arg_0 =
try
(match node.["longitude"] with
| null ->
@@ -186,18 +184,17 @@ module GymLocation =
reraise ()
{
Longitude = Longitude
Latitude = Latitude
Longitude = arg_0
Latitude = arg_1
}
namespace PureGym
/// Module containing JSON parsing methods for the GymAddress type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module GymAddress =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymAddress =
let Postcode =
let arg_5 =
(match node.["postcode"] with
| null ->
raise (
@@ -209,12 +206,12 @@ module GymAddress =
.AsValue()
.GetValue<string> ()
let County =
let arg_4 =
match node.["county"] with
| null -> None
| v -> v.AsValue().GetValue<string> () |> Some
let Town =
let arg_3 =
(match node.["town"] with
| null ->
raise (
@@ -226,17 +223,17 @@ module GymAddress =
.AsValue()
.GetValue<string> ()
let AddressLine3 =
let arg_2 =
match node.["addressLine3"] with
| null -> None
| v -> v.AsValue().GetValue<string> () |> Some
let AddressLine2 =
let arg_1 =
match node.["addressLine2"] with
| null -> None
| v -> v.AsValue().GetValue<string> () |> Some
let AddressLine1 =
let arg_0 =
(match node.["addressLine1"] with
| null ->
raise (
@@ -249,22 +246,21 @@ module GymAddress =
.GetValue<string> ()
{
AddressLine1 = AddressLine1
AddressLine2 = AddressLine2
AddressLine3 = AddressLine3
Town = Town
County = County
Postcode = Postcode
AddressLine1 = arg_0
AddressLine2 = arg_1
AddressLine3 = arg_2
Town = arg_3
County = arg_4
Postcode = arg_5
}
namespace PureGym
/// Module containing JSON parsing methods for the Gym type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module Gym =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : Gym =
let ReopenDate =
let arg_10 =
(match node.["reopenDate"] with
| null ->
raise (
@@ -276,7 +272,7 @@ module Gym =
.AsValue()
.GetValue<string> ()
let TimeZone =
let arg_9 =
(match node.["timeZone"] with
| null ->
raise (
@@ -288,7 +284,7 @@ module Gym =
.AsValue()
.GetValue<string> ()
let Location =
let arg_8 =
GymLocation.jsonParse (
match node.["location"] with
| null ->
@@ -300,7 +296,7 @@ module Gym =
| v -> v
)
let AccessOptions =
let arg_7 =
GymAccessOptions.jsonParse (
match node.["accessOptions"] with
| null ->
@@ -312,7 +308,7 @@ module Gym =
| v -> v
)
let GymOpeningHours =
let arg_6 =
GymOpeningHours.jsonParse (
match node.["gymOpeningHours"] with
| null ->
@@ -324,7 +320,7 @@ module Gym =
| v -> v
)
let EmailAddress =
let arg_5 =
(match node.["emailAddress"] with
| null ->
raise (
@@ -336,7 +332,7 @@ module Gym =
.AsValue()
.GetValue<string> ()
let PhoneNumber =
let arg_4 =
(match node.["phoneNumber"] with
| null ->
raise (
@@ -348,7 +344,7 @@ module Gym =
.AsValue()
.GetValue<string> ()
let Address =
let arg_3 =
GymAddress.jsonParse (
match node.["address"] with
| null ->
@@ -360,7 +356,7 @@ module Gym =
| v -> v
)
let Status =
let arg_2 =
(match node.["status"] with
| null ->
raise (
@@ -372,7 +368,7 @@ module Gym =
.AsValue()
.GetValue<int> ()
let Id =
let arg_1 =
(match node.["id"] with
| null ->
raise (
@@ -384,7 +380,7 @@ module Gym =
.AsValue()
.GetValue<int> ()
let Name =
let arg_0 =
(match node.["name"] with
| null ->
raise (
@@ -397,17 +393,17 @@ module Gym =
.GetValue<string> ()
{
Name = Name
Id = Id
Status = Status
Address = Address
PhoneNumber = PhoneNumber
EmailAddress = EmailAddress
GymOpeningHours = GymOpeningHours
AccessOptions = AccessOptions
Location = Location
TimeZone = TimeZone
ReopenDate = ReopenDate
Name = arg_0
Id = arg_1
Status = arg_2
Address = arg_3
PhoneNumber = arg_4
EmailAddress = arg_5
GymOpeningHours = arg_6
AccessOptions = arg_7
Location = arg_8
TimeZone = arg_9
ReopenDate = arg_10
}
namespace PureGym
@@ -419,7 +415,7 @@ module MemberJsonParseExtension =
/// Parse from a JSON node.
static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : Member =
let MemberStatus =
let arg_14 =
(match node.["memberStatus"] with
| null ->
raise (
@@ -431,7 +427,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<int> ()
let SuspendedReason =
let arg_13 =
(match node.["suspendedReason"] with
| null ->
raise (
@@ -443,7 +439,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<int> ()
let MembershipLevel =
let arg_12 =
(match node.["membershipLevel"] with
| null ->
raise (
@@ -455,7 +451,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<int> ()
let MembershipName =
let arg_11 =
(match node.["membershipName"] with
| null ->
raise (
@@ -467,7 +463,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<string> ()
let Postcode =
let arg_10 =
(match node.["postCode"] with
| null ->
raise (
@@ -479,7 +475,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<string> ()
let MobileNumber =
let arg_9 =
(match node.["mobileNumber"] with
| null ->
raise (
@@ -491,7 +487,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<string> ()
let DateOfBirth =
let arg_8 =
(match node.["dateofBirth"] with
| null ->
raise (
@@ -504,7 +500,7 @@ module MemberJsonParseExtension =
.GetValue<string> ()
|> System.DateOnly.Parse
let GymAccessPin =
let arg_7 =
(match node.["gymAccessPin"] with
| null ->
raise (
@@ -516,7 +512,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<string> ()
let EmailAddress =
let arg_6 =
(match node.["emailAddress"] with
| null ->
raise (
@@ -528,7 +524,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<string> ()
let HomeGymName =
let arg_5 =
(match node.["homeGymName"] with
| null ->
raise (
@@ -540,7 +536,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<string> ()
let HomeGymId =
let arg_4 =
(match node.["homeGymId"] with
| null ->
raise (
@@ -552,7 +548,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<int> ()
let LastName =
let arg_3 =
(match node.["lastName"] with
| null ->
raise (
@@ -564,7 +560,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<string> ()
let FirstName =
let arg_2 =
(match node.["firstName"] with
| null ->
raise (
@@ -576,7 +572,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<string> ()
let CompoundMemberId =
let arg_1 =
(match node.["compoundMemberId"] with
| null ->
raise (
@@ -588,7 +584,7 @@ module MemberJsonParseExtension =
.AsValue()
.GetValue<string> ()
let Id =
let arg_0 =
(match node.["id"] with
| null ->
raise (
@@ -601,31 +597,30 @@ module MemberJsonParseExtension =
.GetValue<int> ()
{
Id = Id
CompoundMemberId = CompoundMemberId
FirstName = FirstName
LastName = LastName
HomeGymId = HomeGymId
HomeGymName = HomeGymName
EmailAddress = EmailAddress
GymAccessPin = GymAccessPin
DateOfBirth = DateOfBirth
MobileNumber = MobileNumber
Postcode = Postcode
MembershipName = MembershipName
MembershipLevel = MembershipLevel
SuspendedReason = SuspendedReason
MemberStatus = MemberStatus
Id = arg_0
CompoundMemberId = arg_1
FirstName = arg_2
LastName = arg_3
HomeGymId = arg_4
HomeGymName = arg_5
EmailAddress = arg_6
GymAccessPin = arg_7
DateOfBirth = arg_8
MobileNumber = arg_9
Postcode = arg_10
MembershipName = arg_11
MembershipLevel = arg_12
SuspendedReason = arg_13
MemberStatus = arg_14
}
namespace PureGym
/// Module containing JSON parsing methods for the GymAttendance type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module GymAttendance =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : GymAttendance =
let MaximumCapacity =
let arg_8 =
(match node.["maximumCapacity"] with
| null ->
raise (
@@ -637,7 +632,7 @@ module GymAttendance =
.AsValue()
.GetValue<int> ()
let LastRefreshedPeopleInClasses =
let arg_7 =
(match node.["lastRefreshedPeopleInClasses"] with
| null ->
raise (
@@ -650,7 +645,7 @@ module GymAttendance =
.GetValue<string> ()
|> System.DateTime.Parse
let LastRefreshed =
let arg_6 =
(match node.["lastRefreshed"] with
| null ->
raise (
@@ -663,7 +658,7 @@ module GymAttendance =
.GetValue<string> ()
|> System.DateTime.Parse
let AttendanceTime =
let arg_5 =
(match node.["attendanceTime"] with
| null ->
raise (
@@ -676,7 +671,7 @@ module GymAttendance =
.GetValue<string> ()
|> System.DateTime.Parse
let IsApproximate =
let arg_4 =
(match node.["isApproximate"] with
| null ->
raise (
@@ -688,12 +683,12 @@ module GymAttendance =
.AsValue()
.GetValue<bool> ()
let TotalPeopleSuffix =
let arg_3 =
match node.["totalPeopleSuffix"] with
| null -> None
| v -> v.AsValue().GetValue<string> () |> Some
let TotalPeopleInClasses =
let arg_2 =
(match node.["totalPeopleInClasses"] with
| null ->
raise (
@@ -705,7 +700,7 @@ module GymAttendance =
.AsValue()
.GetValue<int> ()
let TotalPeopleInGym =
let arg_1 =
(match node.["totalPeopleInGym"] with
| null ->
raise (
@@ -717,7 +712,7 @@ module GymAttendance =
.AsValue()
.GetValue<int> ()
let Description =
let arg_0 =
(match node.["description"] with
| null ->
raise (
@@ -730,25 +725,24 @@ module GymAttendance =
.GetValue<string> ()
{
Description = Description
TotalPeopleInGym = TotalPeopleInGym
TotalPeopleInClasses = TotalPeopleInClasses
TotalPeopleSuffix = TotalPeopleSuffix
IsApproximate = IsApproximate
AttendanceTime = AttendanceTime
LastRefreshed = LastRefreshed
LastRefreshedPeopleInClasses = LastRefreshedPeopleInClasses
MaximumCapacity = MaximumCapacity
Description = arg_0
TotalPeopleInGym = arg_1
TotalPeopleInClasses = arg_2
TotalPeopleSuffix = arg_3
IsApproximate = arg_4
AttendanceTime = arg_5
LastRefreshed = arg_6
LastRefreshedPeopleInClasses = arg_7
MaximumCapacity = arg_8
}
namespace PureGym
/// Module containing JSON parsing methods for the MemberActivityDto type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module MemberActivityDto =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : MemberActivityDto =
let LastRefreshed =
let arg_5 =
(match node.["lastRefreshed"] with
| null ->
raise (
@@ -761,7 +755,7 @@ module MemberActivityDto =
.GetValue<string> ()
|> System.DateTime.Parse
let IsEstimated =
let arg_4 =
(match node.["isEstimated"] with
| null ->
raise (
@@ -773,7 +767,7 @@ module MemberActivityDto =
.AsValue()
.GetValue<bool> ()
let TotalClasses =
let arg_3 =
(match node.["totalClasses"] with
| null ->
raise (
@@ -785,7 +779,7 @@ module MemberActivityDto =
.AsValue()
.GetValue<int> ()
let TotalVisits =
let arg_2 =
(match node.["totalVisits"] with
| null ->
raise (
@@ -797,7 +791,7 @@ module MemberActivityDto =
.AsValue()
.GetValue<int> ()
let AverageDuration =
let arg_1 =
(match node.["averageDuration"] with
| null ->
raise (
@@ -809,7 +803,7 @@ module MemberActivityDto =
.AsValue()
.GetValue<int> ()
let TotalDuration =
let arg_0 =
(match node.["totalDuration"] with
| null ->
raise (
@@ -822,22 +816,21 @@ module MemberActivityDto =
.GetValue<int> ()
{
TotalDuration = TotalDuration
AverageDuration = AverageDuration
TotalVisits = TotalVisits
TotalClasses = TotalClasses
IsEstimated = IsEstimated
LastRefreshed = LastRefreshed
TotalDuration = arg_0
AverageDuration = arg_1
TotalVisits = arg_2
TotalClasses = arg_3
IsEstimated = arg_4
LastRefreshed = arg_5
}
namespace PureGym
/// Module containing JSON parsing methods for the SessionsAggregate type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module SessionsAggregate =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : SessionsAggregate =
let Duration =
let arg_2 =
(match node.["Duration"] with
| null ->
raise (
@@ -849,7 +842,7 @@ module SessionsAggregate =
.AsValue()
.GetValue<int> ()
let Visits =
let arg_1 =
(match node.["Visits"] with
| null ->
raise (
@@ -861,7 +854,7 @@ module SessionsAggregate =
.AsValue()
.GetValue<int> ()
let Activities =
let arg_0 =
(match node.["Activities"] with
| null ->
raise (
@@ -874,19 +867,18 @@ module SessionsAggregate =
.GetValue<int> ()
{
Activities = Activities
Visits = Visits
Duration = Duration
Activities = arg_0
Visits = arg_1
Duration = arg_2
}
namespace PureGym
/// Module containing JSON parsing methods for the VisitGym type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module VisitGym =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : VisitGym =
let Status =
let arg_2 =
(match node.["Status"] with
| null ->
raise (
@@ -898,7 +890,7 @@ module VisitGym =
.AsValue()
.GetValue<string> ()
let Name =
let arg_1 =
(match node.["Name"] with
| null ->
raise (
@@ -910,7 +902,7 @@ module VisitGym =
.AsValue()
.GetValue<string> ()
let Id =
let arg_0 =
(match node.["Id"] with
| null ->
raise (
@@ -923,19 +915,18 @@ module VisitGym =
.GetValue<int> ()
{
Id = Id
Name = Name
Status = Status
Id = arg_0
Name = arg_1
Status = arg_2
}
namespace PureGym
/// Module containing JSON parsing methods for the Visit type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module Visit =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : Visit =
let Gym =
let arg_3 =
VisitGym.jsonParse (
match node.["Gym"] with
| null ->
@@ -947,7 +938,7 @@ module Visit =
| v -> v
)
let Duration =
let arg_2 =
(match node.["Duration"] with
| null ->
raise (
@@ -959,7 +950,7 @@ module Visit =
.AsValue()
.GetValue<int> ()
let StartTime =
let arg_1 =
(match node.["StartTime"] with
| null ->
raise (
@@ -972,7 +963,7 @@ module Visit =
.GetValue<string> ()
|> System.DateTime.Parse
let IsDurationEstimated =
let arg_0 =
(match node.["IsDurationEstimated"] with
| null ->
raise (
@@ -985,20 +976,19 @@ module Visit =
.GetValue<bool> ()
{
IsDurationEstimated = IsDurationEstimated
StartTime = StartTime
Duration = Duration
Gym = Gym
IsDurationEstimated = arg_0
StartTime = arg_1
Duration = arg_2
Gym = arg_3
}
namespace PureGym
/// Module containing JSON parsing methods for the SessionsSummary type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module SessionsSummary =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : SessionsSummary =
let ThisWeek =
let arg_1 =
SessionsAggregate.jsonParse (
match node.["ThisWeek"] with
| null ->
@@ -1010,7 +1000,7 @@ module SessionsSummary =
| v -> v
)
let Total =
let arg_0 =
SessionsAggregate.jsonParse (
match node.["Total"] with
| null ->
@@ -1023,18 +1013,17 @@ module SessionsSummary =
)
{
Total = Total
ThisWeek = ThisWeek
Total = arg_0
ThisWeek = arg_1
}
namespace PureGym
/// Module containing JSON parsing methods for the Sessions type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module Sessions =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : Sessions =
let Visits =
let arg_1 =
(match node.["Visits"] with
| null ->
raise (
@@ -1047,7 +1036,7 @@ module Sessions =
|> Seq.map (fun elt -> Visit.jsonParse elt)
|> List.ofSeq
let Summary =
let arg_0 =
SessionsSummary.jsonParse (
match node.["Summary"] with
| null ->
@@ -1060,18 +1049,17 @@ module Sessions =
)
{
Summary = Summary
Visits = Visits
Summary = arg_0
Visits = arg_1
}
namespace PureGym
/// Module containing JSON parsing methods for the UriThing type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module UriThing =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : UriThing =
let SomeUri =
let arg_0 =
(match node.["someUri"] with
| null ->
raise (
@@ -1085,5 +1073,5 @@ module UriThing =
|> System.Uri
{
SomeUri = SomeUri
SomeUri = arg_0
}

View File

@@ -17,8 +17,7 @@ open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module PureGymApi =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IPureGymApi =
@@ -1055,8 +1054,7 @@ open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module internal ApiWithoutBaseAddress =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IApiWithoutBaseAddress =
@@ -1107,8 +1105,7 @@ open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module ApiWithBasePath =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IApiWithBasePath =
@@ -1159,8 +1156,7 @@ open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module ApiWithBasePathAndAddress =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IApiWithBasePathAndAddress =
@@ -1205,8 +1201,7 @@ open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module ApiWithHeaders =
/// Create a REST client. The input functions will be re-evaluated on every HTTP request to obtain the required values for the corresponding header properties.
let make
@@ -1268,8 +1263,7 @@ open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module ApiWithHeaders2 =
/// Create a REST client. The input functions will be re-evaluated on every HTTP request to obtain the required values for the corresponding header properties.
let make

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
@@ -160,7 +191,7 @@ module InnerTypeWithBothJsonParseExtension =
/// Parse from a JSON node.
static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : InnerTypeWithBoth =
let ConcreteDict =
let arg_4 =
(match node.["concreteDict"] with
| null ->
raise (
@@ -178,7 +209,7 @@ module InnerTypeWithBothJsonParseExtension =
|> Seq.map System.Collections.Generic.KeyValuePair
|> System.Collections.Generic.Dictionary
let Dict =
let arg_3 =
(match node.["dict"] with
| null ->
raise (
@@ -195,7 +226,7 @@ module InnerTypeWithBothJsonParseExtension =
)
|> dict
let ReadOnlyDict =
let arg_2 =
(match node.["readOnlyDict"] with
| null ->
raise (
@@ -217,7 +248,7 @@ module InnerTypeWithBothJsonParseExtension =
)
|> readOnlyDict
let Map =
let arg_1 =
(match node.["map"] with
| null ->
raise (
@@ -234,7 +265,7 @@ module InnerTypeWithBothJsonParseExtension =
)
|> Map.ofSeq
let Thing =
let arg_0 =
(match node.[("it's-a-me")] with
| null ->
raise (
@@ -248,11 +279,11 @@ module InnerTypeWithBothJsonParseExtension =
|> System.Guid.Parse
{
Thing = Thing
Map = Map
ReadOnlyDict = ReadOnlyDict
Dict = Dict
ConcreteDict = ConcreteDict
Thing = arg_0
Map = arg_1
ReadOnlyDict = arg_2
Dict = arg_3
ConcreteDict = arg_4
}
namespace ConsumePlugin
@@ -264,7 +295,7 @@ module JsonRecordTypeWithBothJsonParseExtension =
/// Parse from a JSON node.
static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : JsonRecordTypeWithBoth =
let F =
let arg_5 =
(match node.["f"] with
| null ->
raise (
@@ -277,7 +308,7 @@ module JsonRecordTypeWithBothJsonParseExtension =
|> Seq.map (fun elt -> elt.AsValue().GetValue<int> ())
|> Array.ofSeq
let E =
let arg_4 =
(match node.["e"] with
| null ->
raise (
@@ -290,7 +321,7 @@ module JsonRecordTypeWithBothJsonParseExtension =
|> Seq.map (fun elt -> elt.AsValue().GetValue<string> ())
|> Array.ofSeq
let D =
let arg_3 =
InnerTypeWithBoth.jsonParse (
match node.["d"] with
| null ->
@@ -302,7 +333,7 @@ module JsonRecordTypeWithBothJsonParseExtension =
| v -> v
)
let C =
let arg_2 =
(match node.["c"] with
| null ->
raise (
@@ -315,7 +346,7 @@ module JsonRecordTypeWithBothJsonParseExtension =
|> Seq.map (fun elt -> elt.AsValue().GetValue<int> ())
|> List.ofSeq
let B =
let arg_1 =
(match node.["b"] with
| null ->
raise (
@@ -327,7 +358,7 @@ module JsonRecordTypeWithBothJsonParseExtension =
.AsValue()
.GetValue<string> ()
let A =
let arg_0 =
(match node.["a"] with
| null ->
raise (
@@ -340,10 +371,90 @@ module JsonRecordTypeWithBothJsonParseExtension =
.GetValue<int> ()
{
A = A
B = B
C = C
D = D
E = E
F = F
A = arg_0
B = arg_1
C = arg_2
D = arg_3
E = arg_4
F = arg_5
}
namespace ConsumePlugin
/// Module containing JSON parsing extension members for the FirstDu type
[<AutoOpen>]
module FirstDuJsonParseExtension =
/// Extension methods for JSON parsing
type FirstDu with
/// Parse from a JSON node.
static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : FirstDu =
let ty =
(match node.["type"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("type")
)
)
| v -> v)
|> (fun v -> v.GetValue<string> ())
match ty with
| "emptyCase" -> FirstDu.EmptyCase
| "case1" ->
let node =
(match node.["data"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("data")
)
)
| v -> v)
FirstDu.Case1 (
(match node.["data"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("data")
)
)
| v -> v)
.AsValue()
.GetValue<string> ()
)
| "case2" ->
let node =
(match node.["data"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("data")
)
)
| v -> v)
FirstDu.Case2 (
JsonRecordTypeWithBoth.jsonParse (
match node.["record"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("record")
)
)
| v -> v
),
(match node.["i"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("i")
)
)
| v -> v)
.AsValue()
.GetValue<int> ()
)
| v -> failwith ("Unrecognised 'type' field value: " + v)

View File

@@ -8,12 +8,11 @@
namespace ConsumePlugin
/// Module containing JSON parsing methods for the JwtVaultAuthResponse type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JwtVaultAuthResponse =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JwtVaultAuthResponse =
let NumUses =
let arg_10 =
(match node.["num_uses"] with
| null ->
raise (
@@ -25,7 +24,7 @@ module JwtVaultAuthResponse =
.AsValue()
.GetValue<int> ()
let Orphan =
let arg_9 =
(match node.["orphan"] with
| null ->
raise (
@@ -37,7 +36,7 @@ module JwtVaultAuthResponse =
.AsValue()
.GetValue<bool> ()
let EntityId =
let arg_8 =
(match node.["entity_id"] with
| null ->
raise (
@@ -49,7 +48,7 @@ module JwtVaultAuthResponse =
.AsValue()
.GetValue<string> ()
let TokenType =
let arg_7 =
(match node.["token_type"] with
| null ->
raise (
@@ -61,7 +60,7 @@ module JwtVaultAuthResponse =
.AsValue()
.GetValue<string> ()
let Renewable =
let arg_6 =
(match node.["renewable"] with
| null ->
raise (
@@ -73,7 +72,7 @@ module JwtVaultAuthResponse =
.AsValue()
.GetValue<bool> ()
let LeaseDuration =
let arg_5 =
(match node.["lease_duration"] with
| null ->
raise (
@@ -85,7 +84,7 @@ module JwtVaultAuthResponse =
.AsValue()
.GetValue<int> ()
let IdentityPolicies =
let arg_4 =
(match node.["identity_policies"] with
| null ->
raise (
@@ -98,7 +97,7 @@ module JwtVaultAuthResponse =
|> Seq.map (fun elt -> elt.AsValue().GetValue<string> ())
|> List.ofSeq
let TokenPolicies =
let arg_3 =
(match node.["token_policies"] with
| null ->
raise (
@@ -111,7 +110,7 @@ module JwtVaultAuthResponse =
|> Seq.map (fun elt -> elt.AsValue().GetValue<string> ())
|> List.ofSeq
let Policies =
let arg_2 =
(match node.["policies"] with
| null ->
raise (
@@ -124,7 +123,7 @@ module JwtVaultAuthResponse =
|> Seq.map (fun elt -> elt.AsValue().GetValue<string> ())
|> List.ofSeq
let Accessor =
let arg_1 =
(match node.["accessor"] with
| null ->
raise (
@@ -136,7 +135,7 @@ module JwtVaultAuthResponse =
.AsValue()
.GetValue<string> ()
let ClientToken =
let arg_0 =
(match node.["client_token"] with
| null ->
raise (
@@ -149,27 +148,26 @@ module JwtVaultAuthResponse =
.GetValue<string> ()
{
ClientToken = ClientToken
Accessor = Accessor
Policies = Policies
TokenPolicies = TokenPolicies
IdentityPolicies = IdentityPolicies
LeaseDuration = LeaseDuration
Renewable = Renewable
TokenType = TokenType
EntityId = EntityId
Orphan = Orphan
NumUses = NumUses
ClientToken = arg_0
Accessor = arg_1
Policies = arg_2
TokenPolicies = arg_3
IdentityPolicies = arg_4
LeaseDuration = arg_5
Renewable = arg_6
TokenType = arg_7
EntityId = arg_8
Orphan = arg_9
NumUses = arg_10
}
namespace ConsumePlugin
/// Module containing JSON parsing methods for the JwtVaultResponse type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JwtVaultResponse =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JwtVaultResponse =
let Auth =
let arg_4 =
JwtVaultAuthResponse.jsonParse (
match node.["auth"] with
| null ->
@@ -181,7 +179,7 @@ module JwtVaultResponse =
| v -> v
)
let LeaseDuration =
let arg_3 =
(match node.["lease_duration"] with
| null ->
raise (
@@ -193,7 +191,7 @@ module JwtVaultResponse =
.AsValue()
.GetValue<int> ()
let Renewable =
let arg_2 =
(match node.["renewable"] with
| null ->
raise (
@@ -205,7 +203,7 @@ module JwtVaultResponse =
.AsValue()
.GetValue<bool> ()
let LeaseId =
let arg_1 =
(match node.["lease_id"] with
| null ->
raise (
@@ -217,7 +215,7 @@ module JwtVaultResponse =
.AsValue()
.GetValue<string> ()
let RequestId =
let arg_0 =
(match node.["request_id"] with
| null ->
raise (
@@ -230,21 +228,20 @@ module JwtVaultResponse =
.GetValue<string> ()
{
RequestId = RequestId
LeaseId = LeaseId
Renewable = Renewable
LeaseDuration = LeaseDuration
Auth = Auth
RequestId = arg_0
LeaseId = arg_1
Renewable = arg_2
LeaseDuration = arg_3
Auth = arg_4
}
namespace ConsumePlugin
/// Module containing JSON parsing methods for the JwtSecretResponse type
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JwtSecretResponse =
/// Parse from a JSON node.
let jsonParse (node : System.Text.Json.Nodes.JsonNode) : JwtSecretResponse =
let Data8 =
let arg_11 =
(match node.["data8"] with
| null ->
raise (
@@ -262,7 +259,7 @@ module JwtSecretResponse =
|> Seq.map System.Collections.Generic.KeyValuePair
|> System.Collections.Generic.Dictionary
let Data7 =
let arg_10 =
(match node.["data7"] with
| null ->
raise (
@@ -279,7 +276,7 @@ module JwtSecretResponse =
)
|> Map.ofSeq
let Data6 =
let arg_9 =
(match node.["data6"] with
| null ->
raise (
@@ -296,7 +293,7 @@ module JwtSecretResponse =
)
|> dict
let Data5 =
let arg_8 =
(match node.["data5"] with
| null ->
raise (
@@ -313,7 +310,7 @@ module JwtSecretResponse =
)
|> readOnlyDict
let Data4 =
let arg_7 =
(match node.["data4"] with
| null ->
raise (
@@ -330,7 +327,7 @@ module JwtSecretResponse =
)
|> Map.ofSeq
let Data3 =
let arg_6 =
(match node.["data3"] with
| null ->
raise (
@@ -348,7 +345,7 @@ module JwtSecretResponse =
|> Seq.map System.Collections.Generic.KeyValuePair
|> System.Collections.Generic.Dictionary
let Data2 =
let arg_5 =
(match node.["data2"] with
| null ->
raise (
@@ -365,7 +362,7 @@ module JwtSecretResponse =
)
|> dict
let Data =
let arg_4 =
(match node.["data"] with
| null ->
raise (
@@ -382,7 +379,7 @@ module JwtSecretResponse =
)
|> readOnlyDict
let LeaseDuration =
let arg_3 =
(match node.["lease_duration"] with
| null ->
raise (
@@ -394,7 +391,7 @@ module JwtSecretResponse =
.AsValue()
.GetValue<int> ()
let Renewable =
let arg_2 =
(match node.["renewable"] with
| null ->
raise (
@@ -406,7 +403,7 @@ module JwtSecretResponse =
.AsValue()
.GetValue<bool> ()
let LeaseId =
let arg_1 =
(match node.["lease_id"] with
| null ->
raise (
@@ -418,7 +415,7 @@ module JwtSecretResponse =
.AsValue()
.GetValue<string> ()
let RequestId =
let arg_0 =
(match node.["request_id"] with
| null ->
raise (
@@ -431,18 +428,18 @@ module JwtSecretResponse =
.GetValue<string> ()
{
RequestId = RequestId
LeaseId = LeaseId
Renewable = Renewable
LeaseDuration = LeaseDuration
Data = Data
Data2 = Data2
Data3 = Data3
Data4 = Data4
Data5 = Data5
Data6 = Data6
Data7 = Data7
Data8 = Data8
RequestId = arg_0
LeaseId = arg_1
Renewable = arg_2
LeaseDuration = arg_3
Data = arg_4
Data2 = arg_5
Data3 = arg_6
Data4 = arg_7
Data5 = arg_8
Data6 = arg_9
Data7 = arg_10
Data8 = arg_11
}
namespace ConsumePlugin
@@ -455,8 +452,7 @@ open System.Threading.Tasks
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module VaultClient =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IVaultClient =
@@ -553,8 +549,7 @@ open System.Threading.Tasks
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module VaultClientNonExtensionMethod =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IVaultClientNonExtensionMethod =

View File

@@ -29,6 +29,28 @@ type JsonRecordType =
F : int[]
}
[<WoofWare.Myriad.Plugins.JsonParse>]
type internal InternalTypeNotExtension =
{
[<JsonPropertyName(Literals.something)>]
InternalThing : string
}
[<WoofWare.Myriad.Plugins.JsonSerialize>]
type internal InternalTypeNotExtensionSerial =
{
[<JsonPropertyName(Literals.something)>]
InternalThing2 : string
}
[<WoofWare.Myriad.Plugins.JsonParse true>]
[<WoofWare.Myriad.Plugins.JsonSerialize true>]
type internal InternalTypeExtension =
{
[<JsonPropertyName(Literals.something)>]
ExternalThing : string
}
[<WoofWare.Myriad.Plugins.JsonParse true>]
type ToGetExtensionMethod =
{

View File

@@ -50,7 +50,7 @@ module MyListCata =
}) ->
instructions.Add (Instruction.MyList_Cons (head))
instructions.Add (Instruction.Process__MyList tail)
| Instruction.MyList_Cons (head) ->
| Instruction.MyList_Cons head ->
let tail = myListStack.[myListStack.Count - 1]
myListStack.RemoveAt (myListStack.Count - 1)
cata.MyList.Cons head tail |> myListStack.Add
@@ -103,7 +103,7 @@ module MyList2Cata =
| MyList2.Cons (arg0_0, arg1_0) ->
instructions.Add (Instruction.MyList2_Cons (arg0_0))
instructions.Add (Instruction.Process__MyList2 arg1_0)
| Instruction.MyList2_Cons (arg0_0) ->
| Instruction.MyList2_Cons arg0_0 ->
let arg1_0 = myList2Stack.[myList2Stack.Count - 1]
myList2Stack.RemoveAt (myList2Stack.Count - 1)
cata.MyList2.Cons arg0_0 arg1_0 |> myList2Stack.Add

View File

@@ -19,13 +19,16 @@ type GymAccessOptions =
QrCodeAccess : bool
}
[<Measure>]
type measure
[<WoofWare.Myriad.Plugins.JsonParse>]
type GymLocation =
{
[<JsonNumberHandling(JsonNumberHandling.AllowReadingFromString)>]
Longitude : float
[<JsonNumberHandling(JsonNumberHandling.AllowReadingFromString)>]
Latitude : float
Latitude : float<measure>
}
[<WoofWare.Myriad.Plugins.JsonParse>]

View File

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

View File

@@ -10,19 +10,10 @@
<WarnOn>FS3388,FS3559</WarnOn>
</PropertyGroup>
<ItemGroup>
<PackageReference Include="Nerdbank.GitVersioning" Version="3.6.133" PrivateAssets="all"/>
<PackageReference Include="Microsoft.SourceLink.GitHub" Version="8.0.0" PrivateAssets="All"/>
<PackageReference Include="Nerdbank.GitVersioning" Version="3.6.139" PrivateAssets="all"/>
<SourceLinkGitHubHost Include="github.com" ContentUrl="https://raw.githubusercontent.com"/>
</ItemGroup>
<!--
SourceLink doesn't support F# deterministic builds out of the box,
so tell SourceLink that our source root is going to be remapped.
-->
<Target Name="MapSourceRoot" BeforeTargets="_GenerateSourceLinkFile" Condition="'$(SourceRootMappedPathsFeatureSupported)' != 'true'">
<ItemGroup>
<SourceRoot Update="@(SourceRoot)">
<MappedPath>Z:\CheckoutRoot\WoofWare.Myriad\</MappedPath>
</SourceRoot>
</ItemGroup>
</Target>
<PropertyGroup Condition="'$(GITHUB_ACTION)' != ''">
<ContinuousIntegrationBuild>true</ContinuousIntegrationBuild>
</PropertyGroup>
</Project>

View File

@@ -8,23 +8,20 @@
Some helpers in [Myriad](https://github.com/MoiraeSoftware/myriad/) which might be useful.
These are currently somewhat experimental, and I personally am their primary customer.
The `RemoveOptions` generator in particular is extremely half-baked.
Currently implemented:
* `JsonParse` (to stamp out `jsonParse : JsonNode -> 'T` methods).
* `JsonSerialize` (to stamp out `toJsonNode : 'T -> JsonNode` methods).
* `HttpClient` (to stamp out a [RestEase](https://github.com/canton7/RestEase)-style HTTP client).
* `GenerateMock` (to stamp out a record type corresponding to an interface, like a compile-time [Foq](https://github.com/fsprojects/Foq)).
* `CreateCatamorphism` (to stamp out a non-stack-overflowing [catamorphism](https://fsharpforfunandprofit.com/posts/recursive-types-and-folds/) for a discriminated union).
* `RemoveOptions` (to strip `option` modifiers from a type) - this one is particularly half-baked!
If you would like to ensure that your particular use-case remains unbroken, please do contribute tests to this repository.
The `ConsumePlugin` assembly contains a number of invocations of these source generators,
so you just need to add copies of your types to that assembly to ensure that I will at least notice if I break the build;
and if you add tests to `WoofWare.Myriad.Plugins.Test` then I will also notice if I break the runtime semantics of the generated code.
Currently implemented:
* `JsonParse` (to stamp out `jsonParse : JsonNode -> 'T` methods);
* `JsonSerialize` (to stamp out `toJsonNode : 'T -> JsonNode` methods);
* `RemoveOptions` (to strip `option` modifiers from a type).
* `HttpClient` (to stamp out a [RestEase](https://github.com/canton7/RestEase)-style HTTP client).
* `GenerateMock` (to stamp out a record type corresponding to an interface).
* `CreateCatamorphism` (to stamp out a non-stack-overflowing [catamorphism](https://fsharpforfunandprofit.com/posts/recursive-types-and-folds/) for a discriminated union).
## `JsonParse`
Takes records like this:
@@ -143,6 +140,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

@@ -12,7 +12,7 @@
</ItemGroup>
<ItemGroup>
<PackageReference Include="ApiSurface" Version="4.0.40" />
<PackageReference Include="ApiSurface" Version="4.0.41" />
<PackageReference Include="Microsoft.NET.Test.Sdk" Version="17.10.0"/>
<PackageReference Include="NUnit" Version="4.1.0"/>
<PackageReference Include="NUnit3TestAdapter" Version="4.5.0"/>

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

@@ -58,7 +58,7 @@ module PureGymDtos =
[
"""{"latitude": 1.0, "longitude": 3.0}""",
{
GymLocation.Latitude = 1.0
GymLocation.Latitude = 1.0<measure>
Longitude = 3.0
}
]
@@ -96,7 +96,7 @@ module PureGymDtos =
Location =
{
Longitude = -0.110252
Latitude = 51.480401
Latitude = 51.480401<measure>
}
TimeZone = "Europe/London"
ReopenDate = "2021-04-12T00:00:00+01 Europe/London"

View File

@@ -2,10 +2,9 @@ namespace WoofWare.Myriad.Plugins.Test
open System
open System.Collections.Generic
open System.IO
open System.Text
open System.Text.Json
open System.Text.Json.Nodes
open FsCheck.Random
open Microsoft.FSharp.Reflection
open NUnit.Framework
open FsCheck
open FsUnitTyped
@@ -124,3 +123,83 @@ module TestJsonSerde =
|> shouldEqual (
sprintf """{"it\u0027s-a-me":"%s","map":{},"readOnlyDict":{},"dict":{},"concreteDict":{}}""" guidStr
)
type Generators =
static member TestCase () =
{ new Arbitrary<InnerTypeWithBoth>() with
override x.Generator = innerGen 5
}
let sanitiseInner (r : InnerTypeWithBoth) : InnerTypeWithBoth =
{
Thing = r.Thing
Map = r.Map
ReadOnlyDict = r.ReadOnlyDict
Dict = r.Dict
ConcreteDict = r.ConcreteDict
}
let sanitiseRec (r : JsonRecordTypeWithBoth) : JsonRecordTypeWithBoth =
{
A = r.A
B = if isNull r.B then "<null>" else r.B
C =
if Object.ReferenceEquals (r.C, (null : obj)) then
[]
else
r.C
D = sanitiseInner r.D
E = if isNull r.E then [||] else r.E
F =
if Object.ReferenceEquals (r.F, (null : obj)) then
[||]
else
r.F
}
let duGen =
gen {
let! case = Gen.choose (0, 2)
match case with
| 0 -> return FirstDu.EmptyCase
| 1 ->
let! s = Arb.generate<NonNull<string>>
return FirstDu.Case1 s.Get
| 2 ->
let! i = Arb.generate<int>
let! record = outerGen
return FirstDu.Case2 (record, i)
| _ -> return failwith $"unexpected: %i{case}"
}
[<Test>]
let ``Discriminated union works`` () =
let property (du : FirstDu) : unit =
du
|> FirstDu.toJsonNode
|> fun s -> s.ToJsonString ()
|> JsonNode.Parse
|> FirstDu.jsonParse
|> shouldEqual du
property |> Prop.forAll (Arb.fromGen duGen) |> Check.QuickThrowOnFailure
[<Test>]
let ``DU generator covers all cases`` () =
let rand = Random ()
let cases = FSharpType.GetUnionCases typeof<FirstDu>
let counts = Array.zeroCreate<int> cases.Length
let decompose = FSharpValue.PreComputeUnionTagReader typeof<FirstDu>
let mutable i = 0
while i < 10_000 && Array.exists (fun i -> i = 0) counts do
let du = Gen.eval 10 (StdGen.StdGen (rand.Next (), rand.Next ())) duGen
let tag = decompose du
counts.[tag] <- counts.[tag] + 1
i <- i + 1
for i in counts do
i |> shouldBeGreaterThan 0

View File

@@ -12,7 +12,8 @@ module TestSurface =
let ``Ensure API surface has not been modified`` () = ApiSurface.assertIdentical assembly
[<Test>]
let ``Check version against remote`` () =
// https://github.com/nunit/nunit3-vs-adapter/issues/876
let CheckVersionAgainstRemote () =
MonotonicVersion.validate assembly "WoofWare.Myriad.Plugins"
[<Test ; Explicit>]

View File

@@ -33,7 +33,7 @@
</ItemGroup>
<ItemGroup>
<PackageReference Include="ApiSurface" Version="4.0.40"/>
<PackageReference Include="ApiSurface" Version="4.0.41"/>
<PackageReference Include="FsCheck" Version="2.16.6"/>
<PackageReference Include="FsUnit" Version="6.0.0"/>
<PackageReference Include="Microsoft.NET.Test.Sdk" Version="17.10.0"/>

View File

@@ -1,10 +1,8 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Text.Range
open Fantomas.FCS.Xml
open Myriad.Core.AstExtensions
type internal ParameterInfo =
{
@@ -98,30 +96,6 @@ type internal AdtProduct =
[<RequireQualifiedAccess>]
module internal AstHelper =
/// Given e.g. "byte", returns "System.Byte".
let qualifyPrimitiveType (typeName : string) : LongIdent option =
match typeName with
| "float32"
| "single" -> [ "System" ; "Single" ] |> Some
| "float"
| "double" -> [ "System" ; "Double" ] |> Some
| "byte"
| "uint8" -> [ "System" ; "Byte" ] |> Some
| "sbyte"
| "int8" -> [ "System" ; "SByte" ] |> Some
| "int16" -> [ "System" ; "Int16" ] |> Some
| "int"
| "int32" -> [ "System" ; "Int32" ] |> Some
| "int64" -> [ "System" ; "Int64" ] |> Some
| "uint16" -> [ "System" ; "UInt16" ] |> Some
| "uint"
| "uint32" -> [ "System" ; "UInt32" ] |> Some
| "uint64" -> [ "System" ; "UInt64" ] |> Some
| "char" -> [ "System" ; "Char" ] |> Some
| "decimal" -> [ "System" ; "Decimal" ] |> Some
| _ -> None
|> Option.map (List.map Ident.Create)
let instantiateRecord (fields : (RecordFieldName * SynExpr option) list) : SynExpr =
let fields =
fields
@@ -130,86 +104,17 @@ module internal AstHelper =
SynExpr.Record (None, None, fields, range0)
let defineRecordType (record : RecordType) : SynTypeDefn =
let repr =
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, Seq.toList record.Fields, range0), range0)
let name =
SynComponentInfo.Create (
[ record.Name ],
?xmldoc = record.XmlDoc,
?parameters = record.Generics,
access = record.Accessibility
)
SynComponentInfo.create record.Name
|> SynComponentInfo.setAccessibility record.Accessibility
|> match record.XmlDoc with
| None -> id
| Some doc -> SynComponentInfo.withDocString doc
|> SynComponentInfo.setGenerics record.Generics
let trivia : SynTypeDefnTrivia =
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
EqualsRange = Some range0
WithKeyword = Some range0
}
SynTypeDefn (name, repr, defaultArg record.Members SynMemberDefns.Empty, None, range0, trivia)
let isOptionIdent (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when System.String.Equals (i.idText, "option", System.StringComparison.OrdinalIgnoreCase) -> true
// TODO: consider Microsoft.FSharp.Option or whatever it is
| _ -> false
let isUnitIdent (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when System.String.Equals (i.idText, "unit", System.StringComparison.OrdinalIgnoreCase) -> true
| _ -> false
let isListIdent (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when System.String.Equals (i.idText, "list", System.StringComparison.OrdinalIgnoreCase) -> true
// TODO: consider FSharpList or whatever it is
| _ -> false
let isArrayIdent (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when
System.String.Equals (i.idText, "array", System.StringComparison.OrdinalIgnoreCase)
|| System.String.Equals (i.idText, "[]", System.StringComparison.Ordinal)
->
true
| _ -> false
let isResponseIdent (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "Response" ]
| [ "RestEase" ; "Response" ] -> true
| _ -> false
let isMapIdent (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "Map" ] -> true
| _ -> false
let isReadOnlyDictionaryIdent (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "IReadOnlyDictionary" ]
| [ "Generic" ; "IReadOnlyDictionary" ]
| [ "Collections" ; "Generic" ; "IReadOnlyDictionary" ]
| [ "System" ; "Collections" ; "Generic" ; "IReadOnlyDictionary" ] -> true
| _ -> false
let isDictionaryIdent (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "Dictionary" ]
| [ "Generic" ; "Dictionary" ]
| [ "Collections" ; "Generic" ; "Dictionary" ]
| [ "System" ; "Collections" ; "Generic" ; "Dictionary" ] -> true
| _ -> false
let isIDictionaryIdent (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "IDictionary" ]
| [ "Generic" ; "IDictionary" ]
| [ "Collections" ; "Generic" ; "IDictionary" ]
| [ "System" ; "Collections" ; "Generic" ; "IDictionary" ] -> true
| _ -> false
SynTypeDefnRepr.record (Seq.toList record.Fields)
|> SynTypeDefn.create name
|> SynTypeDefn.withMemberDefns (defaultArg record.Members SynMemberDefns.Empty)
let rec private extractOpensFromDecl (moduleDecls : SynModuleDecl list) : SynOpenDeclTarget list =
moduleDecls
@@ -231,12 +136,12 @@ module internal AstHelper =
| SynType.Paren (inner, _) ->
let result, _ = convertSigParam inner
result, true
| SynType.LongIdent ident ->
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
{
Attributes = []
IsOptional = false
Id = None
Type = SynType.CreateLongIdent ident
Type = SynType.createLongIdent ident
},
false
| SynType.SignatureParameter (attrs, opt, id, usedType, _) ->
@@ -254,7 +159,7 @@ module internal AstHelper =
Attributes = []
IsOptional = false
Id = None
Type = SynType.Var (typar, range0)
Type = SynType.var typar
},
false
| _ -> failwithf "expected SignatureParameter, got: %+A" ty
@@ -283,10 +188,6 @@ module internal AstHelper =
}
| _ -> failwithf "Didn't have alternating type-and-star in interface member definition: %+A" tupleType
let toFun (inputs : SynType list) (ret : SynType) : SynType =
(ret, List.rev inputs)
||> List.fold (fun ty input -> SynType.CreateFun (input, ty))
/// Returns the args (where these are tuple types if curried) in order, and the return type.
let rec getType (ty : SynType) : (SynType * bool) list * SynType =
match ty with
@@ -299,7 +200,7 @@ module internal AstHelper =
| SynType.Paren (argType, _) -> getType argType, true
| _ -> getType argType, false
((toFun (List.map fst inputArgs) inputRet), hasParen) :: args, ret
((SynType.toFun (List.map fst inputArgs) inputRet), hasParen) :: args, ret
| _ -> [], ty
let private parseMember (slotSig : SynValSig) (flags : SynMemberFlags) : Choice<MemberInfo, PropertyInfo> =
@@ -356,7 +257,7 @@ module internal AstHelper =
Attributes = []
IsOptional = false
Id = None
Type = SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent ident)
Type = SynType.createLongIdent ident
}
|> List.singleton
}
@@ -368,7 +269,7 @@ module internal AstHelper =
Attributes = []
IsOptional = false
Id = None
Type = SynType.Var (typar, range0)
Type = SynType.var typar
}
|> List.singleton
}
@@ -522,190 +423,3 @@ module internal AstHelper =
}
)
| _ -> failwithf "Failed to get record elements for type that was: %+A" repr
[<AutoOpen>]
module internal SynTypePatterns =
let (|OptionType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when AstHelper.isOptionIdent ident ->
Some innerType
| _ -> None
let (|UnitType|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident when AstHelper.isUnitIdent ident -> Some ()
| _ -> None
let (|ListType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when AstHelper.isListIdent ident ->
Some innerType
| _ -> None
let (|ArrayType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when AstHelper.isArrayIdent ident ->
Some innerType
| SynType.Array (1, innerType, _) -> Some innerType
| _ -> None
let (|RestEaseResponseType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when AstHelper.isResponseIdent ident ->
Some innerType
| _ -> None
let (|DictionaryType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when AstHelper.isDictionaryIdent ident ->
Some (key, value)
| _ -> None
let (|IDictionaryType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when AstHelper.isIDictionaryIdent ident ->
Some (key, value)
| _ -> None
let (|IReadOnlyDictionaryType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when
AstHelper.isReadOnlyDictionaryIdent ident
->
Some (key, value)
| _ -> None
let (|MapType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when AstHelper.isMapIdent ident ->
Some (key, value)
| _ -> None
let (|BigInt|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map _.idText with
| [ "bigint" ]
| [ "BigInteger" ]
| [ "Numerics" ; "BigInteger" ]
| [ "System" ; "Numerics" ; "BigInteger" ] -> Some ()
| _ -> None
| _ -> None
/// Returns the type, qualified as in e.g. `System.Boolean`.
let (|PrimitiveType|_|) (fieldType : SynType) : LongIdent option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] -> AstHelper.qualifyPrimitiveType i.idText
| _ -> None
| _ -> None
let (|String|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] ->
[ "string" ]
|> List.tryFind (fun s -> s = i.idText)
|> Option.map ignore<string>
| _ -> None
| _ -> None
let (|Byte|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] -> [ "byte" ] |> List.tryFind (fun s -> s = i.idText) |> Option.map ignore<string>
| _ -> None
| _ -> None
let (|Guid|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "Guid" ]
| [ "Guid" ] -> Some ()
| _ -> None
| _ -> None
let (|HttpResponseMessage|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "Net" ; "Http" ; "HttpResponseMessage" ]
| [ "Net" ; "Http" ; "HttpResponseMessage" ]
| [ "Http" ; "HttpResponseMessage" ]
| [ "HttpResponseMessage" ] -> Some ()
| _ -> None
| _ -> None
let (|HttpContent|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "Net" ; "Http" ; "HttpContent" ]
| [ "Net" ; "Http" ; "HttpContent" ]
| [ "Http" ; "HttpContent" ]
| [ "HttpContent" ] -> Some ()
| _ -> None
| _ -> None
let (|Stream|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "IO" ; "Stream" ]
| [ "IO" ; "Stream" ]
| [ "Stream" ] -> Some ()
| _ -> None
| _ -> None
let (|NumberType|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] -> [ "string" ; "float" ; "int" ; "bool" ] |> List.tryFind (fun s -> s = i.idText)
| _ -> None
| _ -> None
let (|DateOnly|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "DateOnly" ]
| [ "DateOnly" ] -> Some ()
| _ -> None
| _ -> None
let (|DateTime|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "DateTime" ]
| [ "DateTime" ] -> Some ()
| _ -> None
| _ -> None
let (|Uri|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "Uri" ]
| [ "Uri" ] -> Some ()
| _ -> None
| _ -> None
let (|Task|_|) (fieldType : SynType) : SynType option =
match fieldType with
| SynType.App (SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)), _, args, _, _, _, _) ->
match ident |> List.map (fun i -> i.idText) with
| [ "Task" ]
| [ "Tasks" ; "Task" ]
| [ "Threading" ; "Tasks" ; "Task" ]
| [ "System" ; "Threading" ; "Tasks" ; "Task" ] ->
match args with
| [ arg ] -> Some arg
| _ -> failwithf "Expected Task to be applied to exactly one arg, but got: %+A" args
| _ -> None
| _ -> None

File diff suppressed because it is too large Load Diff

View File

@@ -2,9 +2,6 @@ namespace WoofWare.Myriad.Plugins
open System.Net.Http
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Myriad.Core
type internal HttpClientGeneratorOutputSpec =
{
@@ -14,7 +11,6 @@ type internal HttpClientGeneratorOutputSpec =
[<RequireQualifiedAccess>]
module internal HttpClientGenerator =
open Fantomas.FCS.Text.Range
open Myriad.Core.Ast
[<RequireQualifiedAccess>]
type PathSpec =
@@ -82,7 +78,7 @@ module internal HttpClientGenerator =
let matchingAttrs =
attrs
|> List.choose (fun attr ->
match attr.TypeName.AsString with
match SynLongIdent.toString attr.TypeName with
| "Get"
| "GetAttribute"
| "WoofWare.Myriad.Plugins.RestEase.Get"
@@ -144,7 +140,7 @@ module internal HttpClientGenerator =
let extractHeaderInformation (attrs : SynAttribute list) : SynExpr list list =
attrs
|> List.choose (fun attr ->
match attr.TypeName.AsString with
match SynLongIdent.toString attr.TypeName with
| "Header"
| "RestEase.Header"
| "WoofWare.Myriad.Plugins.RestEase.Header" ->
@@ -158,7 +154,7 @@ module internal HttpClientGenerator =
let shouldAllowAnyStatusCode (attrs : SynAttribute list) : bool =
attrs
|> List.exists (fun attr ->
match attr.TypeName.AsString with
match SynLongIdent.toString attr.TypeName with
| "AllowAnyStatusCode"
| "AllowAnyStatusCodeAttribute"
| "RestEase.AllowAnyStatusCode"
@@ -174,35 +170,6 @@ module internal HttpClientGenerator =
(info : MemberInfo)
: SynMemberDefn
=
let valInfo =
SynValInfo.SynValInfo (
[
[ SynArgInfo.Empty ]
[
for arg in info.Args do
match arg.Id with
| None -> yield SynArgInfo.CreateIdString (failwith "TODO: create an arg name")
| Some id -> yield SynArgInfo.CreateId id
]
],
SynArgInfo.Empty
)
let valData =
SynValData (
Some
{
IsInstance = true
IsDispatchSlot = false
IsOverrideOrExplicitImpl = true
IsFinal = false
GetterOrSetterIsCompilerGenerated = false
MemberKind = SynMemberKind.Member
},
valInfo,
None
)
let args =
info.Args
|> List.map (fun arg ->
@@ -213,15 +180,13 @@ module internal HttpClientGenerator =
let argType =
if arg.IsOptional then
SynType.CreateApp (
SynType.CreateLongIdent (SynLongIdent.CreateString "option"),
[ arg.Type ],
isPostfix = true
)
SynType.appPostfix "option" arg.Type
else
arg.Type
argName, SynPat.CreateTyped (SynPat.CreateNamed argName, argType)
// We'll be tupling these up anyway, so don't need the parens
// around the type annotations.
argName, SynPat.annotateTypeNoParen argType (SynPat.namedI argName)
)
let cancellationTokenArg =
@@ -229,26 +194,6 @@ module internal HttpClientGenerator =
| None -> failwith $"expected an optional cancellation token as final arg in %s{info.Identifier.idText}"
| Some (arg, _) -> arg
let argPats =
let args = args |> List.map snd
SynPat.Tuple (false, args, List.replicate (args.Length - 1) range0, range0)
|> SynPat.CreateParen
|> List.singleton
|> SynArgPats.Pats
let headPat =
let thisIdent = if variableHeaders.IsEmpty then "_" else "this"
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.Create thisIdent ; info.Identifier ],
None,
None,
argPats,
None,
range0
)
let requestUriTrailer =
(info.UrlTemplate, info.Args)
||> List.fold (fun template arg ->
@@ -269,14 +214,12 @@ module internal HttpClientGenerator =
template
|> SynExpr.callMethodArg
"Replace"
(SynExpr.CreateParenedTuple
(SynExpr.tuple
[
SynExpr.CreateConstString ("{" + substituteId + "}")
SynExpr.callMethod "ToString" (SynExpr.CreateIdent varName)
SynExpr.CreateConst ("{" + substituteId + "}")
SynExpr.callMethod "ToString" (SynExpr.createIdent' varName)
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
)
SynExpr.createLongIdent [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
)
])
| _ -> template
@@ -316,33 +259,27 @@ module internal HttpClientGenerator =
let urlSeparator =
// apparent Myriad bug: `IndexOf '?'` gets formatted as `IndexOf ?` which is clearly wrong
let questionMark =
SynExpr.CreateParen (
SynExpr.CreateApp (
SynExpr.CreateIdentString "char",
SynExpr.CreateConst (SynConst.Int32 63)
)
)
SynExpr.CreateConst 63
|> SynExpr.applyFunction (SynExpr.createIdent "char")
|> SynExpr.paren
let containsQuestion =
info.UrlTemplate
|> SynExpr.callMethodArg "IndexOf" questionMark
|> SynExpr.greaterThanOrEqual (SynExpr.CreateConst (SynConst.Int32 0))
|> SynExpr.greaterThanOrEqual (SynExpr.CreateConst 0)
SynExpr.ifThenElse
containsQuestion
(SynExpr.CreateConst (SynConst.CreateString "?"))
(SynExpr.CreateConst (SynConst.CreateString "&"))
|> SynExpr.CreateParen
SynExpr.ifThenElse containsQuestion (SynExpr.CreateConst "?") (SynExpr.CreateConst "&")
|> SynExpr.paren
let prefix =
SynExpr.CreateIdent firstValueId
SynExpr.createIdent' firstValueId
|> SynExpr.toString firstValue.Type
|> SynExpr.CreateParen
|> SynExpr.paren
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ])
SynExpr.createLongIdent [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
)
|> SynExpr.CreateParen
|> SynExpr.plus (SynExpr.plus urlSeparator (SynExpr.CreateConstString (firstKey + "=")))
|> SynExpr.paren
|> SynExpr.plus (SynExpr.plus urlSeparator (SynExpr.CreateConst (firstKey + "=")))
(prefix, queryParams)
||> List.fold (fun uri (paramKey, paramValue) ->
@@ -351,82 +288,55 @@ module internal HttpClientGenerator =
| None -> failwith "Unable to get parameter variable name from anonymous parameter"
| Some id -> id
SynExpr.toString paramValue.Type (SynExpr.CreateIdent paramValueId)
|> SynExpr.CreateParen
SynExpr.toString paramValue.Type (SynExpr.createIdent' paramValueId)
|> SynExpr.paren
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
)
SynExpr.createLongIdent [ "System" ; "Web" ; "HttpUtility" ; "UrlEncode" ]
)
|> SynExpr.CreateParen
|> SynExpr.plus (SynExpr.plus uri (SynExpr.CreateConstString ("&" + paramKey + "=")))
|> SynExpr.paren
|> SynExpr.plus (SynExpr.plus uri (SynExpr.CreateConst ("&" + paramKey + "=")))
)
|> SynExpr.plus requestUriTrailer
|> SynExpr.CreateParen
|> SynExpr.paren
let requestUri =
let uriIdent = SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Uri" ])
let uriIdent = SynExpr.createLongIdent [ "System" ; "Uri" ]
let baseAddress = SynExpr.createLongIdent [ "client" ; "BaseAddress" ]
let baseAddress =
SynExpr.CreateLongIdent (SynLongIdent.Create [ "client" ; "BaseAddress" ])
[
SynMatchClause.create
SynPat.createNull
(match info.BaseAddress with
| None ->
[
SynExpr.applyFunction (SynExpr.createIdent "nameof") (SynExpr.paren baseAddress)
SynExpr.CreateConst
"No base address was supplied on the type, and no BaseAddress was on the HttpClient."
]
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "ArgumentNullException" ])
|> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createIdent "raise")
| Some expr -> SynExpr.applyFunction uriIdent expr)
SynMatchClause.create (SynPat.named "v") (SynExpr.createIdent "v")
]
|> SynExpr.createMatch baseAddress
|> SynExpr.paren
let baseAddress =
SynExpr.CreateMatch (
baseAddress,
[
SynMatchClause.Create (
SynPat.CreateNull,
None,
match info.BaseAddress with
| None ->
SynExpr.CreateApp (
SynExpr.CreateIdentString "raise",
SynExpr.CreateParen (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "ArgumentNullException" ]
),
SynExpr.CreateParenedTuple
[
SynExpr.CreateApp (
SynExpr.CreateIdentString "nameof",
SynExpr.CreateParen baseAddress
)
SynExpr.CreateConstString
"No base address was supplied on the type, and no BaseAddress was on the HttpClient."
]
)
)
)
| Some expr -> SynExpr.CreateApp (uriIdent, expr)
)
SynMatchClause.Create (
SynPat.CreateNamed (Ident.Create "v"),
None,
SynExpr.CreateIdentString "v"
)
]
)
|> SynExpr.CreateParen
SynExpr.App (
ExprAtomicFlag.Atomic,
false,
uriIdent,
SynExpr.CreateParenedTuple
[
baseAddress
SynExpr.CreateApp (
uriIdent,
SynExpr.CreateParenedTuple
[
requestUriTrailer
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "UriKind" ; "Relative" ])
]
)
],
range0
)
[
baseAddress
SynExpr.applyFunction
uriIdent
(SynExpr.tuple
[
requestUriTrailer
SynExpr.createLongIdent [ "System" ; "UriKind" ; "Relative" ]
])
]
|> SynExpr.tuple
|> SynExpr.applyFunction uriIdent
let bodyParams =
info.Args
@@ -460,58 +370,43 @@ module internal HttpClientGenerator =
let httpReqMessageConstructor =
[
SynExpr.equals
(SynExpr.CreateIdentString "Method")
(SynExpr.CreateLongIdent (
SynLongIdent.Create
[ "System" ; "Net" ; "Http" ; "HttpMethod" ; httpMethodString info.HttpMethod ]
))
SynExpr.equals (SynExpr.CreateIdentString "RequestUri") (SynExpr.CreateIdentString "uri")
(SynExpr.createIdent "Method")
(SynExpr.createLongIdent
[ "System" ; "Net" ; "Http" ; "HttpMethod" ; httpMethodString info.HttpMethod ])
SynExpr.equals (SynExpr.createIdent "RequestUri") (SynExpr.createIdent "uri")
]
|> SynExpr.CreateParenedTuple
|> SynExpr.tupleNoParen
let returnExpr =
match info.TaskReturnType with
| HttpResponseMessage -> SynExpr.CreateIdentString "response"
| String -> SynExpr.CreateIdentString "responseString"
| Stream -> SynExpr.CreateIdentString "responseStream"
| HttpResponseMessage -> SynExpr.createIdent "response"
| String -> SynExpr.createIdent "responseString"
| Stream -> SynExpr.createIdent "responseStream"
| RestEaseResponseType contents ->
let deserialiser =
SynExpr.CreateLambda (
[ SynPat.CreateConst SynConst.Unit ],
SynExpr.CreateParen (
JsonParseGenerator.parseNode
None
JsonParseGenerator.JsonParseOption.None
contents
(SynExpr.CreateIdentString "jsonNode")
)
)
JsonParseGenerator.parseNode
None
JsonParseGenerator.JsonParseOption.None
contents
(SynExpr.createIdent "jsonNode")
|> SynExpr.paren
|> SynExpr.createThunk
// new RestEase.Response (content : string, response : HttpResponseMessage, deserialiser : unit -> 'T)
SynExpr.New (
false,
SynType.App (
SynType.CreateLongIdent (SynLongIdent.Create [ "RestEase" ; "Response" ]),
Some range0,
[ SynType.Anon range0 ],
[],
Some range0,
false,
range0
),
SynExpr.CreateParenedTuple
SynExpr.createNew
(SynType.app' (SynType.createLongIdent' [ "RestEase" ; "Response" ]) [ SynType.Anon range0 ])
(SynExpr.tupleNoParen
[
SynExpr.CreateIdentString "responseString"
SynExpr.CreateIdentString "response"
SynExpr.CreateParen deserialiser
],
range0
)
SynExpr.createIdent "responseString"
SynExpr.createIdent "response"
deserialiser
])
| retType ->
JsonParseGenerator.parseNode
None
JsonParseGenerator.JsonParseOption.None
retType
(SynExpr.CreateIdentString "jsonNode")
(SynExpr.createIdent "jsonNode")
let handleBodyParams =
match bodyParam with
@@ -524,20 +419,15 @@ module internal HttpClientGenerator =
[
Let (
"queryParams",
SynExpr.New (
false,
SynType.CreateLongIdent (
SynLongIdent.Create
[ "System" ; "Net" ; "Http" ; (bodyParamType : BodyParamMethods).ToString () ]
),
SynExpr.CreateParen (SynExpr.CreateIdent bodyParamName),
range0
)
SynExpr.createNew
(SynType.createLongIdent'
[ "System" ; "Net" ; "Http" ; (bodyParamType : BodyParamMethods).ToString () ])
(SynExpr.createIdent' bodyParamName)
)
Do (
SynExpr.LongIdentSet (
SynLongIdent.Create [ "httpMessage" ; "Content" ],
SynExpr.CreateIdentString "queryParams",
SynLongIdent.createS' [ "httpMessage" ; "Content" ],
SynExpr.createIdent "queryParams",
range0
)
)
@@ -546,8 +436,8 @@ module internal HttpClientGenerator =
[
Do (
SynExpr.LongIdentSet (
SynLongIdent.Create [ "httpMessage" ; "Content" ],
SynExpr.CreateIdent bodyParamName,
SynLongIdent.createS' [ "httpMessage" ; "Content" ],
SynExpr.createIdent' bodyParamName,
range0
)
)
@@ -556,38 +446,27 @@ module internal HttpClientGenerator =
[
Let (
"queryParams",
SynExpr.New (
false,
SynType.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Net" ; "Http" ; "StringContent" ]
),
SynExpr.CreateParen (
SynExpr.CreateIdent bodyParamName
|> SynExpr.pipeThroughFunction (JsonSerializeGenerator.serializeNode ty)
|> SynExpr.pipeThroughFunction (
SynExpr.createLambda
"node"
(SynExpr.ifThenElse
(SynExpr.CreateApp (
SynExpr.CreateIdentString "isNull",
SynExpr.CreateIdentString "node"
))
(SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "node" ; "ToJsonString" ]
),
SynExpr.CreateConst SynConst.Unit
))
(SynExpr.CreateConst (SynConst.CreateString "null")))
)
),
range0
)
SynExpr.createNew
(SynType.createLongIdent' [ "System" ; "Net" ; "Http" ; "StringContent" ])
(SynExpr.createIdent' bodyParamName
|> SynExpr.pipeThroughFunction (JsonSerializeGenerator.serializeNode ty)
|> SynExpr.pipeThroughFunction (
SynExpr.createLambda
"node"
(SynExpr.ifThenElse
(SynExpr.applyFunction
(SynExpr.createIdent "isNull")
(SynExpr.createIdent "node"))
(SynExpr.applyFunction
(SynExpr.createLongIdent [ "node" ; "ToJsonString" ])
(SynExpr.CreateConst ()))
(SynExpr.CreateConst "null"))
))
)
Do (
SynExpr.LongIdentSet (
SynLongIdent.Create [ "httpMessage" ; "Content" ],
SynExpr.CreateIdent (Ident.Create "queryParams"),
SynLongIdent.createS' [ "httpMessage" ; "Content" ],
SynExpr.createIdent "queryParams",
range0
)
)
@@ -598,12 +477,9 @@ module internal HttpClientGenerator =
LetBang (
"responseString",
SynExpr.awaitTask (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "response" ; "Content" ; "ReadAsStringAsync" ]
),
SynExpr.CreateIdentString "ct"
)
SynExpr.applyFunction
(SynExpr.createLongIdent [ "response" ; "Content" ; "ReadAsStringAsync" ])
(SynExpr.createIdent "ct")
)
)
@@ -611,12 +487,9 @@ module internal HttpClientGenerator =
LetBang (
"responseStream",
SynExpr.awaitTask (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "response" ; "Content" ; "ReadAsStreamAsync" ]
),
SynExpr.CreateIdentString "ct"
)
SynExpr.applyFunction
(SynExpr.createLongIdent [ "response" ; "Content" ; "ReadAsStreamAsync" ])
(SynExpr.createIdent "ct")
)
)
@@ -624,67 +497,50 @@ module internal HttpClientGenerator =
LetBang (
"jsonNode",
SynExpr.awaitTask (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ; "ParseAsync" ]
),
SynExpr.CreateParenedTuple
SynExpr.applyFunction
(SynExpr.createLongIdent
[ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ; "ParseAsync" ])
(SynExpr.tuple
[
SynExpr.CreateIdentString "responseStream"
SynExpr.equals
(SynExpr.CreateIdentString "cancellationToken")
(SynExpr.CreateIdentString "ct")
]
)
SynExpr.createIdent "responseStream"
SynExpr.equals (SynExpr.createIdent "cancellationToken") (SynExpr.createIdent "ct")
])
)
)
let setVariableHeaders =
variableHeaders
|> List.map (fun (headerName, callToGetValue) ->
Do (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "httpMessage" ; "Headers" ; "Add" ]),
SynExpr.CreateParenedTuple
[
headerName
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.CreateFromLongIdent
[ Ident.Create "this" ; callToGetValue ; Ident.Create "ToString" ]
),
SynExpr.CreateConst SynConst.Unit
)
]
)
)
[
headerName
SynExpr.applyFunction
(SynExpr.createLongIdent'
[ Ident.create "this" ; callToGetValue ; Ident.create "ToString" ])
(SynExpr.CreateConst ())
]
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "httpMessage" ; "Headers" ; "Add" ])
|> Do
)
let setConstantHeaders =
constantHeaders
|> List.map (fun (headerName, headerValue) ->
Do (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "httpMessage" ; "Headers" ; "Add" ]),
SynExpr.CreateParenedTuple [ headerName ; headerValue ]
)
)
SynExpr.applyFunction
(SynExpr.createLongIdent [ "httpMessage" ; "Headers" ; "Add" ])
(SynExpr.tuple [ headerName ; headerValue ])
|> Do
)
[
yield LetBang ("ct", SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "CancellationToken" ]))
yield LetBang ("ct", SynExpr.createLongIdent [ "Async" ; "CancellationToken" ])
yield Let ("uri", requestUri)
yield
Use (
"httpMessage",
SynExpr.New (
false,
SynType.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Net" ; "Http" ; "HttpRequestMessage" ]
),
httpReqMessageConstructor,
range0
)
SynExpr.createNew
(SynType.createLongIdent' [ "System" ; "Net" ; "Http" ; "HttpRequestMessage" ])
httpReqMessageConstructor
)
yield! handleBodyParams
@@ -696,21 +552,18 @@ module internal HttpClientGenerator =
LetBang (
"response",
SynExpr.awaitTask (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "client" ; "SendAsync" ]),
SynExpr.CreateParenedTuple
[ SynExpr.CreateIdentString "httpMessage" ; SynExpr.CreateIdentString "ct" ]
)
SynExpr.applyFunction
(SynExpr.createLongIdent [ "client" ; "SendAsync" ])
(SynExpr.tuple [ SynExpr.createIdent "httpMessage" ; SynExpr.createIdent "ct" ])
)
)
if info.EnsureSuccessHttpCode then
yield
Let (
"response",
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "response" ; "EnsureSuccessStatusCode" ]),
SynExpr.CreateConst SynConst.Unit
)
SynExpr.applyFunction
(SynExpr.createLongIdent [ "response" ; "EnsureSuccessStatusCode" ])
(SynExpr.CreateConst ())
)
match info.TaskReturnType with
| HttpResponseMessage -> ()
@@ -725,31 +578,22 @@ module internal HttpClientGenerator =
yield jsonNode
]
|> SynExpr.createCompExpr "async" returnExpr
|> SynExpr.startAsTask (SynLongIdent.CreateFromLongIdent [ cancellationTokenArg ])
|> SynExpr.startAsTask cancellationTokenArg
SynMemberDefn.Member (
SynBinding.SynBinding (
info.Accessibility,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Empty,
valData,
headPat,
None,
implementation,
range0,
DebugPointAtBinding.Yes range0,
SynExpr.synBindingTriviaZero true
),
range0
)
let thisIdent =
if variableHeaders.IsEmpty then "_" else "this"
|> Ident.create
let args = args |> List.map snd |> SynPat.tuple |> List.singleton
SynBinding.basic [ thisIdent ; info.Identifier ] args implementation
|> SynBinding.withAccessibility info.Accessibility
|> SynMemberDefn.memberImplementation
let getHttpAttributes (attrs : SynAttribute list) : HttpAttribute list =
attrs
|> List.choose (fun attr ->
match attr.TypeName.AsString with
match SynLongIdent.toString attr.TypeName with
| "RestEase.Query"
| "RestEase.QueryAttribute"
| "WoofWare.Myriad.Plugins.RestEase.Query"
@@ -790,7 +634,7 @@ module internal HttpClientGenerator =
let extractBasePath (attrs : SynAttribute list) : SynExpr option =
attrs
|> List.tryPick (fun attr ->
match attr.TypeName.AsString with
match SynLongIdent.toString attr.TypeName with
| "BasePath"
| "RestEase.BasePath"
| "WoofWare.Myriad.Plugins.RestEase.BasePath"
@@ -803,7 +647,7 @@ module internal HttpClientGenerator =
let extractBaseAddress (attrs : SynAttribute list) : SynExpr option =
attrs
|> List.tryPick (fun attr ->
match attr.TypeName.AsString with
match SynLongIdent.toString attr.TypeName with
| "BaseAddress"
| "RestEase.BaseAddress"
| "WoofWare.Myriad.Plugins.RestEase.BaseAddress"
@@ -918,48 +762,13 @@ module internal HttpClientGenerator =
let propertyMembers =
properties
|> List.map (fun (_, pi) ->
SynMemberDefn.Member (
SynBinding.SynBinding (
pi.Accessibility,
SynBindingKind.Normal,
pi.IsInline,
false,
[],
PreXmlDoc.Empty,
SynValData.SynValData (
Some
{
IsInstance = true
IsDispatchSlot = false
IsOverrideOrExplicitImpl = true
IsFinal = false
GetterOrSetterIsCompilerGenerated = false
MemberKind = SynMemberKind.Member
},
SynValInfo.SynValInfo ([ [ SynArgInfo.Empty ] ; [] ], SynArgInfo.Empty),
None
),
SynPat.CreateLongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.Create "_" ; pi.Identifier ],
[]
),
Some (SynBindingReturnInfo.Create pi.Type),
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.lowerFirstLetter pi.Identifier ]
),
SynExpr.CreateConst SynConst.Unit
),
range0,
DebugPointAtBinding.Yes range0,
{
LeadingKeyword = SynLeadingKeyword.Member range0
InlineKeyword = if pi.IsInline then Some range0 else None
EqualsRange = Some range0
}
),
range0
)
SynExpr.createLongIdent' [ Ident.lowerFirstLetter pi.Identifier ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic [ Ident.create "_" ; pi.Identifier ] []
|> SynBinding.withReturnAnnotation pi.Type
|> SynBinding.setInline pi.IsInline
|> SynBinding.withAccessibility pi.Accessibility
|> SynMemberDefn.memberImplementation
)
let members = propertyMembers @ nonPropertyMembers
@@ -969,12 +778,12 @@ module internal HttpClientGenerator =
"Extension methods"
else
"Module")
|> sprintf " %s for constructing a REST client."
|> PreXmlDoc.Create
|> sprintf "%s for constructing a REST client."
|> PreXmlDoc.create
let interfaceImpl =
SynExpr.ObjExpr (
SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name),
SynType.createLongIdent interfaceType.Name,
None,
Some range0,
[],
@@ -987,160 +796,87 @@ module internal HttpClientGenerator =
let headerArgs =
properties
|> List.map (fun (_, pi) ->
SynPat.CreateTyped (
SynPat.CreateNamed (Ident.lowerFirstLetter pi.Identifier),
SynType.CreateFun (SynType.CreateLongIdent "unit", pi.Type)
)
|> SynPat.CreateParen
SynPat.namedI (Ident.lowerFirstLetter pi.Identifier)
|> SynPat.annotateType (SynType.funFromDomain (SynType.named "unit") pi.Type)
)
let clientCreationArg =
SynPat.CreateTyped (
SynPat.CreateNamed (Ident.Create "client"),
SynType.CreateLongIdent (SynLongIdent.Create [ "System" ; "Net" ; "Http" ; "HttpClient" ])
)
|> SynPat.CreateParen
SynPat.named "client"
|> SynPat.annotateType (SynType.createLongIdent' [ "System" ; "Net" ; "Http" ; "HttpClient" ])
let xmlDoc =
if properties.IsEmpty then
" Create a REST client."
"Create a REST client."
else
" Create a REST client. The input functions will be re-evaluated on every HTTP request to obtain the required values for the corresponding header properties."
|> PreXmlDoc.Create
"Create a REST client. The input functions will be re-evaluated on every HTTP request to obtain the required values for the corresponding header properties."
|> PreXmlDoc.create
let functionName = Ident.Create "client"
let functionName = Ident.create "client"
let valData =
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 pattern = SynLongIdent.createS "make"
SynValData.SynValData (
memberFlags,
SynValInfo.SynValInfo ([ [ SynArgInfo.SynArgInfo ([], false, Some functionName) ] ], SynArgInfo.Empty),
None
)
let pattern =
SynPat.CreateLongIdent (SynLongIdent.CreateString "make", headerArgs @ [ clientCreationArg ])
let returnInfo =
SynBindingReturnInfo.Create (SynType.LongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name))
let returnInfo = SynType.createLongIdent interfaceType.Name
let nameWithoutLeadingI =
List.last interfaceType.Name
|> _.idText
|> fun s ->
if s.StartsWith 'I' then
s.[1..]
s.Substring 1
else
failwith $"Expected interface type to start with 'I', but was: %s{s}"
let createFunc =
if spec.ExtensionMethods then
let binding =
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
xmlDoc,
valData,
pattern,
Some returnInfo,
interfaceImpl,
range0,
DebugPointAtBinding.NoneAtInvisible,
{
LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0)
InlineKeyword = None
EqualsRange = Some range0
}
)
SynBinding.basic [ Ident.create "make" ] (headerArgs @ [ clientCreationArg ]) interfaceImpl
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> SynMemberDefn.staticMember
let mem = SynMemberDefn.Member (binding, range0)
let componentInfo =
SynComponentInfo.create (Ident.create nameWithoutLeadingI)
|> SynComponentInfo.withDocString (PreXmlDoc.create "Extension methods for HTTP clients")
let containingType =
SynTypeDefn.SynTypeDefn (
SynComponentInfo.Create (
[ Ident.Create nameWithoutLeadingI ],
xmldoc = PreXmlDoc.Create " Extension methods for HTTP clients"
),
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0),
[ mem ],
None,
range0,
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
EqualsRange = None
WithKeyword = None
}
)
SynTypeDefnRepr.augmentation ()
|> SynTypeDefn.create componentInfo
|> SynTypeDefn.withMemberDefns [ binding ]
SynModuleDecl.Types ([ containingType ], range0)
else
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
xmlDoc,
valData,
pattern,
Some returnInfo,
interfaceImpl,
range0,
DebugPointAtBinding.NoneAtLet,
SynExpr.synBindingTriviaZero false
)
|> List.singleton
|> SynModuleDecl.CreateLet
SynBinding.basic [ Ident.create "make" ] (headerArgs @ [ clientCreationArg ]) interfaceImpl
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> SynModuleDecl.createLet
let moduleName : LongIdent =
let moduleName =
if spec.ExtensionMethods then
[ Ident.Create (nameWithoutLeadingI + "HttpClientExtension") ]
Ident.create (nameWithoutLeadingI + "HttpClientExtension")
else
[ Ident.Create nameWithoutLeadingI ]
Ident.create nameWithoutLeadingI
let attribs =
if spec.ExtensionMethods then
[ SynAttributeList.Create SynAttribute.autoOpen ]
[ SynAttribute.autoOpen ]
else
[
SynAttributeList.Create SynAttribute.compilationRepresentation
SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ())
]
[ SynAttribute.compilationRepresentation ; SynAttribute.requireQualifiedAccess ]
let modInfo =
SynComponentInfo.Create (
moduleName,
attributes = attribs,
xmldoc = docString,
access = interfaceType.Accessibility
)
SynComponentInfo.create moduleName
|> SynComponentInfo.withDocString docString
|> SynComponentInfo.addAttributes attribs
|> SynComponentInfo.setAccessibility interfaceType.Accessibility
SynModuleOrNamespace.CreateNamespace (
ns,
decls =
[
for openStatement in opens do
yield SynModuleDecl.CreateOpen openStatement
yield SynModuleDecl.CreateNestedModule (modInfo, [ createFunc ])
]
)
[
for openStatement in opens do
yield SynModuleDecl.openAny openStatement
yield SynModuleDecl.nestedModule modInfo [ createFunc ]
]
|> SynModuleOrNamespace.createNamespace ns
open Myriad.Core
/// Myriad generator that provides an HTTP client for an interface type using RestEase annotations.
[<MyriadGenerator("http-client")>]

View File

@@ -2,9 +2,7 @@ namespace WoofWare.Myriad.Plugins
open System
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Myriad.Core
type internal GenerateMockOutputSpec =
{
@@ -14,7 +12,6 @@ type internal GenerateMockOutputSpec =
[<RequireQualifiedAccess>]
module internal InterfaceMockGenerator =
open Fantomas.FCS.Text.Range
open Myriad.Core.Ast
let private getName (SynField (_, _, id, _, _, _, _, _, _)) =
match id with
@@ -46,116 +43,67 @@ module internal InterfaceMockGenerator =
)
|> Set.ofSeq
let synValData =
{
SynMemberFlags.IsInstance = false
SynMemberFlags.IsDispatchSlot = false
SynMemberFlags.IsOverrideOrExplicitImpl = false
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
let failwithFun (SynField (_, _, idOpt, _, _, _, _, _, _)) =
let failString =
match idOpt with
| None -> SynExpr.CreateConst "Unimplemented mock function"
| Some ident -> SynExpr.CreateConst $"Unimplemented mock function: %s{ident.idText}"
let failwithFun =
SynExpr.createLambda
"x"
(SynExpr.CreateApp (
SynExpr.CreateIdentString "raise",
SynExpr.CreateParen (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "NotImplementedException" ]),
SynExpr.CreateConstString "Unimplemented mock function"
)
)
))
let constructorIdent =
let generics =
interfaceType.Generics
|> Option.map (fun generics -> SynValTyparDecls (Some generics, false))
SynPat.LongIdent (
SynLongIdent.CreateString "Empty",
None,
None, // no generics on the "Empty", only on the return type
SynArgPats.Pats (
if generics.IsNone then
[]
else
[ SynPat.CreateParen (SynPat.CreateConst SynConst.Unit) ]
),
None,
range0
)
SynExpr.createLongIdent [ "System" ; "NotImplementedException" ]
|> SynExpr.applyTo failString
|> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createIdent "raise")
|> SynExpr.createLambda "_"
let constructorReturnType =
match interfaceType.Generics with
| None -> SynType.CreateLongIdent name
| None -> SynType.createLongIdent' [ name ]
| Some generics ->
let generics =
generics.TyparDecls
|> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0))
SynType.App (
SynType.CreateLongIdent name,
Some range0,
generics,
List.replicate (generics.Length - 1) range0,
Some range0,
false,
range0
)
|> SynBindingReturnInfo.Create
let generics =
generics.TyparDecls
|> List.map (fun (SynTyparDecl (_, typar)) -> SynType.var typar)
SynType.app name generics
let constructorFields =
let extras =
if inherits.Contains KnownInheritance.IDisposable then
let unitFun = SynExpr.createLambda "_" SynExpr.CreateUnit
let unitFun = SynExpr.createThunk (SynExpr.CreateConst ())
[
(SynLongIdent.CreateFromLongIdent [ Ident.Create "Dispose" ], true), Some unitFun
]
[ (SynLongIdent.createS "Dispose", true), Some unitFun ]
else
[]
let nonExtras =
fields
|> List.map (fun field -> (SynLongIdent.CreateFromLongIdent [ getName field ], true), Some failwithFun)
|> List.map (fun field -> (SynLongIdent.createI (getName field), true), Some (failwithFun field))
extras @ nonExtras
let constructor =
SynMemberDefn.Member (
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Create " An implementation where every method throws.",
SynValData.SynValData (Some synValData, SynValInfo.Empty, None),
constructorIdent,
Some constructorReturnType,
AstHelper.instantiateRecord constructorFields,
range0,
DebugPointAtBinding.Yes range0,
{ SynExpr.synBindingTriviaZero true with
LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0)
}
),
range0
)
SynBinding.basic
[ Ident.create "Empty" ]
(if interfaceType.Generics.IsNone then
[]
else
[ SynPat.unit ])
(AstHelper.instantiateRecord constructorFields)
|> SynBinding.withXmlDoc (PreXmlDoc.create "An implementation where every method throws.")
|> SynBinding.withReturnAnnotation constructorReturnType
|> SynMemberDefn.staticMember
let fields =
let extras =
if inherits.Contains KnownInheritance.IDisposable then
[
SynField.Create (
SynType.CreateFun (SynType.CreateUnit, SynType.CreateUnit),
Ident.Create "Dispose",
xmldoc = PreXmlDoc.Create " Implementation of IDisposable.Dispose"
)
]
{
Attrs = []
Ident = Some (Ident.create "Dispose")
Type = SynType.funFromDomain SynType.unit SynType.unit
}
|> SynField.make
|> SynField.withDocString (PreXmlDoc.create "Implementation of IDisposable.Dispose")
|> List.singleton
else
[]
@@ -165,47 +113,6 @@ module internal InterfaceMockGenerator =
let members =
interfaceType.Members
|> List.map (fun memberInfo ->
let synValData =
SynValData.SynValData (
Some
{
IsInstance = true
IsDispatchSlot = false
IsOverrideOrExplicitImpl = true
IsFinal = false
GetterOrSetterIsCompilerGenerated = false
MemberKind = SynMemberKind.Member
},
valInfo =
SynValInfo.SynValInfo (
curriedArgInfos =
[
yield
[
SynArgInfo.SynArgInfo (
attributes = [],
optional = false,
ident = None
)
]
yield!
memberInfo.Args
|> List.mapi (fun i arg ->
arg.Args
|> List.mapi (fun j arg ->
match arg.Type with
| UnitType -> SynArgInfo.SynArgInfo ([], false, None)
| _ -> SynArgInfo.CreateIdString $"arg_%i{i}_%i{j}"
)
)
],
returnInfo =
SynArgInfo.SynArgInfo (attributes = [], optional = false, ident = None)
),
thisIdOpt = None
)
let headArgs =
memberInfo.Args
|> List.mapi (fun i tupledArgs ->
@@ -213,27 +120,15 @@ module internal InterfaceMockGenerator =
tupledArgs.Args
|> List.mapi (fun j ty ->
match ty.Type with
| UnitType -> SynPat.Const (SynConst.Unit, range0)
| _ -> SynPat.CreateNamed (Ident.Create $"arg_%i{i}_%i{j}")
| UnitType -> SynPat.unit
| _ -> SynPat.named $"arg_%i{i}_%i{j}"
)
match args with
| [] -> failwith "somehow got no args at all"
| [ arg ] -> arg
| args ->
SynPat.Tuple (false, args, List.replicate (args.Length - 1) range0, range0)
|> SynPat.CreateParen
|> fun i -> if tupledArgs.HasParen then SynPat.Paren (i, range0) else i
)
let headPat =
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ],
None,
None,
SynArgPats.Pats headArgs,
None,
range0
| args -> SynPat.tuple args
|> fun i -> if tupledArgs.HasParen then SynPat.paren i else i
)
let body =
@@ -243,10 +138,10 @@ module internal InterfaceMockGenerator =
args.Args
|> List.mapi (fun j arg ->
match arg.Type with
| UnitType -> SynExpr.CreateConst SynConst.Unit
| _ -> SynExpr.CreateIdentString $"arg_%i{i}_%i{j}"
| UnitType -> SynExpr.CreateConst ()
| _ -> SynExpr.createIdent $"arg_%i{i}_%i{j}"
)
|> SynExpr.CreateParenedTuple
|> SynExpr.tuple
)
match tuples |> List.rev with
@@ -254,42 +149,17 @@ module internal InterfaceMockGenerator =
| last :: rest ->
(last, rest)
||> List.fold (fun trail next -> SynExpr.CreateApp (next, trail))
|> fun args ->
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; memberInfo.Identifier ]
),
args
)
||> List.fold SynExpr.applyTo
|> SynExpr.applyFunction (
SynExpr.createLongIdent' [ Ident.create "this" ; memberInfo.Identifier ]
)
SynMemberDefn.Member (
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Empty,
synValData,
headPat,
None,
body,
range0,
DebugPointAtBinding.Yes range0,
{
LeadingKeyword = SynLeadingKeyword.Member range0
InlineKeyword = None
EqualsRange = Some range0
}
),
range0
)
SynBinding.basic [ Ident.create "this" ; memberInfo.Identifier ] headArgs body
|> SynMemberDefn.memberImplementation
)
let interfaceName =
let baseName =
SynType.CreateLongIdent (SynLongIdent.CreateFromLongIdent interfaceType.Name)
let baseName = SynType.createLongIdent interfaceType.Name
match interfaceType.Generics with
| None -> baseName
@@ -299,17 +169,9 @@ module internal InterfaceMockGenerator =
| SynTyparDecls.PostfixList (decls, _, _) -> decls
| SynTyparDecls.PrefixList (decls, _) -> decls
| SynTyparDecls.SinglePrefix (decl, _) -> [ decl ]
|> List.map (fun (SynTyparDecl (_, typar)) -> SynType.Var (typar, range0))
|> List.map (fun (SynTyparDecl (_, typar)) -> SynType.var typar)
SynType.App (
baseName,
Some range0,
generics,
List.replicate (generics.Length - 1) range0,
Some range0,
false,
range0
)
SynType.app' baseName generics
SynMemberDefn.Interface (interfaceName, Some range0, Some members, range0)
@@ -327,83 +189,15 @@ module internal InterfaceMockGenerator =
|> Seq.map (fun inheritance ->
match inheritance with
| KnownInheritance.IDisposable ->
let valData =
SynValData.SynValData (
Some
{
IsInstance = true
IsDispatchSlot = false
IsOverrideOrExplicitImpl = true
IsFinal = false
GetterOrSetterIsCompilerGenerated = false
MemberKind = SynMemberKind.Member
},
valInfo =
SynValInfo.SynValInfo (
curriedArgInfos =
[
yield
[
SynArgInfo.SynArgInfo (
attributes = [],
optional = false,
ident = None
)
]
],
returnInfo =
SynArgInfo.SynArgInfo (attributes = [], optional = false, ident = None)
),
thisIdOpt = None
)
let headArgs = [ SynPat.Const (SynConst.Unit, range0) ]
let headPat =
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ Ident.Create "this" ; Ident.Create "Dispose" ],
None,
None,
SynArgPats.Pats headArgs,
None,
range0
)
let binding =
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Empty,
valData,
headPat,
Some (
SynBindingReturnInfo.SynBindingReturnInfo (
SynType.Unit (),
range0,
[],
SynBindingReturnInfoTrivia.Zero
)
),
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "this" ; "Dispose" ]),
SynExpr.CreateUnit
),
range0,
DebugPointAtBinding.Yes range0,
{
LeadingKeyword = SynLeadingKeyword.Member range0
InlineKeyword = None
EqualsRange = Some range0
}
)
let mem = SynMemberDefn.Member (binding, range0)
let mem =
SynExpr.createLongIdent [ "this" ; "Dispose" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic [ Ident.create "this" ; Ident.create "Dispose" ] [ SynPat.unit ]
|> SynBinding.withReturnAnnotation SynType.unit
|> SynMemberDefn.memberImplementation
SynMemberDefn.Interface (
SynType.CreateLongIdent (SynLongIdent.Create [ "System" ; "IDisposable" ]),
SynType.createLongIdent' [ "System" ; "IDisposable" ],
Some range0,
Some [ mem ],
range0
@@ -413,7 +207,7 @@ module internal InterfaceMockGenerator =
let record =
{
Name = Ident.Create name
Name = Ident.create name
Fields = fields
Members = Some ([ constructor ; interfaceMembers ] @ extraInterfaces)
XmlDoc = Some xmlDoc
@@ -427,7 +221,7 @@ module internal InterfaceMockGenerator =
let private buildType (x : ParameterInfo) : SynType =
if x.IsOptional then
SynType.App (SynType.CreateLongIdent "option", Some range0, [ x.Type ], [], Some range0, false, range0)
SynType.app "option" [ x.Type ]
else
x.Type
@@ -444,19 +238,15 @@ module internal InterfaceMockGenerator =
let constructMember (mem : MemberInfo) : SynField =
let inputType = mem.Args |> List.map constructMemberSinglePlace
let funcType = AstHelper.toFun inputType mem.ReturnType
let funcType = SynType.toFun inputType mem.ReturnType
SynField.SynField (
[],
false,
Some mem.Identifier,
funcType,
false,
mem.XmlDoc |> Option.defaultValue PreXmlDoc.Empty,
None,
range0,
SynFieldTrivia.Zero
)
{
Type = funcType
Attrs = []
Ident = Some mem.Identifier
}
|> SynField.make
|> SynField.withDocString (mem.XmlDoc |> Option.defaultValue PreXmlDoc.Empty)
let createRecord
(namespaceId : LongIdent)
@@ -466,24 +256,24 @@ module internal InterfaceMockGenerator =
=
let interfaceType = AstHelper.parseInterface interfaceType
let fields = interfaceType.Members |> List.map constructMember
let docString = PreXmlDoc.Create " Mock record type for an interface"
let docString = PreXmlDoc.create "Mock record type for an interface"
let name =
List.last interfaceType.Name
|> _.idText
|> fun s ->
if s.StartsWith 'I' && s.Length > 1 && Char.IsUpper s.[1] then
s.[1..]
s.Substring 1
else
s
|> fun s -> s + "Mock"
let typeDecl = createType spec name interfaceType docString fields
SynModuleOrNamespace.CreateNamespace (
namespaceId,
decls = (opens |> List.map SynModuleDecl.CreateOpen) @ [ typeDecl ]
)
[ yield! opens |> List.map SynModuleDecl.openAny ; yield typeDecl ]
|> SynModuleOrNamespace.createNamespace namespaceId
open Myriad.Core
/// Myriad generator that creates a record which implements the given interface,
/// but with every field mocked out.

View File

@@ -4,8 +4,6 @@ open System
open System.Text
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Myriad.Core
type internal JsonParseOutputSpec =
{
@@ -15,7 +13,6 @@ type internal JsonParseOutputSpec =
[<RequireQualifiedAccess>]
module internal JsonParseGenerator =
open Fantomas.FCS.Text.Range
open Myriad.Core.Ast
type JsonParseOption =
{
@@ -30,34 +27,23 @@ module internal JsonParseGenerator =
/// (match {indexed} with | null -> raise (System.Collections.Generic.KeyNotFoundException ()) | v -> v)
let assertNotNull (propertyName : SynExpr) (indexed : SynExpr) =
let raiseExpr =
SynExpr.CreateApp (
SynExpr.CreateIdentString "raise",
SynExpr.CreateParen (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Collections" ; "Generic" ; "KeyNotFoundException" ]
),
SynExpr.CreateParen (
SynExpr.CreateApp (
SynExpr.CreateApp (
SynExpr.CreateIdentString "sprintf",
SynExpr.CreateConstString "Required key '%s' not found on JSON object"
),
SynExpr.CreateParen propertyName
)
)
)
)
SynExpr.applyFunction
(SynExpr.createIdent "sprintf")
(SynExpr.CreateConst "Required key '%s' not found on JSON object")
|> SynExpr.applyTo (SynExpr.paren propertyName)
|> SynExpr.paren
|> SynExpr.applyFunction (
SynExpr.createLongIdent [ "System" ; "Collections" ; "Generic" ; "KeyNotFoundException" ]
)
|> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createIdent "raise")
SynExpr.CreateMatch (
indexed,
[
SynMatchClause.Create (SynPat.CreateNull, None, raiseExpr)
SynMatchClause.Create (SynPat.CreateNamed (Ident.Create "v"), None, SynExpr.CreateIdentString "v")
]
)
|> SynExpr.CreateParen
[
SynMatchClause.create SynPat.createNull raiseExpr
SynMatchClause.create (SynPat.named "v") (SynExpr.createIdent "v")
]
|> SynExpr.createMatch indexed
|> SynExpr.paren
/// {node}.AsValue().GetValue<{typeName}> ()
/// If `propertyName` is Some, uses `assertNotNull {node}` instead of `{node}`.
@@ -85,10 +71,8 @@ module internal JsonParseGenerator =
/// {type}.jsonParse {node}
let typeJsonParse (typeName : LongIdent) (node : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent (typeName @ [ Ident.Create "jsonParse" ])),
node
)
node
|> SynExpr.applyFunction (SynExpr.createLongIdent' (typeName @ [ Ident.create "jsonParse" ]))
/// collectionType is e.g. "List"; we'll be calling `ofSeq` on it.
/// body is the body of a lambda which takes a parameter `elt`.
@@ -107,69 +91,41 @@ module internal JsonParseGenerator =
| Some propertyName -> assertNotNull propertyName node
|> SynExpr.callMethod "AsArray"
|> SynExpr.pipeThroughFunction (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]),
SynExpr.createLambda "elt" body
)
SynExpr.applyFunction (SynExpr.createLongIdent [ "Seq" ; "map" ]) (SynExpr.createLambda "elt" body)
)
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ collectionType ; "ofSeq" ]))
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ collectionType ; "ofSeq" ])
/// match {node} with | null -> None | v -> {body} |> Some
/// Use the variable `v` to get access to the `Some`.
let createParseLineOption (node : SynExpr) (body : SynExpr) : SynExpr =
let body = SynExpr.pipeThroughFunction (SynExpr.CreateIdentString "Some") body
let body = SynExpr.pipeThroughFunction (SynExpr.createIdent "Some") body
SynExpr.CreateMatch (
node,
[
SynMatchClause.Create (SynPat.CreateNull, None, SynExpr.CreateIdent (Ident.Create "None"))
SynMatchClause.Create (SynPat.CreateNamed (Ident.Create "v"), None, body)
]
)
[
SynMatchClause.create SynPat.createNull (SynExpr.createIdent "None")
SynMatchClause.create (SynPat.named "v") body
]
|> SynExpr.createMatch node
/// Given e.g. "float", returns "System.Double.Parse"
let parseFunction (typeName : string) : LongIdent =
let qualified =
match AstHelper.qualifyPrimitiveType typeName with
match Primitives.qualifyType typeName with
| Some x -> x
| None -> failwith $"Could not recognise type %s{typeName} as a primitive."
List.append qualified [ Ident.Create "Parse" ]
List.append qualified [ Ident.create "Parse" ]
/// fun kvp -> let key = {key(kvp)} in let value = {value(kvp)} in (key, value))
/// The inputs will be fed with appropriate SynExprs to apply them to the `kvp.Key` and `kvp.Value` args.
let dictionaryMapper (key : SynExpr -> SynExpr) (value : SynExpr -> SynExpr) : SynExpr =
let keyArg =
SynExpr.CreateLongIdent (SynLongIdent.Create [ "kvp" ; "Key" ])
|> SynExpr.CreateParen
let keyArg = SynExpr.createLongIdent [ "kvp" ; "Key" ] |> SynExpr.paren
let valueArg =
SynExpr.CreateLongIdent (SynLongIdent.Create [ "kvp" ; "Value" ])
|> SynExpr.CreateParen
let valueArg = SynExpr.createLongIdent [ "kvp" ; "Value" ] |> SynExpr.paren
SynExpr.LetOrUse (
false,
false,
[
SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create "key"), expr = key keyArg)
],
SynExpr.LetOrUse (
false,
false,
[
SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create "value"), expr = value valueArg)
],
SynExpr.CreateTuple [ SynExpr.CreateIdentString "key" ; SynExpr.CreateIdentString "value" ],
range0,
{
InKeyword = None
}
),
range0,
{
InKeyword = None
}
)
// No need to paren here, we're on the LHS of a `let`
SynExpr.tupleNoParen [ SynExpr.createIdent "key" ; SynExpr.createIdent "value" ]
|> SynExpr.createLet [ SynBinding.basic [ Ident.create "value" ] [] (value valueArg) ]
|> SynExpr.createLet [ SynBinding.basic [ Ident.create "key" ] [] (key keyArg) ]
|> SynExpr.createLambda "kvp"
/// A conforming JSON object has only strings as keys. But it would be reasonable to allow the user
@@ -179,11 +135,52 @@ module internal JsonParseGenerator =
| String -> key
| Uri ->
key
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Uri" ]))
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "System" ; "Uri" ])
| _ ->
failwithf
$"Unable to parse the key type %+A{desiredType} of a JSON object. Keys are strings, and this plugin does not know how to convert to that from a string."
let private parseNumberType
(options : JsonParseOption)
(propertyName : SynExpr option)
(node : SynExpr)
(typeName : string)
=
let basic = asValueGetValue propertyName typeName node
match options.JsonNumberHandlingArg with
| None -> basic
| Some option ->
let cond =
SynExpr.DotGet (SynExpr.createIdent "exc", range0, SynLongIdent.createS "Message", range0)
|> SynExpr.callMethodArg "Contains" (SynExpr.CreateConst "cannot be converted to")
let handler =
asValueGetValue propertyName "string" node
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' (parseFunction typeName))
|> SynExpr.ifThenElse
(SynExpr.equals
option
(SynExpr.createLongIdent
[
"System"
"Text"
"Json"
"Serialization"
"JsonNumberHandling"
"AllowReadingFromString"
]))
SynExpr.reraise
|> SynExpr.ifThenElse cond SynExpr.reraise
basic
|> SynExpr.pipeThroughTryWith
(SynPat.IsInst (
SynType.LongIdent (SynLongIdent.createS' [ "System" ; "InvalidOperationException" ]),
range0
))
handler
/// Given `node.["town"]`, for example, choose how to obtain a JSON value from it.
/// The property name is used in error messages at runtime to show where a JSON
/// parse error occurred; supply `None` to indicate "don't validate".
@@ -199,136 +196,86 @@ module internal JsonParseGenerator =
| DateOnly ->
node
|> asValueGetValue propertyName "string"
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "DateOnly" ; "Parse" ])
)
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "System" ; "DateOnly" ; "Parse" ])
| Uri ->
node
|> asValueGetValue propertyName "string"
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Uri" ]))
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "System" ; "Uri" ])
| Guid ->
node
|> asValueGetValue propertyName "string"
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Guid" ; "Parse" ])
)
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "System" ; "Guid" ; "Parse" ])
| DateTime ->
node
|> asValueGetValue propertyName "string"
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "DateTime" ; "Parse" ])
)
| NumberType typeName ->
let basic = asValueGetValue propertyName typeName node
match options.JsonNumberHandlingArg with
| None -> basic
| Some option ->
let cond =
SynExpr.DotGet (
SynExpr.CreateIdentString "exc",
range0,
SynLongIdent.CreateString "Message",
range0
)
|> SynExpr.callMethodArg
"Contains"
(SynExpr.CreateConst (SynConst.CreateString "cannot be converted to"))
let handler =
asValueGetValue propertyName "string" node
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent (parseFunction typeName))
)
|> SynExpr.ifThenElse
(SynExpr.equals
option
(SynExpr.CreateLongIdent (
SynLongIdent.Create
[
"System"
"Text"
"Json"
"Serialization"
"JsonNumberHandling"
"AllowReadingFromString"
]
)))
SynExpr.reraise
|> SynExpr.ifThenElse cond SynExpr.reraise
basic
|> SynExpr.pipeThroughTryWith
(SynPat.IsInst (
SynType.LongIdent (SynLongIdent.Create [ "System" ; "InvalidOperationException" ]),
range0
))
handler
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "System" ; "DateTime" ; "Parse" ])
| NumberType typeName -> parseNumberType options propertyName node typeName
| PrimitiveType typeName -> asValueGetValueIdent propertyName typeName node
| OptionType ty ->
parseNode None options ty (SynExpr.CreateIdentString "v")
parseNode None options ty (SynExpr.createIdent "v")
|> createParseLineOption node
| ListType ty ->
parseNode None options ty (SynExpr.CreateLongIdent (SynLongIdent.CreateString "elt"))
parseNode None options ty (SynExpr.createIdent "elt")
|> asArrayMapped propertyName "List" node
| ArrayType ty ->
parseNode None options ty (SynExpr.CreateLongIdent (SynLongIdent.CreateString "elt"))
parseNode None options ty (SynExpr.createIdent "elt")
|> asArrayMapped propertyName "Array" node
| IDictionaryType (keyType, valueType) ->
node
|> asObject propertyName
|> SynExpr.pipeThroughFunction (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]),
dictionaryMapper (parseKeyString keyType) (parseNode None options valueType)
)
SynExpr.applyFunction
(SynExpr.createLongIdent [ "Seq" ; "map" ])
(dictionaryMapper (parseKeyString keyType) (parseNode None options valueType))
)
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "dict" ]))
|> SynExpr.pipeThroughFunction (SynExpr.createIdent "dict")
| DictionaryType (keyType, valueType) ->
node
|> asObject propertyName
|> SynExpr.pipeThroughFunction (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]),
dictionaryMapper (parseKeyString keyType) (parseNode None options valueType)
)
SynExpr.applyFunction
(SynExpr.createLongIdent [ "Seq" ; "map" ])
(dictionaryMapper (parseKeyString keyType) (parseNode None options valueType))
)
|> SynExpr.pipeThroughFunction (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]),
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Collections" ; "Generic" ; "KeyValuePair" ]
)
)
SynExpr.applyFunction
(SynExpr.createLongIdent [ "Seq" ; "map" ])
(SynExpr.createLongIdent [ "System" ; "Collections" ; "Generic" ; "KeyValuePair" ])
)
|> SynExpr.pipeThroughFunction (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Collections" ; "Generic" ; "Dictionary" ])
SynExpr.createLongIdent [ "System" ; "Collections" ; "Generic" ; "Dictionary" ]
)
| IReadOnlyDictionaryType (keyType, valueType) ->
node
|> asObject propertyName
|> SynExpr.pipeThroughFunction (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]),
dictionaryMapper (parseKeyString keyType) (parseNode None options valueType)
)
SynExpr.applyFunction
(SynExpr.createLongIdent [ "Seq" ; "map" ])
(dictionaryMapper (parseKeyString keyType) (parseNode None options valueType))
)
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "readOnlyDict" ]))
|> SynExpr.pipeThroughFunction (SynExpr.createIdent "readOnlyDict")
| MapType (keyType, valueType) ->
node
|> asObject propertyName
|> SynExpr.pipeThroughFunction (
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Seq" ; "map" ]),
dictionaryMapper (parseKeyString keyType) (parseNode None options valueType)
)
SynExpr.applyFunction
(SynExpr.createLongIdent [ "Seq" ; "map" ])
(dictionaryMapper (parseKeyString keyType) (parseNode None options valueType))
)
|> SynExpr.pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "Map" ; "ofSeq" ]))
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "Map" ; "ofSeq" ])
| BigInt ->
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "System" ; "Numerics" ; "BigInteger" ; "Parse" ]),
SynExpr.CreateParen (node |> SynExpr.callMethod "ToJsonString")
)
node
|> SynExpr.callMethod "ToJsonString"
|> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "Numerics" ; "BigInteger" ; "Parse" ])
| Measure (_measure, primType) ->
let qualified =
match Primitives.qualifyType primType with
| None -> failwith $"did not recognise type %s{primType} to assign measure"
| Some t -> t
parseNumberType options propertyName node primType
|> SynExpr.pipeThroughFunction (Measure.getLanguagePrimitivesMeasure qualified)
| _ ->
// Let's just hope that we've also got our own type annotation!
let typeName =
@@ -344,9 +291,8 @@ module internal JsonParseGenerator =
/// propertyName is probably a string literal, but it could be a [<Literal>] variable
/// The result of this function is the body of a let-binding (not including the LHS of that let-binding).
let createParseRhs (options : JsonParseOption) (propertyName : SynExpr) (fieldType : SynType) : SynExpr =
SynExpr.CreateIdentString "node"
|> SynExpr.index propertyName
|> parseNode (Some propertyName) options fieldType
let objectToParse = SynExpr.createIdent "node" |> SynExpr.index propertyName
parseNode (Some propertyName) options fieldType objectToParse
let isJsonNumberHandling (literal : LongIdent) : bool =
match List.rev literal |> List.map (fun ident -> ident.idText) with
@@ -357,270 +303,260 @@ module internal JsonParseGenerator =
| [ _ ; "JsonNumberHandling" ; "Serialization" ; "Json" ; "Text" ; "System" ] -> true
| _ -> false
let createMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : SynField list) =
let xmlDoc = PreXmlDoc.Create " Parse from a JSON node."
/// `populateNode` will be inserted before we return the `node` variable.
///
/// That is, we give you access to a `JsonNode` called `node`,
/// and you must return a `typeName`.
let scaffolding (spec : JsonParseOutputSpec) (typeName : LongIdent) (functionBody : SynExpr) : SynModuleDecl =
let xmlDoc = PreXmlDoc.create "Parse from a JSON node."
let returnInfo =
SynBindingReturnInfo.Create (SynType.LongIdent (SynLongIdent.CreateFromLongIdent typeName))
let returnInfo = SynType.createLongIdent typeName
let inputArg = Ident.Create "node"
let functionName = Ident.Create "jsonParse"
let inputArg = "node"
let functionName = Ident.create "jsonParse"
let inputVal =
let memberFlags =
if spec.ExtensionMethods then
{
SynMemberFlags.IsInstance = false
SynMemberFlags.IsDispatchSlot = false
SynMemberFlags.IsOverrideOrExplicitImpl = false
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
|> Some
else
None
let arg =
SynPat.named inputArg
|> SynPat.annotateType (SynType.createLongIdent' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
let thisIdOpt = if spec.ExtensionMethods then None else Some inputArg
if spec.ExtensionMethods then
let binding =
SynBinding.basic [ functionName ] [ arg ] functionBody
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> SynMemberDefn.staticMember
SynValData.SynValData (
memberFlags,
SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty),
thisIdOpt
)
let componentInfo =
SynComponentInfo.createLong typeName
|> SynComponentInfo.withDocString (PreXmlDoc.create "Extension methods for JSON parsing")
let containingType =
SynTypeDefnRepr.augmentation ()
|> SynTypeDefn.create componentInfo
|> SynTypeDefn.withMemberDefns [ binding ]
SynModuleDecl.Types ([ containingType ], range0)
else
SynBinding.basic [ functionName ] [ arg ] functionBody
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> SynModuleDecl.createLet
let getParseOptions (fieldAttrs : SynAttribute list) =
(JsonParseOption.None, fieldAttrs)
||> List.fold (fun options attr ->
if
(SynLongIdent.toString attr.TypeName)
.EndsWith ("JsonNumberHandling", StringComparison.Ordinal)
then
let qualifiedEnumValue =
match SynExpr.stripOptionalParen attr.ArgExpr with
| SynExpr.LongIdent (_, SynLongIdent (ident, _, _), _, _) when isJsonNumberHandling ident ->
// Make sure it's fully qualified
SynExpr.createLongIdent
[
"System"
"Text"
"Json"
"Serialization"
"JsonNumberHandling"
"AllowReadingFromString"
]
| _ -> attr.ArgExpr
{
JsonNumberHandlingArg = Some qualifiedEnumValue
}
else
options
)
let createRecordMaker (spec : JsonParseOutputSpec) (fields : SynFieldData<Ident> list) =
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.mapi (fun i fieldData ->
let propertyNameAttr =
attrs
fieldData.Attrs
|> List.tryFind (fun attr ->
attr.TypeName.AsString.EndsWith ("JsonPropertyName", StringComparison.Ordinal)
(SynLongIdent.toString attr.TypeName)
.EndsWith ("JsonPropertyName", StringComparison.Ordinal)
)
let options =
(JsonParseOption.None, attrs)
||> List.fold (fun options attr ->
if attr.TypeName.AsString.EndsWith ("JsonNumberHandling", StringComparison.Ordinal) then
let qualifiedEnumValue =
match SynExpr.stripOptionalParen attr.ArgExpr with
| SynExpr.LongIdent (_, SynLongIdent (ident, _, _), _, _) when
isJsonNumberHandling ident
->
// Make sure it's fully qualified
SynExpr.CreateLongIdent (
SynLongIdent.Create
[
"System"
"Text"
"Json"
"Serialization"
"JsonNumberHandling"
"AllowReadingFromString"
]
)
| _ -> attr.ArgExpr
{
JsonNumberHandlingArg = Some qualifiedEnumValue
}
else
options
)
let options = getParseOptions fieldData.Attrs
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
if id.idText.Length > 1 then
sb.Append id.idText.[1..] |> ignore
sb.Append (Char.ToLowerInvariant fieldData.Ident.idText.[0])
|> ignore<StringBuilder>
sb.ToString () |> SynConst.CreateString |> SynExpr.CreateConst
if fieldData.Ident.idText.Length > 1 then
sb.Append (fieldData.Ident.idText.Substring 1) |> ignore<StringBuilder>
sb.ToString () |> SynExpr.CreateConst
| Some name -> name.ArgExpr
let pattern =
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ id ],
None,
None,
SynArgPats.Empty,
None,
range0
)
SynBinding.Let (
isInline = false,
isMutable = false,
expr = createParseRhs options propertyName fieldType,
valData = inputVal,
pattern = pattern
)
createParseRhs options propertyName fieldData.Type
|> SynBinding.basic [ Ident.create $"arg_%i{i}" ] []
)
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.mapi (fun i fieldData ->
(SynLongIdent.createI fieldData.Ident, true), Some (SynExpr.createIdent $"arg_%i{i}")
)
|> AstHelper.instantiateRecord
let assignments =
(finalConstruction, assignments)
||> List.fold (fun final assignment ->
SynExpr.LetOrUse (
false,
false,
[ assignment ],
final,
range0,
{
InKeyword = None
}
)
)
(finalConstruction, assignments)
||> List.fold (fun final assignment -> SynExpr.createLet [ assignment ] final)
let pattern =
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ functionName ],
None,
None,
SynArgPats.Pats
[
SynPat.CreateTyped (
SynPat.CreateNamed inputArg,
SynType.LongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
)
)
|> SynPat.CreateParen
],
None,
range0
)
let createUnionMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : UnionCase<Ident> list) =
fields
|> List.map (fun case ->
let propertyName = JsonSerializeGenerator.getPropertyName case.Ident case.Attrs
if spec.ExtensionMethods then
let binding =
SynBinding.SynBinding (
let body =
if case.Fields.IsEmpty then
SynExpr.createLongIdent' (typeName @ [ case.Ident ])
else
case.Fields
|> List.map (fun field ->
let propertyName = JsonSerializeGenerator.getPropertyName field.Ident field.Attrs
let options = getParseOptions field.Attrs
createParseRhs options propertyName field.Type
)
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent' (typeName @ [ case.Ident ]))
|> SynExpr.createLet
[
SynExpr.index (SynExpr.CreateConst "data") (SynExpr.createIdent "node")
|> assertNotNull (SynExpr.CreateConst "data")
|> SynBinding.basic [ Ident.create "node" ] []
]
match propertyName with
| SynExpr.Const (synConst, _) ->
SynMatchClause.SynMatchClause (
SynPat.createConst synConst,
None,
SynBindingKind.Normal,
false,
false,
[],
xmlDoc,
inputVal,
pattern,
Some returnInfo,
assignments,
body,
range0,
DebugPointAtBinding.NoneAtInvisible,
DebugPointAtTarget.Yes,
{
LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0)
InlineKeyword = None
EqualsRange = Some range0
ArrowRange = Some range0
BarRange = Some range0
}
)
| _ ->
SynMatchClause.create (SynPat.named "x") body
|> SynMatchClause.withWhere (SynExpr.equals (SynExpr.createIdent "x") propertyName)
)
|> fun l ->
l
@ [
let fail =
SynExpr.plus (SynExpr.CreateConst "Unrecognised 'type' field value: ") (SynExpr.createIdent "v")
|> SynExpr.paren
|> SynExpr.applyFunction (SynExpr.createIdent "failwith")
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 ],
SynMatchClause.SynMatchClause (
SynPat.named "v",
None,
fail,
range0,
DebugPointAtTarget.Yes,
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
EqualsRange = None
WithKeyword = None
ArrowRange = Some range0
BarRange = Some range0
}
)
]
|> SynExpr.createMatch (SynExpr.createIdent "ty")
|> SynExpr.createLet
[
let property = SynExpr.CreateConst "type"
SynModuleDecl.Types ([ containingType ], range0)
else
let binding =
SynBinding.Let (
isInline = false,
isMutable = false,
xmldoc = xmlDoc,
returnInfo = returnInfo,
expr = assignments,
valData = inputVal,
pattern = pattern
SynExpr.createIdent "node"
|> SynExpr.index property
|> assertNotNull property
|> SynExpr.pipeThroughFunction (
SynExpr.createLambda
"v"
(SynExpr.callGenericMethod "GetValue" [ Ident.create "string" ] (SynExpr.createIdent "v"))
)
|> SynBinding.basic [ Ident.create "ty" ] []
]
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
[ SynAttribute.autoOpen ]
else
[ SynAttribute.requireQualifiedAccess ; 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.createLong moduleName
|> SynComponentInfo.withDocString xmlDoc
|> SynComponentInfo.setAccessibility access
|> SynComponentInfo.addAttributes attributes
List.take (List.length recordId - 1) recordId @ [ expanded ]
else
recordId
let decl =
match synTypeDefnRepr with
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (_accessibility, fields, _range), _) ->
fields |> List.map SynField.extractWithIdent |> createRecordMaker spec
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (_accessibility, cases, _range), _) ->
let optionGet (i : Ident option) =
match i with
| None -> failwith "WoofWare.Myriad requires union cases to have identifiers on each field."
| Some i -> i
let info =
SynComponentInfo.Create (moduleName, attributes = attributes, xmldoc = xmlDoc)
cases
|> List.map SynUnionCase.extract
|> List.map (UnionCase.mapIdentFields optionGet)
|> createUnionMaker spec ident
| _ -> failwithf "Not a record or union type"
let mdl = SynModuleDecl.CreateNestedModule (info, decls)
[ scaffolding spec ident decl ]
|> SynModuleDecl.nestedModule info
|> List.singleton
|> SynModuleOrNamespace.createNamespace namespaceId
SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ mdl ])
| _ -> failwithf "Not a record type"
open Myriad.Core
/// Myriad generator that provides a method (possibly an extension method) for a record type,
/// containing a JSON parse function.
@@ -634,10 +570,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 +611,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

@@ -3,9 +3,6 @@ namespace WoofWare.Myriad.Plugins
open System
open System.Text
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Myriad.Core
type internal JsonSerializeOutputSpec =
{
@@ -15,7 +12,6 @@ type internal JsonSerializeOutputSpec =
[<RequireQualifiedAccess>]
module internal JsonSerializeGenerator =
open Fantomas.FCS.Text.Range
open Myriad.Core.Ast
/// Given `input.Ident`, for example, choose how to add it to the ambient `node`.
/// The result is a line like `(fun ident -> InnerType.toJsonNode ident)` or `(fun ident -> JsonValue.Create ident)`.
@@ -30,9 +26,7 @@ module internal JsonSerializeGenerator =
| Uri ->
// JsonValue.Create<type>
SynExpr.TypeApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ]
),
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ],
range0,
[ fieldType ],
[],
@@ -42,39 +36,24 @@ module internal JsonSerializeGenerator =
)
| OptionType ty ->
// fun field -> match field with | None -> JsonValue.Create null | Some v -> {serializeNode ty} field
SynExpr.CreateMatch (
SynExpr.CreateIdentString "field",
[
SynMatchClause.Create (
SynPat.CreateLongIdent (SynLongIdent.CreateString "None", []),
None,
// The absolutely galaxy-brained implementation of JsonValue has `JsonValue.Parse "null"`
// identically equal to null. We have to work around this later, but we might as well just
// be efficient here and whip up the null directly.
SynExpr.CreateNull
|> SynExpr.upcast' (
SynType.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
)
)
)
let noneClause =
// The absolutely galaxy-brained implementation of JsonValue has `JsonValue.Parse "null"`
// identically equal to null. We have to work around this later, but we might as well just
// be efficient here and whip up the null directly.
SynExpr.createNull ()
|> SynExpr.upcast' (SynType.createLongIdent' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
|> SynMatchClause.create (SynPat.named "None")
SynMatchClause.Create (
SynPat.CreateLongIdent (
SynLongIdent.CreateString "Some",
[ SynPat.CreateNamed (Ident.Create "field") ]
),
None,
SynExpr.CreateApp (serializeNode ty, SynExpr.CreateIdentString "field")
|> SynExpr.CreateParen
|> SynExpr.upcast' (
SynType.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
)
)
)
]
)
let someClause =
SynExpr.applyFunction (serializeNode ty) (SynExpr.createIdent "field")
|> SynExpr.paren
|> SynExpr.upcast' (SynType.createLongIdent' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
|> SynMatchClause.create (
SynPat.identWithArgs [ Ident.create "Some" ] (SynArgPats.create [ Ident.create "field" ])
)
[ noneClause ; someClause ]
|> SynExpr.createMatch (SynExpr.createIdent "field")
|> SynExpr.createLambda "field"
| ArrayType ty
| ListType ty ->
@@ -82,116 +61,69 @@ module internal JsonSerializeGenerator =
// let arr = JsonArray ()
// for mem in field do arr.Add ({serializeNode} mem)
// arr
SynExpr.LetOrUse (
false,
false,
[
SynExpr.ForEach (
DebugPointAtFor.Yes range0,
DebugPointAtInOrTo.Yes range0,
SeqExprOnly.SeqExprOnly false,
true,
SynPat.named "mem",
SynExpr.createIdent "field",
SynExpr.applyFunction
(SynExpr.createLongIdent [ "arr" ; "Add" ])
(SynExpr.paren (SynExpr.applyFunction (serializeNode ty) (SynExpr.createIdent "mem"))),
range0
)
SynExpr.createIdent "arr"
]
|> SynExpr.sequential
|> SynExpr.createLet
[
SynBinding.Let (
pattern = SynPat.CreateNamed (Ident.Create "arr"),
expr =
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonArray" ]
),
SynExpr.CreateConst SynConst.Unit
)
)
],
SynExpr.CreateSequential
[
SynExpr.ForEach (
DebugPointAtFor.Yes range0,
DebugPointAtInOrTo.Yes range0,
SeqExprOnly.SeqExprOnly false,
true,
SynPat.CreateNamed (Ident.Create "mem"),
SynExpr.CreateIdent (Ident.Create "field"),
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "arr" ; "Add" ]),
SynExpr.CreateParen (
SynExpr.CreateApp (serializeNode ty, SynExpr.CreateIdentString "mem")
)
),
range0
)
SynExpr.CreateIdentString "arr"
],
range0,
{
InKeyword = None
}
)
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonArray" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic [ Ident.create "arr" ] []
]
|> 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
// ret.Add (key.ToString (), {serializeNode} value)
// ret
SynExpr.LetOrUse (
false,
false,
[
SynExpr.ForEach (
DebugPointAtFor.Yes range0,
DebugPointAtInOrTo.Yes range0,
SeqExprOnly.SeqExprOnly false,
true,
SynPat.paren (
SynPat.identWithArgs
[ Ident.create "KeyValue" ]
(SynArgPats.create [ Ident.create "key" ; Ident.create "value" ])
),
SynExpr.createIdent "field",
SynExpr.applyFunction
(SynExpr.createLongIdent [ "ret" ; "Add" ])
(SynExpr.tuple
[
SynExpr.createLongIdent [ "key" ; "ToString" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
SynExpr.applyFunction (serializeNode valueType) (SynExpr.createIdent "value")
]),
range0
)
SynExpr.createIdent "ret"
]
|> SynExpr.sequential
|> SynExpr.createLet
[
SynBinding.Let (
pattern = SynPat.CreateNamed (Ident.Create "ret"),
expr =
SynExpr.CreateApp (
SynExpr.CreateLongIdent (
SynLongIdent.Create [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
),
SynExpr.CreateConst SynConst.Unit
)
)
],
SynExpr.CreateSequential
[
SynExpr.ForEach (
DebugPointAtFor.Yes range0,
DebugPointAtInOrTo.Yes range0,
SeqExprOnly.SeqExprOnly false,
true,
SynPat.CreateParen (
SynPat.CreateLongIdent (
SynLongIdent.CreateString "KeyValue",
[
SynPat.CreateParen (
SynPat.Tuple (
false,
[
SynPat.CreateNamed (Ident.Create "key")
SynPat.CreateNamed (Ident.Create "value")
],
[ range0 ],
range0
)
)
]
)
),
SynExpr.CreateIdent (Ident.Create "field"),
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "ret" ; "Add" ]),
SynExpr.CreateParenedTuple
[
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "key" ; "ToString" ]),
SynExpr.CreateConst SynConst.Unit
)
SynExpr.CreateApp (serializeNode valueType, SynExpr.CreateIdentString "value")
]
),
range0
)
SynExpr.CreateIdentString "ret"
],
range0,
{
InKeyword = None
}
)
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic [ Ident.create "ret" ] []
]
|> SynExpr.createLambda "field"
| _ ->
// {type}.toJsonNode
@@ -200,213 +132,189 @@ module internal JsonSerializeGenerator =
| SynType.LongIdent ident -> ident.LongIdent
| _ -> failwith $"Unrecognised type: %+A{fieldType}"
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent (typeName @ [ Ident.Create "toJsonNode" ]))
SynExpr.createLongIdent' (typeName @ [ Ident.create "toJsonNode" ])
/// 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 func = SynExpr.CreateLongIdent (SynLongIdent.Create [ "node" ; "Add" ])
let createSerializeRhsRecord (propertyName : SynExpr) (fieldId : Ident) (fieldType : SynType) : SynExpr =
[
propertyName
SynExpr.applyFunction
(serializeNode fieldType)
(SynExpr.createLongIdent' [ Ident.create "input" ; fieldId ])
]
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
let args =
SynExpr.CreateParenedTuple
[
propertyName
SynExpr.CreateApp (
serializeNode fieldType,
SynExpr.CreateLongIdent (SynLongIdent.CreateFromLongIdent [ Ident.Create "input" ; fieldId ])
)
]
let getPropertyName (fieldId : Ident) (attrs : SynAttribute list) : SynExpr =
let propertyNameAttr =
attrs
|> List.tryFind (fun attr ->
(SynLongIdent.toString attr.TypeName)
.EndsWith ("JsonPropertyName", StringComparison.Ordinal)
)
SynExpr.CreateApp (func, args)
match propertyNameAttr with
| None ->
let sb = StringBuilder fieldId.idText.Length
sb.Append (Char.ToLowerInvariant fieldId.idText.[0]) |> ignore
let createMaker (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (fields : SynField list) =
let xmlDoc = PreXmlDoc.Create " Serialize to a JSON node"
if fieldId.idText.Length > 1 then
sb.Append fieldId.idText.[1..] |> ignore
sb.ToString () |> 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" ])
)
SynLongIdent.createS' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
|> SynType.LongIdent
let inputArg = Ident.Create "input"
let functionName = Ident.Create "toJsonNode"
let inputVal =
let memberFlags =
if spec.ExtensionMethods then
{
SynMemberFlags.IsInstance = false
SynMemberFlags.IsDispatchSlot = false
SynMemberFlags.IsOverrideOrExplicitImpl = false
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
|> Some
else
None
let thisIdOpt = if spec.ExtensionMethods then None else Some inputArg
SynValData.SynValData (
memberFlags,
SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty),
thisIdOpt
)
let functionName = Ident.create "toJsonNode"
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,
false,
[
populateNode
SynExpr.Upcast (SynExpr.createIdent "node", SynType.Anon range0, range0)
]
|> SynExpr.sequential
|> SynExpr.createLet
[
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,
{
InKeyword = None
}
)
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic [ Ident.create "node" ] []
]
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
)
SynPat.namedI inputArgName
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create typeName))
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 componentInfo =
SynComponentInfo.createLong typeName
|> SynComponentInfo.withDocString (PreXmlDoc.create "Extension methods for JSON parsing")
let mem = SynMemberDefn.Member (binding, range0)
let memberDef =
assignments
|> SynBinding.basic [ functionName ] [ pattern ]
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation returnInfo
|> SynMemberDefn.staticMember
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
}
)
SynTypeDefnRepr.augmentation ()
|> SynTypeDefn.create componentInfo
|> SynTypeDefn.withMemberDefns [ memberDef ]
SynModuleDecl.Types ([ containingType ], range0)
else
let binding =
SynBinding.Let (
isInline = false,
isMutable = false,
xmldoc = xmlDoc,
returnInfo = returnInfo,
expr = assignments,
valData = inputVal,
pattern = pattern
assignments
|> SynBinding.basic [ functionName ] [ pattern ]
|> SynBinding.withReturnAnnotation returnInfo
|> SynBinding.withXmlDoc xmlDoc
|> SynModuleDecl.createLet
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.sequential
|> 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.create (typeName @ [ unionCase.Ident ]),
None,
None,
argPats,
None,
range0
)
SynModuleDecl.CreateLet [ binding ]
let typeLine =
[
SynExpr.CreateConst "type"
SynExpr.applyFunction
(SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonValue" ; "Create" ])
propertyName
]
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
let createRecordModule
let dataNode =
SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())
|> SynBinding.basic [ Ident.create "dataNode" ] []
let dataBindings =
(unionCase.Fields, caseNames)
||> List.zip
|> List.map (fun (fieldData, caseName) ->
let propertyName = getPropertyName (Option.get fieldData.Ident) fieldData.Attrs
let node =
SynExpr.applyFunction (serializeNode fieldData.Type) (SynExpr.createIdent' caseName)
[ propertyName ; node ]
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "dataNode" ; "Add" ])
)
let assignToNode =
[ SynExpr.CreateConst "data" ; SynExpr.createIdent "dataNode" ]
|> SynExpr.tuple
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "node" ; "Add" ])
let dataNode =
SynExpr.sequential (dataBindings @ [ assignToNode ])
|> SynExpr.createLet [ dataNode ]
let action =
[
yield typeLine
if not dataBindings.IsEmpty then
yield dataNode
]
|> SynExpr.sequential
SynMatchClause.create pattern action
)
|> SynExpr.createMatch (SynExpr.createIdent' inputArg)
|> scaffolding spec typeName inputArg
let createModule
(namespaceId : LongIdent)
(opens : SynOpenDeclTarget list)
(spec : JsonSerializeOutputSpec)
@@ -415,60 +323,63 @@ 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
[ SynAttribute.autoOpen ]
else
[ SynAttribute.requireQualifiedAccess ; 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.createLong moduleName
|> SynComponentInfo.addAttributes attributes
|> SynComponentInfo.setAccessibility access
|> SynComponentInfo.withDocString 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)
[
yield! opens |> List.map SynModuleDecl.openAny
yield SynModuleDecl.nestedModule info decls
]
|> SynModuleOrNamespace.createNamespace namespaceId
let mdl = SynModuleDecl.CreateNestedModule (info, decls)
SynModuleOrNamespace.CreateNamespace (
namespaceId,
decls = (opens |> List.map SynModuleDecl.CreateOpen) @ [ mdl ]
)
| _ -> failwithf "Not a record type"
open Myriad.Core
/// Myriad generator that provides a method (possibly an extension method) for a record type,
/// containing a JSON serialization function.
@@ -482,10 +393,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 +436,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

@@ -0,0 +1,24 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
[<RequireQualifiedAccess>]
module internal Measure =
let getLanguagePrimitivesMeasure (typeName : LongIdent) : SynExpr =
match typeName |> List.map _.idText with
| [ "System" ; "Single" ] -> [ "LanguagePrimitives" ; "Float32WithMeasure" ]
| [ "System" ; "Double" ] -> [ "LanguagePrimitives" ; "FloatWithMeasure" ]
| [ "System" ; "Byte" ] -> [ "LanguagePrimitives" ; "ByteWithMeasure" ]
| [ "System" ; "SByte" ] -> [ "LanguagePrimitives" ; "SByteWithMeasure" ]
| [ "System" ; "Int16" ] -> [ "LanguagePrimitives" ; "Int16WithMeasure" ]
| [ "System" ; "Int32" ] -> [ "LanguagePrimitives" ; "Int32WithMeasure" ]
| [ "System" ; "Int64" ] -> [ "LanguagePrimitives" ; "Int64WithMeasure" ]
| [ "System" ; "UInt16" ] -> [ "LanguagePrimitives" ; "UInt16WithMeasure" ]
| [ "System" ; "UInt32" ] -> [ "LanguagePrimitives" ; "UInt32WithMeasure" ]
| [ "System" ; "UInt64" ] -> [ "LanguagePrimitives" ; "UInt64WithMeasure" ]
| l ->
let l = String.concat "." l
failwith $"unrecognised type for measure: %s{l}"
|> SynExpr.createLongIdent

View File

@@ -0,0 +1,30 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal Primitives =
/// Given e.g. "byte", returns "System.Byte".
let qualifyType (typeName : string) : LongIdent option =
match typeName with
| "float32"
| "single" -> [ "System" ; "Single" ] |> Some
| "float"
| "double" -> [ "System" ; "Double" ] |> Some
| "byte"
| "uint8" -> [ "System" ; "Byte" ] |> Some
| "sbyte"
| "int8" -> [ "System" ; "SByte" ] |> Some
| "int16" -> [ "System" ; "Int16" ] |> Some
| "int"
| "int32" -> [ "System" ; "Int32" ] |> Some
| "int64" -> [ "System" ; "Int64" ] |> Some
| "uint16" -> [ "System" ; "UInt16" ] |> Some
| "uint"
| "uint32" -> [ "System" ; "UInt32" ] |> Some
| "uint64" -> [ "System" ; "UInt64" ] |> Some
| "char" -> [ "System" ; "Char" ] |> Some
| "decimal" -> [ "System" ; "Decimal" ] |> Some
| _ -> None
|> Option.map (List.map (fun i -> (Ident (i, range0))))

View File

@@ -1,14 +1,11 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Myriad.Core
[<RequireQualifiedAccess>]
module internal RemoveOptionsGenerator =
open Fantomas.FCS.Text.Range
open Myriad.Core.Ast
let private removeOption (s : SynField) : SynField =
let (SynField.SynField (synAttributeLists,
@@ -47,7 +44,7 @@ module internal RemoveOptionsGenerator =
(fields : SynField list)
=
let fields : SynField list = fields |> List.map removeOption
let name = Ident.Create "Short"
let name = Ident.create "Short"
let record =
{
@@ -63,94 +60,51 @@ module internal RemoveOptionsGenerator =
SynModuleDecl.Types ([ typeDecl ], range0)
let createMaker (withOptionsType : LongIdent) (withoutOptionsType : LongIdent) (fields : SynField list) =
let xmlDoc = PreXmlDoc.Create " Remove the optional members of the input."
let createMaker (withOptionsType : LongIdent) (withoutOptionsType : LongIdent) (fields : SynFieldData<Ident> list) =
let xmlDoc = PreXmlDoc.create "Remove the optional members of the input."
let returnInfo =
SynBindingReturnInfo.Create (SynType.LongIdent (SynLongIdent.CreateFromLongIdent withOptionsType))
let inputArg = Ident.Create "input"
let functionName = Ident.Create "shorten"
let inputVal =
SynValData.SynValData (
None,
SynValInfo.SynValInfo ([ [ SynArgInfo.CreateId functionName ] ], SynArgInfo.Empty),
Some inputArg
)
let inputArg = Ident.create "input"
let functionName = Ident.create "shorten"
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 (
SynExpr.LongIdent (
false,
SynLongIdent.SynLongIdent (
[ Ident.Create "op_PipeRight" ],
[],
[ Some (IdentTrivia.OriginalNotation "|>") ]
),
None,
range0
),
accessor
),
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.CreateString "Option.defaultWith"),
SynExpr.CreateLongIdent (
SynLongIdent.CreateFromLongIdent (
withoutOptionsType @ [ Ident.Create (sprintf "Default%s" id.idText) ]
)
)
)
accessor
|> SynExpr.pipeThroughFunction (
SynExpr.applyFunction
(SynExpr.createLongIdent [ "Option" ; "defaultWith" ])
(SynExpr.createLongIdent' (
withoutOptionsType
@ [ Ident.create (sprintf "Default%s" fieldData.Ident.idText) ]
))
)
| _ -> accessor
(SynLongIdent.CreateFromLongIdent [ id ], true), Some body
(SynLongIdent.createI fieldData.Ident, true), Some body
)
|> AstHelper.instantiateRecord
let pattern =
SynPat.LongIdent (
SynLongIdent.CreateFromLongIdent [ functionName ],
None,
None,
SynArgPats.Pats
[
SynPat.CreateTyped (
SynPat.CreateNamed inputArg,
SynType.LongIdent (SynLongIdent.CreateFromLongIdent withoutOptionsType)
)
|> SynPat.CreateParen
],
None,
range0
)
let binding =
SynBinding.Let (
isInline = false,
isMutable = false,
xmldoc = xmlDoc,
returnInfo = returnInfo,
expr = body,
valData = inputVal,
pattern = pattern
)
SynModuleDecl.CreateLet [ binding ]
SynBinding.basic
[ functionName ]
[
SynPat.named inputArg.idText
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create withoutOptionsType))
]
body
|> SynBinding.withXmlDoc xmlDoc
|> SynBinding.withReturnAnnotation (SynType.LongIdent (SynLongIdent.create withOptionsType))
|> SynModuleDecl.createLet
let createRecordModule (namespaceId : LongIdent) (typeDefn : SynTypeDefn) =
let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) =
@@ -160,35 +114,35 @@ 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
]
let attributes =
[
SynAttributeList.Create (SynAttribute.RequireQualifiedAccess ())
SynAttributeList.Create SynAttribute.compilationRepresentation
createType (Some doc) accessibility typeParams fields
createMaker [ Ident.create "Short" ] recordId fieldData
]
let xmlDoc =
recordId
|> Seq.map (fun i -> i.idText)
|> String.concat "."
|> sprintf " Module containing an option-truncated version of the %s type"
|> PreXmlDoc.Create
|> sprintf "Module containing an option-truncated version of the %s type"
|> PreXmlDoc.create
let info =
SynComponentInfo.Create (recordId, attributes = attributes, xmldoc = xmlDoc)
SynComponentInfo.createLong recordId
|> SynComponentInfo.withDocString xmlDoc
|> SynComponentInfo.addAttributes [ SynAttribute.compilationRepresentation ]
|> SynComponentInfo.addAttributes [ SynAttribute.requireQualifiedAccess ]
let mdl = SynModuleDecl.CreateNestedModule (info, decls)
SynModuleOrNamespace.CreateNamespace (namespaceId, decls = [ mdl ])
SynModuleDecl.nestedModule info decls
|> List.singleton
|> SynModuleOrNamespace.createNamespace namespaceId
| _ -> failwithf "Not a record type"
open Myriad.Core
/// Myriad generator that stamps out a record with option types stripped
/// from the fields at the top level.
[<MyriadGenerator("remove-options")>]

View File

@@ -1,31 +0,0 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
open Myriad.Core
[<RequireQualifiedAccess>]
module internal SynAttribute =
let internal compilationRepresentation : SynAttribute =
{
TypeName = SynLongIdent.CreateString "CompilationRepresentation"
ArgExpr =
SynExpr.CreateLongIdent (
false,
SynLongIdent.Create [ "CompilationRepresentationFlags" ; "ModuleSuffix" ],
None
)
|> SynExpr.CreateParen
Target = None
AppliesToGetterAndSetter = false
Range = range0
}
let internal autoOpen : SynAttribute =
{
TypeName = SynLongIdent.CreateString "AutoOpen"
ArgExpr = SynExpr.CreateConst SynConst.Unit
Target = None
AppliesToGetterAndSetter = false
Range = range0
}

View File

@@ -1,325 +0,0 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Myriad.Core
open Myriad.Core.Ast
open Fantomas.FCS.Text.Range
type internal CompExprBinding =
| LetBang of varName : string * rhs : SynExpr
| Let of varName : string * rhs : SynExpr
| Use of varName : string * rhs : SynExpr
| Do of body : SynExpr
[<RequireQualifiedAccess>]
module internal SynExpr =
/// {expr} |> {func}
let pipeThroughFunction (func : SynExpr) (expr : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "op_PipeRight" ],
[],
[ Some (IdentTrivia.OriginalNotation "|>") ]
)
),
expr
),
func
)
/// if {cond} then {trueBranch} else {falseBranch}
/// Note that this function puts the trueBranch last, for pipelining convenience:
/// we assume that the `else` branch is more like an error case and is less interesting.
let ifThenElse (cond : SynExpr) (falseBranch : SynExpr) (trueBranch : SynExpr) : SynExpr =
SynExpr.IfThenElse (
cond,
trueBranch,
Some falseBranch,
DebugPointAtBinding.Yes range0,
false,
range0,
{
IfKeyword = range0
IsElif = false
ThenKeyword = range0
ElseKeyword = Some range0
IfToThenRange = range0
}
)
/// try {body} with | {exc} as exc -> {handler}
let pipeThroughTryWith (exc : SynPat) (handler : SynExpr) (body : SynExpr) : SynExpr =
let clause =
SynMatchClause.Create (SynPat.As (exc, SynPat.CreateNamed (Ident.Create "exc"), range0), None, handler)
SynExpr.TryWith (
body,
[ clause ],
range0,
DebugPointAtTry.Yes range0,
DebugPointAtWith.Yes range0,
{
TryKeyword = range0
TryToWithRange = range0
WithKeyword = range0
WithToEndRange = range0
}
)
/// {a} = {b}
let equals (a : SynExpr) (b : SynExpr) =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
Ident.CreateLong "op_Equality",
[],
[ Some (IdentTrivia.OriginalNotation "=") ]
)
),
a
),
b
)
/// {a} + {b}
let plus (a : SynExpr) (b : SynExpr) =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
Ident.CreateLong "op_Addition",
[],
[ Some (IdentTrivia.OriginalNotation "+") ]
)
),
a
),
b
)
let rec stripOptionalParen (expr : SynExpr) : SynExpr =
match expr with
| SynExpr.Paren (expr, _, _, _) -> stripOptionalParen expr
| expr -> expr
/// {obj}.{meth} {arg}
let callMethodArg (meth : string) (arg : SynExpr) (obj : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.DotGet (
obj,
range0,
SynLongIdent.SynLongIdent (id = [ Ident.Create meth ], dotRanges = [], trivia = [ None ]),
range0
),
arg
)
/// {obj}.{meth}()
let callMethod (meth : string) (obj : SynExpr) : SynExpr =
callMethodArg meth (SynExpr.CreateConst SynConst.Unit) obj
let callGenericMethod (meth : string) (ty : LongIdent) (obj : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.TypeApp (
SynExpr.DotGet (obj, range0, SynLongIdent.Create [ meth ], range0),
range0,
[ SynType.LongIdent (SynLongIdent.CreateFromLongIdent ty) ],
[],
Some range0,
range0,
range0
),
SynExpr.CreateConst SynConst.Unit
)
/// {obj}.{meth}<ty>()
let callGenericMethod' (meth : string) (ty : string) (obj : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.TypeApp (
SynExpr.DotGet (obj, range0, SynLongIdent.Create [ meth ], range0),
range0,
[ SynType.CreateLongIdent ty ],
[],
Some range0,
range0,
range0
),
SynExpr.CreateConst SynConst.Unit
)
let index (property : SynExpr) (obj : SynExpr) : SynExpr =
SynExpr.DotIndexedGet (obj, property, range0, range0)
/// (fun {varName} -> {body})
let createLambda (varName : string) (body : SynExpr) : SynExpr =
let parsedDataPat = [ SynPat.CreateNamed (Ident.Create varName) ]
SynExpr.Lambda (
false,
false,
SynSimplePats.Create [ SynSimplePat.CreateId (Ident.Create varName) ],
body,
Some (parsedDataPat, body),
range0,
{
ArrowRange = Some range0
}
)
|> SynExpr.CreateParen
let reraise : SynExpr =
SynExpr.CreateApp (SynExpr.CreateIdent (Ident.Create "reraise"), SynExpr.CreateConst SynConst.Unit)
/// {body} |> fun a -> Async.StartAsTask (a, ?cancellationToken=ct)
let startAsTask (ct : SynLongIdent) (body : SynExpr) =
let lambda =
SynExpr.CreateApp (
SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "StartAsTask" ]),
SynExpr.CreateParenedTuple
[
SynExpr.CreateLongIdent (SynLongIdent.CreateString "a")
equals
(SynExpr.LongIdent (true, SynLongIdent.CreateString "cancellationToken", None, range0))
(SynExpr.CreateLongIdent ct)
]
)
|> createLambda "a"
pipeThroughFunction lambda body
/// {compExpr} { {lets} ; return {ret} }
let createCompExpr (compExpr : string) (retBody : SynExpr) (lets : CompExprBinding list) : SynExpr =
let retStatement = SynExpr.YieldOrReturn ((false, true), retBody, range0)
let contents : SynExpr =
(retStatement, List.rev lets)
||> List.fold (fun state binding ->
match binding with
| LetBang (lhs, rhs) ->
SynExpr.LetOrUseBang (
DebugPointAtBinding.Yes range0,
false,
true,
SynPat.CreateNamed (Ident.Create lhs),
rhs,
[],
state,
range0,
{
EqualsRange = Some range0
}
)
| Let (lhs, rhs) ->
SynExpr.LetOrUse (
false,
false,
[ SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create lhs), expr = rhs) ],
state,
range0,
{
SynExprLetOrUseTrivia.InKeyword = None
}
)
| Use (lhs, rhs) ->
SynExpr.LetOrUse (
false,
true,
[ SynBinding.Let (pattern = SynPat.CreateNamed (Ident.Create lhs), expr = rhs) ],
state,
range0,
{
SynExprLetOrUseTrivia.InKeyword = None
}
)
| Do body -> SynExpr.CreateSequential [ SynExpr.Do (body, range0) ; state ]
)
SynExpr.CreateApp (
SynExpr.CreateIdent (Ident.Create compExpr),
SynExpr.ComputationExpr (false, contents, range0)
)
/// {expr} |> Async.AwaitTask
let awaitTask (expr : SynExpr) : SynExpr =
expr
|> pipeThroughFunction (SynExpr.CreateLongIdent (SynLongIdent.Create [ "Async" ; "AwaitTask" ]))
/// {ident}.ToString ()
/// with special casing for some types like DateTime
let toString (ty : SynType) (ident : SynExpr) =
match ty with
| DateOnly -> ident |> callMethodArg "ToString" (SynExpr.CreateConstString "yyyy-MM-dd")
| DateTime ->
ident
|> callMethodArg "ToString" (SynExpr.CreateConstString "yyyy-MM-ddTHH:mm:ss")
| _ -> callMethod "ToString" ident
let upcast' (ty : SynType) (e : SynExpr) = SynExpr.Upcast (e, ty, range0)
let synBindingTriviaZero (isMember : bool) =
{
SynBindingTrivia.EqualsRange = Some range0
InlineKeyword = None
LeadingKeyword =
if isMember then
SynLeadingKeyword.Member range0
else
SynLeadingKeyword.Let range0
}
/// {ident} - {rhs}
let minus (ident : SynLongIdent) (rhs : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "op_Subtraction" ],
[],
[ Some (IdentTrivia.OriginalNotation "-") ]
)
),
SynExpr.CreateLongIdent ident
),
rhs
)
/// {ident} - {n}
let minusN (ident : SynLongIdent) (n : int) : SynExpr =
minus ident (SynExpr.CreateConst (SynConst.Int32 n))
/// {y} > {x}
let greaterThan (x : SynExpr) (y : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "op_GreaterThan" ],
[],
[ Some (IdentTrivia.OriginalNotation ">") ]
)
),
y
),
x
)
/// {y} >= {x}
let greaterThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr =
SynExpr.CreateApp (
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
[ Ident.Create "op_GreaterThanOrEqual" ],
[],
[ Some (IdentTrivia.OriginalNotation ">=") ]
)
),
y
),
x
)

View File

@@ -0,0 +1,49 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
type internal CompExprBinding =
| LetBang of varName : string * rhs : SynExpr
| Let of varName : string * rhs : SynExpr
| Use of varName : string * rhs : SynExpr
| Do of body : SynExpr
(*
Potential API!
type internal CompExprBindings =
private
{
/// These are stored in reverse.
Bindings : CompExprBinding list
CompExprName : string
}
[<RequireQualifiedAccess>]
module internal CompExprBindings =
let make (name : string) : CompExprBindings =
{
Bindings = []
CompExprName = name
}
let thenDo (body : SynExpr) (bindings : CompExprBindings) =
{ bindings with
Bindings = (Do body :: bindings.Bindings)
}
let thenLet (varName : string) (value : SynExpr) (bindings : CompExprBindings) =
{ bindings with
Bindings = (Let (varName, value) :: bindings.Bindings)
}
let thenLetBang (varName : string) (value : SynExpr) (bindings : CompExprBindings) =
{ bindings with
Bindings = (LetBang (varName, value) :: bindings.Bindings)
}
let thenUse (varName : string) (value : SynExpr) (bindings : CompExprBindings) =
{ bindings with
Bindings = (LetBang (varName, value) :: bindings.Bindings)
}
*)

View File

@@ -3,12 +3,14 @@ namespace WoofWare.Myriad.Plugins
open System
open System.Text
open Fantomas.FCS.Syntax
open Myriad.Core
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal Ident =
let inline create (s : string) = Ident (s, range0)
let lowerFirstLetter (x : Ident) : Ident =
let result = StringBuilder x.idText.Length
result.Append (Char.ToLowerInvariant x.idText.[0]) |> ignore
result.Append x.idText.[1..] |> ignore
Ident.Create ((result : StringBuilder).ToString ())
create ((result : StringBuilder).ToString ())

View File

@@ -0,0 +1,9 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Xml
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal PreXmlDoc =
let create (s : string) : PreXmlDoc =
PreXmlDoc.Create ([| " " + s |], range0)

View File

@@ -0,0 +1,16 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
[<RequireQualifiedAccess>]
module internal SynArgPats =
let create (caseNames : Ident list) : SynArgPats =
match caseNames.Length with
| 0 -> SynArgPats.Pats []
| 1 -> [ SynPat.named caseNames.[0].idText ] |> SynArgPats.Pats
| _ ->
caseNames
|> List.map (fun i -> SynPat.named i.idText)
|> SynPat.tuple
|> List.singleton
|> SynArgPats.Pats

View File

@@ -0,0 +1,36 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynAttribute =
let internal compilationRepresentation : SynAttribute =
{
TypeName = SynLongIdent.createS "CompilationRepresentation"
ArgExpr =
[ "CompilationRepresentationFlags" ; "ModuleSuffix" ]
|> SynExpr.createLongIdent
|> SynExpr.paren
Target = None
AppliesToGetterAndSetter = false
Range = range0
}
let internal requireQualifiedAccess : SynAttribute =
{
TypeName = SynLongIdent.createS "RequireQualifiedAccess"
ArgExpr = SynExpr.CreateConst ()
Target = None
AppliesToGetterAndSetter = false
Range = range0
}
let internal autoOpen : SynAttribute =
{
TypeName = SynLongIdent.createS "AutoOpen"
ArgExpr = SynExpr.CreateConst ()
Target = None
AppliesToGetterAndSetter = false
Range = range0
}

View File

@@ -0,0 +1,204 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynBinding =
let rec private stripParen (pat : SynPat) =
match pat with
| SynPat.Paren (p, _) -> stripParen p
| _ -> pat
let rec private getName (pat : SynPat) : Ident option =
match stripParen pat with
| SynPat.Named (SynIdent.SynIdent (name, _), _, _, _) -> Some name
| SynPat.Typed (pat, _, _) -> getName pat
| SynPat.LongIdent (SynLongIdent.SynLongIdent (longIdent, _, _), _, _, _, _, _) ->
match longIdent with
| [ x ] -> Some x
| _ -> failwithf "got long ident %O ; can only get the name of a long ident with one component" longIdent
| _ -> None
let private getArgInfo (pat : SynPat) : SynArgInfo list =
// TODO: this only copes with one layer of tupling
match stripParen pat with
| SynPat.Tuple (_, pats, _, _) -> pats |> List.map (fun pat -> SynArgInfo.SynArgInfo ([], false, getName pat))
| pat -> [ SynArgInfo.SynArgInfo (SynAttributes.Empty, false, getName pat) ]
let triviaZero (isMember : bool) =
{
SynBindingTrivia.EqualsRange = Some range0
InlineKeyword = None
LeadingKeyword =
if isMember then
SynLeadingKeyword.Member range0
else
SynLeadingKeyword.Let range0
}
let basic (name : LongIdent) (args : SynPat list) (body : SynExpr) : SynBinding =
let valInfo : SynValInfo =
args
|> List.map getArgInfo
|> fun x -> SynValInfo.SynValInfo (x, SynArgInfo.SynArgInfo ([], false, None))
SynBinding.SynBinding (
None,
SynBindingKind.Normal,
false,
false,
[],
PreXmlDoc.Empty,
SynValData.SynValData (None, valInfo, None),
SynPat.identWithArgs name (SynArgPats.Pats args),
None,
body,
range0,
DebugPointAtBinding.Yes range0,
triviaZero false
)
let withAccessibility (acc : SynAccess option) (binding : SynBinding) : SynBinding =
match binding with
| SynBinding (_, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
let headPat =
match headPat with
| SynPat.LongIdent (ident, extra, options, argPats, _, range) ->
SynPat.LongIdent (ident, extra, options, argPats, acc, range)
| _ -> failwithf "unrecognised head pattern: %O" headPat
SynBinding (acc, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia)
let withXmlDoc (doc : PreXmlDoc) (binding : SynBinding) : SynBinding =
match binding with
| SynBinding (acc, kind, inl, mut, attrs, _, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
SynBinding (acc, kind, inl, mut, attrs, doc, valData, headPat, returnInfo, expr, range, debugPoint, trivia)
let withReturnAnnotation (ty : SynType) (binding : SynBinding) : SynBinding =
match binding with
| SynBinding (acc, kind, inl, mut, attrs, doc, valData, headPat, _, expr, range, debugPoint, trivia) ->
let retInfo =
SynBindingReturnInfo.SynBindingReturnInfo (
ty,
range0,
[],
{
ColonRange = Some range0
}
)
SynBinding (
acc,
kind,
inl,
mut,
attrs,
doc,
valData,
headPat,
Some retInfo,
expr,
range,
debugPoint,
trivia
)
let inline makeInline (binding : SynBinding) : SynBinding =
match binding with
| SynBinding (acc, kind, _, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia) ->
SynBinding (
acc,
kind,
true,
mut,
attrs,
doc,
valData,
headPat,
ret,
expr,
range,
debugPoint,
{ trivia with
InlineKeyword = Some range0
}
)
let inline makeNotInline (binding : SynBinding) : SynBinding =
match binding with
| SynBinding (acc, kind, _, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia) ->
SynBinding (
acc,
kind,
false,
mut,
attrs,
doc,
valData,
headPat,
ret,
expr,
range,
debugPoint,
{ trivia with
InlineKeyword = None
}
)
let inline setInline (isInline : bool) (binding : SynBinding) : SynBinding =
if isInline then
makeInline binding
else
makeNotInline binding
let makeStaticMember (binding : SynBinding) : SynBinding =
let memberFlags =
{
SynMemberFlags.IsInstance = false
SynMemberFlags.IsDispatchSlot = false
SynMemberFlags.IsOverrideOrExplicitImpl = false
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
match binding with
| SynBinding (acc, kind, inl, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia) ->
let valData =
match valData with
| SynValData.SynValData (_, valInfo, _) -> SynValData.SynValData (Some memberFlags, valInfo, None)
let trivia =
{ trivia with
LeadingKeyword = SynLeadingKeyword.StaticMember (range0, range0)
}
SynBinding (acc, kind, inl, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia)
let makeInstanceMember (binding : SynBinding) : SynBinding =
let memberFlags =
{
SynMemberFlags.IsInstance = true
SynMemberFlags.IsDispatchSlot = false
SynMemberFlags.IsOverrideOrExplicitImpl = true
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
match binding with
| SynBinding (acc, kind, inl, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia) ->
let valData =
match valData with
| SynValData.SynValData (_, valInfo, _) -> SynValData.SynValData (Some memberFlags, valInfo, None)
let trivia =
{ trivia with
LeadingKeyword = SynLeadingKeyword.Member range0
}
SynBinding (acc, kind, inl, mut, attrs, doc, valData, headPat, ret, expr, range, debugPoint, trivia)

View File

@@ -0,0 +1,50 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Xml
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynComponentInfo =
let inline createLong (name : LongIdent) =
SynComponentInfo.SynComponentInfo ([], None, [], name, PreXmlDoc.Empty, false, None, range0)
let inline create (name : Ident) = createLong [ name ]
let inline withDocString (doc : PreXmlDoc) (i : SynComponentInfo) : SynComponentInfo =
match i with
| SynComponentInfo.SynComponentInfo (attrs, typars, constraints, name, _, postfix, access, range) ->
SynComponentInfo (attrs, typars, constraints, name, doc, postfix, access, range)
let inline setGenerics (typars : SynTyparDecls option) (i : SynComponentInfo) : SynComponentInfo =
match i with
| SynComponentInfo.SynComponentInfo (attrs, _, constraints, name, doc, postfix, access, range) ->
SynComponentInfo (attrs, typars, constraints, name, doc, postfix, access, range)
let inline withGenerics (typars : SynTyparDecl list) (i : SynComponentInfo) : SynComponentInfo =
let inner =
if typars.IsEmpty then
None
else
Some (SynTyparDecls.PostfixList (typars, [], range0))
setGenerics inner i
let inline setAccessibility (acc : SynAccess option) (i : SynComponentInfo) : SynComponentInfo =
match i with
| SynComponentInfo.SynComponentInfo (attrs, typars, constraints, name, doc, postfix, _, range) ->
SynComponentInfo.SynComponentInfo (attrs, typars, constraints, name, doc, postfix, acc, range)
let inline withAccessibility (acc : SynAccess) (i : SynComponentInfo) : SynComponentInfo =
setAccessibility (Some acc) i
let inline addAttributes (attrs : SynAttribute list) (i : SynComponentInfo) : SynComponentInfo =
match i with
| SynComponentInfo.SynComponentInfo (oldAttrs, typars, constraints, name, doc, postfix, acc, range) ->
let attrs =
{
SynAttributeList.Attributes = attrs
SynAttributeList.Range = range0
}
SynComponentInfo.SynComponentInfo ((attrs :: oldAttrs), typars, constraints, name, doc, postfix, acc, range)

View File

@@ -0,0 +1,314 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Myriad.Core
open Fantomas.FCS.Text.Range
[<AutoOpen>]
module internal SynExprExtensions =
type SynExpr with
static member CreateConst (s : string) : SynExpr =
SynExpr.Const (SynConst.String (s, SynStringKind.Regular, range0), range0)
static member CreateConst () : SynExpr = SynExpr.Const (SynConst.Unit, range0)
static member CreateConst (i : int32) : SynExpr =
SynExpr.Const (SynConst.Int32 i, range0)
[<RequireQualifiedAccess>]
module internal SynExpr =
/// {f} {x}
let applyFunction (f : SynExpr) (x : SynExpr) : SynExpr = SynExpr.CreateApp (f, x)
/// {f} {x}
let inline applyTo (x : SynExpr) (f : SynExpr) : SynExpr = applyFunction f x
/// {expr} |> {func}
let pipeThroughFunction (func : SynExpr) (expr : SynExpr) : SynExpr =
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.pipe, expr)
|> applyTo func
/// if {cond} then {trueBranch} else {falseBranch}
/// Note that this function puts the trueBranch last, for pipelining convenience:
/// we assume that the `else` branch is more like an error case and is less interesting.
let ifThenElse (cond : SynExpr) (falseBranch : SynExpr) (trueBranch : SynExpr) : SynExpr =
SynExpr.IfThenElse (
cond,
trueBranch,
Some falseBranch,
DebugPointAtBinding.Yes range0,
false,
range0,
{
IfKeyword = range0
IsElif = false
ThenKeyword = range0
ElseKeyword = Some range0
IfToThenRange = range0
}
)
/// try {body} with | {exc} as exc -> {handler}
let pipeThroughTryWith (exc : SynPat) (handler : SynExpr) (body : SynExpr) : SynExpr =
let clause =
SynMatchClause.create (SynPat.As (exc, SynPat.named "exc", range0)) handler
SynExpr.TryWith (
body,
[ clause ],
range0,
DebugPointAtTry.Yes range0,
DebugPointAtWith.Yes range0,
{
TryKeyword = range0
TryToWithRange = range0
WithKeyword = range0
WithToEndRange = range0
}
)
/// {a} = {b}
let equals (a : SynExpr) (b : SynExpr) =
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.eq, a) |> applyTo b
/// {a} + {b}
let plus (a : SynExpr) (b : SynExpr) =
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
Ident.CreateLong "op_Addition",
[],
[ Some (IdentTrivia.OriginalNotation "+") ]
)
),
a
)
|> applyTo b
/// {a} * {b}
let times (a : SynExpr) (b : SynExpr) =
SynExpr.CreateAppInfix (
SynExpr.CreateLongIdent (
SynLongIdent.SynLongIdent (
Ident.CreateLong "op_Multiply",
[],
[ Some (IdentTrivia.OriginalNotation "*") ]
)
),
a
)
|> applyTo b
let rec stripOptionalParen (expr : SynExpr) : SynExpr =
match expr with
| SynExpr.Paren (expr, _, _, _) -> stripOptionalParen expr
| expr -> expr
/// {obj}.{meth} {arg}
let callMethodArg (meth : string) (arg : SynExpr) (obj : SynExpr) : SynExpr =
SynExpr.DotGet (
obj,
range0,
SynLongIdent.SynLongIdent (id = [ Ident.create meth ], dotRanges = [], trivia = [ None ]),
range0
)
|> applyTo arg
/// {obj}.{meth}()
let callMethod (meth : string) (obj : SynExpr) : SynExpr =
callMethodArg meth (SynExpr.CreateConst ()) obj
let callGenericMethod (meth : string) (ty : LongIdent) (obj : SynExpr) : SynExpr =
SynExpr.TypeApp (
SynExpr.DotGet (obj, range0, SynLongIdent.createS meth, range0),
range0,
[ SynType.LongIdent (SynLongIdent.create ty) ],
[],
Some range0,
range0,
range0
)
|> applyTo (SynExpr.CreateConst ())
/// {obj}.{meth}<ty>()
let callGenericMethod' (meth : string) (ty : string) (obj : SynExpr) : SynExpr =
SynExpr.TypeApp (
SynExpr.DotGet (obj, range0, SynLongIdent.createS meth, range0),
range0,
[ SynType.createLongIdent' [ ty ] ],
[],
Some range0,
range0,
range0
)
|> applyTo (SynExpr.CreateConst ())
let inline index (property : SynExpr) (obj : SynExpr) : SynExpr =
SynExpr.DotIndexedGet (obj, property, range0, range0)
let inline paren (e : SynExpr) : SynExpr =
SynExpr.Paren (e, range0, Some range0, range0)
/// (fun {varName} -> {body})
let createLambda (varName : string) (body : SynExpr) : SynExpr =
let parsedDataPat = [ SynPat.named varName ]
SynExpr.Lambda (
false,
false,
SynSimplePats.Create [ SynSimplePat.CreateId (Ident.Create varName) ],
body,
Some (parsedDataPat, body),
range0,
{
ArrowRange = Some range0
}
)
|> paren
let createThunk (body : SynExpr) : SynExpr =
SynExpr.Lambda (
false,
false,
SynSimplePats.Create [],
body,
Some ([ SynPat.unit ], body),
range0,
{
ArrowRange = Some range0
}
)
|> paren
let inline createIdent (s : string) : SynExpr = SynExpr.Ident (Ident (s, range0))
let inline createIdent' (i : Ident) : SynExpr = SynExpr.Ident i
let inline createLongIdent' (ident : Ident list) : SynExpr =
SynExpr.LongIdent (false, SynLongIdent.create ident, None, range0)
let inline createLongIdent (ident : string list) : SynExpr =
createLongIdent' (ident |> List.map Ident.create)
let tupleNoParen (args : SynExpr list) : SynExpr =
SynExpr.Tuple (false, args, List.replicate (args.Length - 1) range0, range0)
let inline tuple (args : SynExpr list) = args |> tupleNoParen |> paren
/// {body} |> fun a -> Async.StartAsTask (a, ?cancellationToken=ct)
let startAsTask (ct : Ident) (body : SynExpr) =
let lambda =
[
createIdent "a"
equals
(SynExpr.LongIdent (true, SynLongIdent.createS "cancellationToken", None, range0))
(createIdent' ct)
]
|> tuple
|> applyFunction (createLongIdent [ "Async" ; "StartAsTask" ])
|> createLambda "a"
pipeThroughFunction lambda body
let inline createLet (bindings : SynBinding list) (body : SynExpr) : SynExpr =
SynExpr.LetOrUse (false, false, bindings, body, range0, SynExprLetOrUseTrivia.empty)
let inline createMatch (matchOn : SynExpr) (cases : SynMatchClause list) : SynExpr =
SynExpr.Match (
DebugPointAtBinding.Yes range0,
matchOn,
cases,
range0,
{
MatchKeyword = range0
WithKeyword = range0
}
)
let typeAnnotate (ty : SynType) (expr : SynExpr) : SynExpr = SynExpr.Typed (expr, ty, range0)
let inline createNew (ty : SynType) (args : SynExpr) : SynExpr =
SynExpr.New (false, ty, paren args, range0)
let inline createWhile (cond : SynExpr) (body : SynExpr) : SynExpr =
SynExpr.While (DebugPointAtWhile.Yes range0, cond, body, range0)
let inline createNull () : SynExpr = SynExpr.Null range0
let reraise : SynExpr = createIdent "reraise" |> applyTo (SynExpr.CreateConst ())
let sequential (exprs : SynExpr list) : SynExpr =
exprs
|> List.reduce (fun a b -> SynExpr.Sequential (DebugPointAtSequential.SuppressNeither, false, a, b, range0))
/// {compExpr} { {lets} ; return {ret} }
let createCompExpr (compExpr : string) (retBody : SynExpr) (lets : CompExprBinding list) : SynExpr =
let retStatement = SynExpr.YieldOrReturn ((false, true), retBody, range0)
let contents : SynExpr =
(retStatement, List.rev lets)
||> List.fold (fun state binding ->
match binding with
| LetBang (lhs, rhs) ->
SynExpr.LetOrUseBang (
DebugPointAtBinding.Yes range0,
false,
true,
SynPat.named lhs,
rhs,
[],
state,
range0,
{
EqualsRange = Some range0
}
)
| Let (lhs, rhs) -> createLet [ SynBinding.basic [ Ident.create lhs ] [] rhs ] state
| Use (lhs, rhs) ->
SynExpr.LetOrUse (
false,
true,
[ SynBinding.basic [ Ident.create lhs ] [] rhs ],
state,
range0,
{
SynExprLetOrUseTrivia.InKeyword = None
}
)
| Do body -> sequential [ SynExpr.Do (body, range0) ; state ]
)
applyFunction (createIdent compExpr) (SynExpr.ComputationExpr (false, contents, range0))
/// {expr} |> Async.AwaitTask
let awaitTask (expr : SynExpr) : SynExpr =
expr |> pipeThroughFunction (createLongIdent [ "Async" ; "AwaitTask" ])
/// {ident}.ToString ()
/// with special casing for some types like DateTime
let toString (ty : SynType) (ident : SynExpr) =
match ty with
| DateOnly -> ident |> callMethodArg "ToString" (SynExpr.CreateConst "yyyy-MM-dd")
| DateTime -> ident |> callMethodArg "ToString" (SynExpr.CreateConst "yyyy-MM-ddTHH:mm:ss")
| _ -> callMethod "ToString" ident
let upcast' (ty : SynType) (e : SynExpr) = SynExpr.Upcast (e, ty, range0)
/// {ident} - {rhs}
let minus (ident : SynLongIdent) (rhs : SynExpr) : SynExpr =
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.sub, SynExpr.CreateLongIdent ident)
|> applyTo rhs
/// {ident} - {n}
let minusN (ident : SynLongIdent) (n : int) : SynExpr = minus ident (SynExpr.CreateConst n)
/// {y} > {x}
let greaterThan (x : SynExpr) (y : SynExpr) : SynExpr =
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.ge, y) |> applyTo x
/// {y} >= {x}
let greaterThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr =
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.geq, y)
|> applyTo x

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,69 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Text.Range
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
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
)
let make (data : SynFieldData<Ident option>) : SynField =
let attrs : SynAttributeList list =
data.Attrs
|> List.map (fun l ->
{
Attributes = [ l ]
Range = range0
}
)
SynField.SynField (
attrs,
false,
data.Ident,
data.Type,
false,
PreXmlDoc.Empty,
None,
range0,
SynFieldTrivia.Zero
)
let withDocString (doc : PreXmlDoc) (f : SynField) : SynField =
match f with
| SynField (attributes, isStatic, idOpt, fieldType, isMutable, _, accessibility, range, trivia) ->
SynField (attributes, isStatic, idOpt, fieldType, isMutable, doc, accessibility, range, trivia)

View File

@@ -0,0 +1,106 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Text.Range
open Fantomas.FCS.Syntax
[<RequireQualifiedAccess>]
module internal SynLongIdent =
let geq =
SynLongIdent.SynLongIdent (
[ Ident.create "op_GreaterThanOrEqual" ],
[],
[ Some (IdentTrivia.OriginalNotation ">=") ]
)
let ge =
SynLongIdent.SynLongIdent ([ Ident.create "op_GreaterThan" ], [], [ Some (IdentTrivia.OriginalNotation ">") ])
let sub =
SynLongIdent.SynLongIdent ([ Ident.create "op_Subtraction" ], [], [ Some (IdentTrivia.OriginalNotation "-") ])
let eq =
SynLongIdent.SynLongIdent ([ Ident.create "op_Equality" ], [], [ Some (IdentTrivia.OriginalNotation "=") ])
let pipe =
SynLongIdent.SynLongIdent ([ Ident.create "op_PipeRight" ], [], [ Some (IdentTrivia.OriginalNotation "|>") ])
let toString (sli : SynLongIdent) : string =
sli.LongIdent |> List.map _.idText |> String.concat "."
let create (ident : LongIdent) : SynLongIdent =
let commas =
match ident with
| [] -> []
| _ :: commas -> commas |> List.map (fun _ -> range0)
SynLongIdent.SynLongIdent (ident, commas, List.replicate ident.Length None)
let inline createI (i : Ident) : SynLongIdent = create [ i ]
let inline createS (s : string) : SynLongIdent = createI (Ident (s, range0))
let inline createS' (s : string list) : SynLongIdent =
create (s |> List.map (fun i -> Ident (i, range0)))
let isUnit (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when System.String.Equals (i.idText, "unit", System.StringComparison.OrdinalIgnoreCase) -> true
| _ -> false
let isList (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when System.String.Equals (i.idText, "list", System.StringComparison.OrdinalIgnoreCase) -> true
// TODO: consider FSharpList or whatever it is
| _ -> false
let isArray (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when
System.String.Equals (i.idText, "array", System.StringComparison.OrdinalIgnoreCase)
|| System.String.Equals (i.idText, "[]", System.StringComparison.Ordinal)
->
true
| _ -> false
let isOption (ident : SynLongIdent) : bool =
match ident.LongIdent with
| [ i ] when System.String.Equals (i.idText, "option", System.StringComparison.OrdinalIgnoreCase) -> true
// TODO: consider Microsoft.FSharp.Option or whatever it is
| _ -> false
let isResponse (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "Response" ]
| [ "RestEase" ; "Response" ] -> true
| _ -> false
let isMap (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "Map" ] -> true
| _ -> false
let isReadOnlyDictionary (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "IReadOnlyDictionary" ]
| [ "Generic" ; "IReadOnlyDictionary" ]
| [ "Collections" ; "Generic" ; "IReadOnlyDictionary" ]
| [ "System" ; "Collections" ; "Generic" ; "IReadOnlyDictionary" ] -> true
| _ -> false
let isDictionary (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "Dictionary" ]
| [ "Generic" ; "Dictionary" ]
| [ "Collections" ; "Generic" ; "Dictionary" ]
| [ "System" ; "Collections" ; "Generic" ; "Dictionary" ] -> true
| _ -> false
let isIDictionary (ident : SynLongIdent) : bool =
match ident.LongIdent |> List.map _.idText with
| [ "IDictionary" ]
| [ "Generic" ; "IDictionary" ]
| [ "Collections" ; "Generic" ; "IDictionary" ]
| [ "System" ; "Collections" ; "Generic" ; "IDictionary" ] -> true
| _ -> false

View File

@@ -0,0 +1,24 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynMatchClause =
let create (lhs : SynPat) (rhs : SynExpr) : SynMatchClause =
SynMatchClause.SynMatchClause (
lhs,
None,
rhs,
range0,
DebugPointAtTarget.Yes,
{
ArrowRange = Some range0
BarRange = Some range0
}
)
let withWhere (where : SynExpr) (m : SynMatchClause) : SynMatchClause =
match m with
| SynMatchClause (synPat, _, resultExpr, range, debugPointAtTarget, synMatchClauseTrivia) ->
SynMatchClause (synPat, Some where, resultExpr, range, debugPointAtTarget, synMatchClauseTrivia)

View File

@@ -0,0 +1,65 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Text.Range
open Fantomas.FCS.Xml
[<RequireQualifiedAccess>]
module internal SynMemberDefn =
let private interfaceMemberSlotFlags =
{
SynMemberFlags.IsInstance = true
SynMemberFlags.IsDispatchSlot = true
SynMemberFlags.IsOverrideOrExplicitImpl = false
SynMemberFlags.IsFinal = false
SynMemberFlags.GetterOrSetterIsCompilerGenerated = false
SynMemberFlags.MemberKind = SynMemberKind.Member
}
let abstractMember
(ident : SynIdent)
(typars : SynTyparDecls option)
(arity : SynValInfo)
(xmlDoc : PreXmlDoc)
(returnType : SynType)
: SynMemberDefn
=
let slot =
SynValSig.SynValSig (
[],
ident,
SynValTyparDecls.SynValTyparDecls (typars, true),
returnType,
arity,
false,
false,
xmlDoc,
None,
None,
range0,
{
EqualsRange = None
WithKeyword = None
InlineKeyword = None
LeadingKeyword = SynLeadingKeyword.Abstract range0
}
)
SynMemberDefn.AbstractSlot (
slot,
interfaceMemberSlotFlags,
range0,
{
GetSetKeywords = None
}
)
let staticMember (binding : SynBinding) : SynMemberDefn =
let binding = SynBinding.makeStaticMember binding
SynMemberDefn.Member (binding, range0)
let memberImplementation (binding : SynBinding) : SynMemberDefn =
let binding = SynBinding.makeInstanceMember binding
SynMemberDefn.Member (binding, range0)

View File

@@ -0,0 +1,28 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynModuleDecl =
let inline openAny (ident : SynOpenDeclTarget) : SynModuleDecl = SynModuleDecl.Open (ident, range0)
let inline createLets (bindings : SynBinding list) : SynModuleDecl =
SynModuleDecl.Let (false, bindings, range0)
let inline createLet (binding : SynBinding) : SynModuleDecl = createLets [ binding ]
let nestedModule (info : SynComponentInfo) (decls : SynModuleDecl list) : SynModuleDecl =
SynModuleDecl.NestedModule (
info,
false,
decls,
false,
range0,
{
ModuleKeyword = Some range0
EqualsRange = Some range0
}
)

View File

@@ -0,0 +1,24 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Xml
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynModuleOrNamespace =
let createNamespace (name : LongIdent) (decls : SynModuleDecl list) =
SynModuleOrNamespace.SynModuleOrNamespace (
name,
false,
SynModuleOrNamespaceKind.DeclaredNamespace,
decls,
PreXmlDoc.Empty,
[],
None,
range0,
{
LeadingKeyword = SynModuleOrNamespaceLeadingKeyword.Namespace range0
}
)

View File

@@ -0,0 +1,35 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynPat =
let inline paren (pat : SynPat) : SynPat = SynPat.Paren (pat, range0)
let inline annotateTypeNoParen (ty : SynType) (pat : SynPat) = SynPat.Typed (pat, ty, range0)
let inline annotateType (ty : SynType) (pat : SynPat) = paren (annotateTypeNoParen ty pat)
let inline named (s : string) : SynPat =
SynPat.Named (SynIdent.SynIdent (Ident (s, range0), None), false, None, range0)
let inline namedI (i : Ident) : SynPat =
SynPat.Named (SynIdent.SynIdent (i, None), false, None, range0)
let inline identWithArgs (i : LongIdent) (args : SynArgPats) : SynPat =
SynPat.LongIdent (SynLongIdent.create i, None, None, args, None, range0)
let inline tupleNoParen (elements : SynPat list) : SynPat =
match elements with
| [] -> failwith "Can't tuple no elements in a pattern"
| [ p ] -> p
| elements -> SynPat.Tuple (false, elements, List.replicate (elements.Length - 1) range0, range0)
let inline tuple (elements : SynPat list) : SynPat = tupleNoParen elements |> paren
let inline createConst (c : SynConst) = SynPat.Const (c, range0)
let unit = createConst SynConst.Unit
let createNull = SynPat.Null range0

View File

@@ -0,0 +1,250 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynType =
let rec stripOptionalParen (ty : SynType) : SynType =
match ty with
| SynType.Paren (ty, _) -> stripOptionalParen ty
| ty -> ty
let inline createLongIdent (ident : LongIdent) : SynType =
SynType.LongIdent (SynLongIdent.create ident)
let inline createLongIdent' (ident : string list) : SynType =
SynType.LongIdent (SynLongIdent.createS' ident)
let inline named (name : string) = createLongIdent' [ name ]
let inline app' (name : SynType) (args : SynType list) : SynType =
if args.IsEmpty then
failwith "Type cannot be applied to no arguments"
SynType.App (name, Some range0, args, List.replicate (args.Length - 1) range0, Some range0, false, range0)
let inline app (name : string) (args : SynType list) : SynType = app' (named name) args
let inline appPostfix (name : string) (arg : SynType) : SynType =
SynType.App (named name, None, [ arg ], [], None, true, range0)
let inline funFromDomain (domain : SynType) (range : SynType) : SynType =
SynType.Fun (
domain,
range,
range0,
{
ArrowRange = range0
}
)
let inline signatureParamOfType (ty : SynType) (name : Ident option) : SynType =
SynType.SignatureParameter ([], false, name, ty, range0)
let inline var (ty : SynTypar) : SynType = SynType.Var (ty, range0)
let unit : SynType = named "unit"
let int : SynType = named "int"
/// Given ['a1, 'a2] and 'ret, returns 'a1 -> 'a2 -> 'ret.
let toFun (inputs : SynType list) (ret : SynType) : SynType =
(ret, List.rev inputs) ||> List.fold (fun ty input -> funFromDomain input ty)
[<AutoOpen>]
module internal SynTypePatterns =
let (|OptionType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when SynLongIdent.isOption ident ->
Some innerType
| _ -> None
let (|UnitType|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident when SynLongIdent.isUnit ident -> Some ()
| _ -> None
let (|ListType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when SynLongIdent.isList ident ->
Some innerType
| _ -> None
let (|ArrayType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when SynLongIdent.isArray ident ->
Some innerType
| SynType.Array (1, innerType, _) -> Some innerType
| _ -> None
let (|RestEaseResponseType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when SynLongIdent.isResponse ident ->
Some innerType
| _ -> None
let (|DictionaryType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when SynLongIdent.isDictionary ident ->
Some (key, value)
| _ -> None
let (|IDictionaryType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when SynLongIdent.isIDictionary ident ->
Some (key, value)
| _ -> None
let (|IReadOnlyDictionaryType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when
SynLongIdent.isReadOnlyDictionary ident
->
Some (key, value)
| _ -> None
let (|MapType|_|) (fieldType : SynType) =
match fieldType with
| SynType.App (SynType.LongIdent ident, _, [ key ; value ], _, _, _, _) when SynLongIdent.isMap ident ->
Some (key, value)
| _ -> None
let (|BigInt|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map _.idText with
| [ "bigint" ]
| [ "BigInteger" ]
| [ "Numerics" ; "BigInteger" ]
| [ "System" ; "Numerics" ; "BigInteger" ] -> Some ()
| _ -> None
| _ -> None
/// Returns the type, qualified as in e.g. `System.Boolean`.
let (|PrimitiveType|_|) (fieldType : SynType) : LongIdent option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] -> Primitives.qualifyType i.idText
| _ -> None
| _ -> None
let (|String|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] ->
[ "string" ]
|> List.tryFind (fun s -> s = i.idText)
|> Option.map ignore<string>
| _ -> None
| _ -> None
let (|Byte|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] -> [ "byte" ] |> List.tryFind (fun s -> s = i.idText) |> Option.map ignore<string>
| _ -> None
| _ -> None
let (|Guid|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "Guid" ]
| [ "Guid" ] -> Some ()
| _ -> None
| _ -> None
let (|HttpResponseMessage|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "Net" ; "Http" ; "HttpResponseMessage" ]
| [ "Net" ; "Http" ; "HttpResponseMessage" ]
| [ "Http" ; "HttpResponseMessage" ]
| [ "HttpResponseMessage" ] -> Some ()
| _ -> None
| _ -> None
let (|HttpContent|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "Net" ; "Http" ; "HttpContent" ]
| [ "Net" ; "Http" ; "HttpContent" ]
| [ "Http" ; "HttpContent" ]
| [ "HttpContent" ] -> Some ()
| _ -> None
| _ -> None
let (|Stream|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent |> List.map (fun i -> i.idText) with
| [ "System" ; "IO" ; "Stream" ]
| [ "IO" ; "Stream" ]
| [ "Stream" ] -> Some ()
| _ -> None
| _ -> None
let (|NumberType|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent ident ->
match ident.LongIdent with
| [ i ] -> [ "string" ; "float" ; "int" ; "bool" ] |> List.tryFind (fun s -> s = i.idText)
| _ -> None
| _ -> None
let (|Measure|_|) (fieldType : SynType) : (Ident * string) option =
match fieldType with
| SynType.App (NumberType outer,
_,
[ SynType.LongIdent (SynLongIdent.SynLongIdent ([ ident ], _, _)) ],
_,
_,
_,
_) -> Some (ident, outer)
| _ -> None
let (|DateOnly|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "DateOnly" ]
| [ "DateOnly" ] -> Some ()
| _ -> None
| _ -> None
let (|DateTime|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "DateTime" ]
| [ "DateTime" ] -> Some ()
| _ -> None
| _ -> None
let (|Uri|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "Uri" ]
| [ "Uri" ] -> Some ()
| _ -> None
| _ -> None
let (|Task|_|) (fieldType : SynType) : SynType option =
match fieldType with
| SynType.App (SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)), _, args, _, _, _, _) ->
match ident |> List.map (fun i -> i.idText) with
| [ "Task" ]
| [ "Tasks" ; "Task" ]
| [ "Threading" ; "Tasks" ; "Task" ]
| [ "System" ; "Threading" ; "Tasks" ; "Task" ] ->
match args with
| [ arg ] -> Some arg
| _ -> failwithf "Expected Task to be applied to exactly one arg, but got: %+A" args
| _ -> None
| _ -> None

View File

@@ -0,0 +1,27 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.SyntaxTrivia
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynTypeDefn =
let inline create (componentInfo : SynComponentInfo) (repr : SynTypeDefnRepr) : SynTypeDefn =
SynTypeDefn.SynTypeDefn (
componentInfo,
repr,
[],
None,
range0,
{
LeadingKeyword = SynTypeDefnLeadingKeyword.Type range0
EqualsRange = Some range0
WithKeyword = None
}
)
let inline withMemberDefns (members : SynMemberDefn list) (r : SynTypeDefn) : SynTypeDefn =
match r with
| SynTypeDefn (typeInfo, typeRepr, _, ctor, range, trivia) ->
SynTypeDefn.SynTypeDefn (typeInfo, typeRepr, members, ctor, range, trivia)

View File

@@ -0,0 +1,20 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynTypeDefnRepr =
let inline interfaceType (mems : SynMemberDefns) : SynTypeDefnRepr =
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Unspecified, mems, range0)
/// Indicates the body of a `type Foo with {body}` extension type declaration.
let inline augmentation () : SynTypeDefnRepr =
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0)
let inline union (cases : SynUnionCase list) : SynTypeDefnRepr =
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (None, cases, range0), range0)
let inline record (fields : SynField list) : SynTypeDefnRepr =
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, fields, range0), range0)

View File

@@ -0,0 +1,41 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
type internal UnionCase<'Ident> =
{
Fields : SynFieldData<'Ident> list
Attrs : SynAttribute list
Ident : Ident
}
[<RequireQualifiedAccess>]
module internal UnionCase =
let mapIdentFields<'a, 'b> (f : 'a -> 'b) (unionCase : UnionCase<'a>) : UnionCase<'b> =
{
Fields = unionCase.Fields |> List.map (SynField.mapIdent f)
Attrs = unionCase.Attrs
Ident = unionCase.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

@@ -1,10 +0,0 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
[<RequireQualifiedAccess>]
module internal SynType =
let rec stripOptionalParen (ty : SynType) : SynType =
match ty with
| SynType.Paren (ty, _) -> stripOptionalParen ty
| ty -> ty

View File

@@ -25,11 +25,29 @@
<ItemGroup>
<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="Primitives.fs" />
<Compile Include="SynExpr\PreXmlDoc.fs" />
<Compile Include="SynExpr\Ident.fs" />
<Compile Include="SynExpr\SynLongIdent.fs" />
<Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" />
<Compile Include="SynExpr\SynPat.fs" />
<Compile Include="SynExpr\SynBinding.fs" />
<Compile Include="SynExpr\SynType.fs" />
<Compile Include="SynExpr\SynMatchClause.fs" />
<Compile Include="SynExpr\CompExpr.fs" />
<Compile Include="SynExpr\SynExpr.fs" />
<Compile Include="SynExpr\SynArgPats.fs" />
<Compile Include="SynExpr\SynField.fs" />
<Compile Include="SynExpr\SynUnionCase.fs" />
<Compile Include="SynExpr\SynTypeDefnRepr.fs" />
<Compile Include="SynExpr\SynTypeDefn.fs" />
<Compile Include="SynExpr\SynComponentInfo.fs" />
<Compile Include="SynExpr\SynMemberDefn.fs" />
<Compile Include="SynExpr\SynAttribute.fs" />
<Compile Include="SynExpr\SynModuleDecl.fs" />
<Compile Include="SynExpr\SynModuleOrNamespace.fs" />
<Compile Include="Measure.fs" />
<Compile Include="AstHelper.fs" />
<Compile Include="RemoveOptionsGenerator.fs"/>
<Compile Include="InterfaceMockGenerator.fs"/>
<Compile Include="JsonSerializeGenerator.fs"/>

View File

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

View File

@@ -45,44 +45,19 @@
packages = {
fantomas = dotnetTool null "fantomas" (builtins.fromJSON (builtins.readFile ./.config/dotnet-tools.json)).tools.fantomas.version (builtins.head (builtins.filter (elem: elem.pname == "fantomas") ((import ./nix/deps.nix) {fetchNuGet = x: x;}))).sha256;
fsharp-analyzers = dotnetTool "FSharp.Analyzers.Cli" "fsharp-analyzers" (builtins.fromJSON (builtins.readFile ./.config/dotnet-tools.json)).tools.fsharp-analyzers.version (builtins.head (builtins.filter (elem: elem.pname == "fsharp-analyzers") ((import ./nix/deps.nix) {fetchNuGet = x: x;}))).sha256;
fetchDeps = let
flags = [];
runtimeIds = ["win-x64"] ++ map (system: pkgs.dotnetCorePackages.systemToDotnetRid system) dotnet-sdk.meta.platforms;
in
pkgs.writeShellScriptBin "fetch-${pname}-deps" (builtins.readFile (pkgs.substituteAll {
src = ./nix/fetchDeps.sh;
pname = pname;
binPath = pkgs.lib.makeBinPath [pkgs.coreutils dotnet-sdk (pkgs.nuget-to-nix.override {inherit dotnet-sdk;})];
projectFiles = toString ["./WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj" "./ConsumePlugin/ConsumePlugin.fsproj" "./WoofWare.Myriad.Plugins.Attributes/WoofWare.Myriad.Plugins.Attributes.fsproj"];
testProjectFiles = ["./WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj" "./WoofWare.Myriad.Plugins.Attributes/Test/Woofware.Myriad.Plugins.Attributes.Test.fsproj"];
rids = pkgs.lib.concatStringsSep "\" \"" runtimeIds;
packages = dotnet-sdk.packages;
storeSrc = pkgs.srcOnly {
src = ./.;
pname = pname;
version = version;
};
}));
default = pkgs.buildDotnetModule {
pname = pname;
inherit pname version dotnet-sdk dotnet-runtime;
name = "WoofWare.Myriad.Plugins";
version = version;
src = ./.;
projectFile = "./WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj";
nugetDeps = ./nix/deps.nix;
testProjectFile = "./WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj";
disabledTests = ["WoofWare.Myriad.Plugins.Test.TestSurface.CheckVersionAgainstRemote"];
nugetDeps = ./nix/deps.nix; # `nix build .#default.passthru.fetch-deps && ./result` and put the result here
doCheck = true;
dotnet-sdk = dotnet-sdk;
dotnet-runtime = dotnet-runtime;
};
};
devShell = pkgs.mkShell {
buildInputs = with pkgs; [
(with dotnetCorePackages;
combinePackages [
dotnet-sdk_8
dotnetPackages.Nuget
])
];
buildInputs = [dotnet-sdk];
packages = [
pkgs.alejandra
pkgs.nodePackages.markdown-link-check

View File

@@ -1,20 +1,15 @@
# This file was automatically generated by passthru.fetch-deps.
# Please don't edit it manually, your changes might get overwritten!
# Please dont edit it manually, your changes might get overwritten!
{fetchNuGet}: [
(fetchNuGet {
pname = "fsharp-analyzers";
version = "0.26.0";
sha256 = "sha256-60Bl36LOb/zVNdH2SBSuQ5O41lP9dKTNZbs5vvYs+3U=";
pname = "ApiSurface";
version = "4.0.41";
sha256 = "03kfa5ngmgkik9lc58sp8s9rrh9g40hhgjnrv662ks0d0y2i9i89";
})
(fetchNuGet {
pname = "fantomas";
version = "6.3.4";
sha256 = "sha256-1aWqZynBkQoznenGoP0sbf1PcUXAbcHiWyECuv89xa0=";
})
(fetchNuGet {
pname = "ApiSurface";
version = "4.0.40";
sha256 = "1c9z0b6minlripwrjmv4yd5w8zj4lcpak4x41izh7ygx8kgmbvx0";
version = "6.3.9";
sha256 = "1b34iiiff02bbzjv03zyna8xmrgs6y87zdvp5i5k58fcqpjw44sx";
})
(fetchNuGet {
pname = "Fantomas.Core";
@@ -31,6 +26,11 @@
version = "2.16.6";
sha256 = "176rwky6b5rk8dzldiz4068p7m9c5y9ygzbhadrs14jkl94pc56n";
})
(fetchNuGet {
pname = "fsharp-analyzers";
version = "0.26.0";
sha256 = "0xgv5kvbwfdvcp6s8x7xagbbi4s3mqa4ixni6pazqvyflbgnah7b";
})
(fetchNuGet {
pname = "FSharp.Core";
version = "4.3.4";
@@ -56,66 +56,26 @@
version = "6.0.26";
sha256 = "1d8nkz24vsm0iy2xm8y5ak2q1w1p99dxyz0y26acs6sfk2na0vm6";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Ref";
version = "8.0.1";
sha256 = "0yaaiqq7mi6sclyrb1v0fyncanbx0ifmnnhv9whynqj8439jsdwh";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.linux-arm64";
version = "6.0.26";
sha256 = "1za8lc52m4z54d68wd64c2nhzy05g3gx171k5cdlx73fbymiys9z";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.linux-arm64";
version = "8.0.1";
sha256 = "0dsdgqg7566qximmjfza4x9if3icy4kskq698ddj5apdia88h2mw";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.linux-x64";
version = "6.0.26";
sha256 = "1zpbmz6z8758gwywzg0bac8kx9x39sxxc9j4a4r2jl74l9ssw4vm";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.linux-x64";
version = "8.0.1";
sha256 = "1gjz379y61ag9whi78qxx09bwkwcznkx2mzypgycibxk61g11da1";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.osx-arm64";
version = "6.0.26";
sha256 = "1i8ydlwjzk7j0mzvn0rpljxfp1h50zwaqalnyvfxai1fwgigzgw5";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.osx-arm64";
version = "8.0.1";
sha256 = "0w3mrs4zdl9mfanl1j81759xwwrzmicsjxn6yfxv5yrxbxzq695n";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.osx-x64";
version = "6.0.26";
sha256 = "02src68hd3213sd1a2ms1my7i92knfmdxclvv90il9cky2zsq8kw";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.osx-x64";
version = "8.0.1";
sha256 = "0a9aljr4fy4haq6ndz2y723liv5hbfpss1rn45s88nmgcp27m15m";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.win-x64";
version = "6.0.26";
sha256 = "1gxlmfdkfzmhw9pac5jiv674nn6i1zymcp2hj81irjwhhjk01mf5";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Runtime.win-x64";
version = "8.0.1";
sha256 = "01kzndyqmsvcq49i2jrv7ymfp0l71yxfylv1cy3nhkdbprqz8ipx";
})
(fetchNuGet {
pname = "Microsoft.Build.Tasks.Git";
version = "8.0.0";
sha256 = "0055f69q3hbagqp8gl3nk0vfn4qyqyxsxyy7pd0g7wm3z28byzmx";
})
(fetchNuGet {
pname = "Microsoft.CodeCoverage";
version = "17.10.0";
@@ -131,111 +91,46 @@
version = "6.0.26";
sha256 = "19y6c6v20bgf7x7rrh4rx9y7s5fy8vp5m4j9b6gi1wp4rpb5mza4";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.linux-arm64";
version = "8.0.1";
sha256 = "0dhpdlcdz7adcfh9w01fc867051m35fqaxnvj3fqvqhgcm2n3143";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.linux-x64";
version = "6.0.26";
sha256 = "0p7hhidaa3mnyiwnsijwy8578v843x8hh99255s69qwwyld6falv";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.linux-x64";
version = "8.0.1";
sha256 = "1aw6mc7zcmzs1grxz2wa9cw9kfj8pz7zpj417xnp1a9n4ix1bxgr";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.osx-arm64";
version = "6.0.26";
sha256 = "1mq11xsv9g1vsasp6k80y7xlvwi9hrpk5dgm773fvy8538s01gfv";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.osx-arm64";
version = "8.0.1";
sha256 = "1dzg3prng9zfdzz7gcgywjdbwzhwm85j89z0jahynxx4q2dra4b9";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.osx-x64";
version = "6.0.26";
sha256 = "1chac9b4424ihrrnlzvc7qz6j4ymfjyv4kzyazzzw19yhymdkh2s";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.osx-x64";
version = "8.0.1";
sha256 = "010f8wn15s2kv7yyzgys3pv9i1mxw20hpv1ig2zhybjxs8lpj8jj";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.win-x64";
version = "6.0.26";
sha256 = "0i7g9fsqjnbh9rc6807m57r2idg5pkcw6xjfwhnxkcpgqm96258v";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.win-x64";
version = "8.0.1";
sha256 = "1ssj1cyam3nfidm8q82kvh4i3fzm2lzb3bxw6ck09hwhvwh909z4";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Ref";
version = "6.0.26";
sha256 = "12gb52dhg5h9hgnyqh1zgj2w46paxv2pfh33pphl9ajhrdr7hlsb";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Ref";
version = "8.0.1";
sha256 = "02r4jg4ha0qksix9v6s3cpmvavmz54gkawkxy9bvknw5ynxhhl1l";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.linux-arm64";
version = "6.0.26";
sha256 = "164hfrwqz5dxcbb441lridk4mzcqmarb0b7ckgvqhsvpawyjw88v";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.linux-arm64";
version = "8.0.1";
sha256 = "0353whnjgz3sqhzsfrviad3a3db4pk7hl7m4wwppv5mqdg9i9ri5";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.linux-x64";
version = "6.0.26";
sha256 = "0islayddpnflviqpbq4djc4f3v9nhsa2y76k5x6il3csq5vdw2hq";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.linux-x64";
version = "8.0.1";
sha256 = "1g5b30f4l8a1zjjr3b8pk9mcqxkxqwa86362f84646xaj4iw3a4d";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.osx-arm64";
version = "6.0.26";
sha256 = "1acn5zw1pxzmcg3c0pbf9hal36fbdh9mvbsiwra7simrk7hzqpdc";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.osx-arm64";
version = "8.0.1";
sha256 = "0cdrpdaq5sl3602anfx1p0z0ncx2sjjvl6mgsd6y38g47n7f95jc";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.osx-x64";
version = "6.0.26";
sha256 = "00f9l9dkdz0zv5csaw8fkm6s8ckrj5n9k3ygz12daa22l3bcn6ii";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.osx-x64";
version = "8.0.1";
sha256 = "1fk1flqp6ji0l4c2gvh83ykndpx7a2nkkgrgkgql3c75j1k2v1s9";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.win-x64";
version = "6.0.26";
sha256 = "0i2p356phfc5y6qnr3vyrzjfi1mrbwfb6g85k4q37bbyxjfp7zl9";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Runtime.win-x64";
version = "8.0.1";
sha256 = "198576cdkl72xs29zznff9ls763p8pfr0zji7b74dqxd5ga0s3bd";
})
(fetchNuGet {
pname = "Microsoft.NETCore.Platforms";
version = "1.1.0";
@@ -256,16 +151,6 @@
version = "1.1.3";
sha256 = "05smkcyxir59rgrmp7d6327vvrlacdgldfxhmyr1azclvga1zfsq";
})
(fetchNuGet {
pname = "Microsoft.SourceLink.Common";
version = "8.0.0";
sha256 = "0xrr8yd34ij7dqnyddkp2awfmf9qn3c89xmw2f3npaa4wnajmx81";
})
(fetchNuGet {
pname = "Microsoft.SourceLink.GitHub";
version = "8.0.0";
sha256 = "1gdx7n45wwia3yvang3ls92sk3wrymqcx9p349j8wba2lyjf9m44";
})
(fetchNuGet {
pname = "Microsoft.TestPlatform.ObjectModel";
version = "17.10.0";
@@ -288,8 +173,8 @@
})
(fetchNuGet {
pname = "Nerdbank.GitVersioning";
version = "3.6.133";
sha256 = "1cdw8krvsnx0n34f7fm5hiiy7bs6h3asvncqcikc0g46l50w2j80";
version = "3.6.139";
sha256 = "0npcryhq3r0c2zi940jk39h13mzc4hyg7z8gm6jdmxi1aqv1vh8c";
})
(fetchNuGet {
pname = "NETStandard.Library";

View File

@@ -1,73 +0,0 @@
#!/bin/bash
# This file was adapted from
# https://github.com/NixOS/nixpkgs/blob/b981d811453ab84fb3ea593a9b33b960f1ab9147/pkgs/build-support/dotnet/build-dotnet-module/default.nix#L173
set -euo pipefail
export PATH="@binPath@"
for arg in "$@"; do
case "$arg" in
--keep-sources|-k)
keepSources=1
shift
;;
--help|-h)
echo "usage: $0 [--keep-sources] [--help] <output path>"
echo " <output path> The path to write the lockfile to. A temporary file is used if this is not set"
echo " --keep-sources Don't remove temporary directories upon exit, useful for debugging"
echo " --help Show this help message"
exit
;;
esac
done
tmp=$(mktemp -td "@pname@-tmp-XXXXXX")
export tmp
HOME=$tmp/home
exitTrap() {
test -n "${ranTrap-}" && return
ranTrap=1
if test -n "${keepSources-}"; then
echo -e "Path to the source: $tmp/src\nPath to the fake home: $tmp/home"
else
rm -rf "$tmp"
fi
# Since mktemp is used this will be empty if the script didnt succesfully complete
if ! test -s "$depsFile"; then
rm -rf "$depsFile"
fi
}
trap exitTrap EXIT INT TERM
dotnetRestore() {
local -r project="${1-}"
local -r rid="$2"
dotnet restore "${project-}" \
-p:ContinuousIntegrationBuild=true \
-p:Deterministic=true \
--packages "$tmp/nuget_pkgs" \
--runtime "$rid" \
--no-cache \
--force
}
declare -a projectFiles=( @projectFiles@ )
declare -a testProjectFiles=( @testProjectFiles@ )
export DOTNET_NOLOGO=1
export DOTNET_CLI_TELEMETRY_OPTOUT=1
depsFile=$(realpath "${1:-$(mktemp -t "@pname@-deps-XXXXXX.nix")}")
mkdir -p "$tmp/nuget_pkgs"
storeSrc="@storeSrc@"
src="$tmp/src"
cp -rT "$storeSrc" "$src"
chmod -R +w "$src"
cd "$src"
echo "Restoring project..."
rids=("@rids@")
for rid in "${rids[@]}"; do
(( ${#projectFiles[@]} == 0 )) && dotnetRestore "" "$rid"
for project in "${projectFiles[@]-}" "${testProjectFiles[@]-}"; do
dotnetRestore "$project" "$rid"
done
done
echo "Successfully restored project"
echo "Writing lockfile..."
echo -e "# This file was automatically generated by passthru.fetch-deps.\n# Please don't edit it manually, your changes might get overwritten!\n" > "$depsFile"
nuget-to-nix "$tmp/nuget_pkgs" "@packages@" >> "$depsFile"
echo "Successfully wrote lockfile to $depsFile"