Compare commits

...

15 Commits

Author SHA1 Message Date
Patrick Stevens
4482038e8a Support individual per-method headers (#268) 2024-09-19 17:08:38 +01:00
dependabot[bot]
a41fa9dd37 Bump FsUnit from 6.0.0 to 6.0.1 (#265)
* Bump fantomas from 6.3.12 to 6.3.15

Bumps [fantomas](https://github.com/fsprojects/fantomas) from 6.3.12 to 6.3.15.
- [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.12...v6.3.15)

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

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

* Bump FsUnit from 6.0.0 to 6.0.1

Bumps [FsUnit](https://github.com/fsprojects/FsUnit) from 6.0.0 to 6.0.1.
- [Release notes](https://github.com/fsprojects/FsUnit/releases)
- [Changelog](https://github.com/fsprojects/FsUnit/blob/master/RELEASE_NOTES.md)
- [Commits](https://github.com/fsprojects/FsUnit/compare/6.0.0...6.0.1)

---
updated-dependencies:
- dependency-name: FsUnit
  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-09-16 13:56:13 +00:00
dependabot[bot]
fc5acc2f58 Bump cachix/install-nix-action from V27 to 28 (#266) 2024-09-16 12:12:30 +01:00
Patrick Stevens
0a1783d6ed Support [<BasePath>] (#263) 2024-09-15 17:38:03 +00:00
Patrick Stevens
9a3ebbf28f Cope with unit type in JSON (#262) 2024-09-15 14:37:50 +00:00
Patrick Stevens
e22525c200 Interpret JsonExtensionData (#261) 2024-09-15 11:13:22 +01:00
Patrick Stevens
09b7109c84 Extract some utilities from http-client branch (#260) 2024-09-14 22:02:32 +00:00
Patrick Stevens
693b95106a Also pipe through parser in PositionalArgs true (#259) 2024-09-13 16:11:53 +00:00
Patrick Stevens
49ecfbf5e5 Fix includeFlagLike when arg doesn't have an equals (#257) 2024-09-12 22:10:08 +00:00
Patrick Stevens
5748ac3d5b Allow consuming *all* args as positionals, not just ones which look like --foo (#255) 2024-09-11 19:00:04 +00:00
Patrick Stevens
913959a740 Make arg parser more AOT-friendly (#253) 2024-09-10 22:16:43 +01:00
dependabot[bot]
93ffc065cd Bump Microsoft.NET.Test.Sdk from 17.11.0 to 17.11.1 (#248)
* Bump Microsoft.NET.Test.Sdk from 17.11.0 to 17.11.1

Bumps [Microsoft.NET.Test.Sdk](https://github.com/microsoft/vstest) from 17.11.0 to 17.11.1.
- [Release notes](https://github.com/microsoft/vstest/releases)
- [Changelog](https://github.com/microsoft/vstest/blob/main/docs/releases.md)
- [Commits](https://github.com/microsoft/vstest/compare/v17.11.0...v17.11.1)

---
updated-dependencies:
- dependency-name: Microsoft.NET.Test.Sdk
  dependency-type: direct:production
  update-type: version-update:semver-patch
...

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

* Bump fantomas from 6.3.11 to 6.3.12

Bumps [fantomas](https://github.com/fsprojects/fantomas) from 6.3.11 to 6.3.12.
- [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.11...v6.3.12)

---
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-09-09 19:33:39 +00:00
dependabot[bot]
d14efba7e7 Bump actions/attest-build-provenance from 1.4.2 to 1.4.3 (#247) 2024-09-09 12:42:12 +01:00
patrick-conscriptus[bot]
f5cf0b79dd Automated commit (#246)
Co-authored-by: patrick-conscriptus[bot] <175414948+patrick-conscriptus[bot]@users.noreply.github.com>
2024-09-08 01:20:34 +00:00
Patrick Stevens
029e3746bb Fix record/union impl accessibility (#245) 2024-09-07 08:49:28 +00:00
42 changed files with 2916 additions and 516 deletions

View File

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

View File

@@ -29,7 +29,7 @@ jobs:
with:
fetch-depth: 0 # so that NerdBank.GitVersioning has access to history
- name: Install Nix
uses: cachix/install-nix-action@V27
uses: cachix/install-nix-action@V28
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
@@ -50,7 +50,7 @@ jobs:
with:
fetch-depth: 0 # so that NerdBank.GitVersioning has access to history
- name: Install Nix
uses: cachix/install-nix-action@V27
uses: cachix/install-nix-action@V28
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
@@ -67,7 +67,7 @@ jobs:
- name: Checkout
uses: actions/checkout@v4
- name: Install Nix
uses: cachix/install-nix-action@V27
uses: cachix/install-nix-action@V28
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
@@ -82,7 +82,7 @@ jobs:
- name: Checkout
uses: actions/checkout@v4
- name: Install Nix
uses: cachix/install-nix-action@V27
uses: cachix/install-nix-action@V28
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
@@ -97,7 +97,7 @@ jobs:
with:
fetch-depth: 0 # so that NerdBank.GitVersioning has access to history
- name: Install Nix
uses: cachix/install-nix-action@V27
uses: cachix/install-nix-action@V28
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
@@ -116,7 +116,7 @@ jobs:
- name: Checkout
uses: actions/checkout@v4
- name: Install Nix
uses: cachix/install-nix-action@V27
uses: cachix/install-nix-action@V28
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
@@ -129,7 +129,7 @@ jobs:
steps:
- uses: actions/checkout@master
- name: Install Nix
uses: cachix/install-nix-action@V27
uses: cachix/install-nix-action@V28
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
@@ -142,7 +142,7 @@ jobs:
steps:
- uses: actions/checkout@master
- name: Install Nix
uses: cachix/install-nix-action@V27
uses: cachix/install-nix-action@V28
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
@@ -156,7 +156,7 @@ jobs:
with:
fetch-depth: 0 # so that NerdBank.GitVersioning has access to history
- name: Install Nix
uses: cachix/install-nix-action@V27
uses: cachix/install-nix-action@V28
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
@@ -241,7 +241,7 @@ jobs:
name: nuget-package-attribute
path: packed
- name: Attest Build Provenance
uses: actions/attest-build-provenance@6149ea5740be74af77f260b9db67e633f6b0a9a1 # v1.4.2
uses: actions/attest-build-provenance@1c608d11d69870c2092266b3f9a6f3abbf17002c # v1.4.3
with:
subject-path: "packed/*.nupkg"
@@ -260,7 +260,7 @@ jobs:
name: nuget-package-plugin
path: packed
- name: Attest Build Provenance
uses: actions/attest-build-provenance@6149ea5740be74af77f260b9db67e633f6b0a9a1 # v1.4.2
uses: actions/attest-build-provenance@1c608d11d69870c2092266b3f9a6f3abbf17002c # v1.4.3
with:
subject-path: "packed/*.nupkg"
@@ -276,7 +276,7 @@ jobs:
steps:
- uses: actions/checkout@v4
- name: Install Nix
uses: cachix/install-nix-action@V27
uses: cachix/install-nix-action@V28
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}
@@ -309,7 +309,7 @@ jobs:
steps:
- uses: actions/checkout@v4
- name: Install Nix
uses: cachix/install-nix-action@V27
uses: cachix/install-nix-action@V28
with:
extra_nix_config: |
access-tokens = github.com=${{ secrets.GITHUB_TOKEN }}

View File

@@ -1,5 +1,14 @@
Notable changes are recorded here.
# WoofWare.Myriad.Plugins 3.0.1
Semantics of `HttpClient`'s URI component composition changed:
we now implicitly insert `/` characters after `[<BaseAddress>]` and `[<BasePath>]`, so that URI composition doesn't silently drop the last component if you didn't put a slash there.
# WoofWare.Myriad.Plugins 2.3.9
`JsonParse` and `JsonSerialize` now interpret `[<JsonExtensionData>]`, which must be on a `Dictionary<string, _>`; this collects any extra components that were present on the JSON object.
# WoofWare.Myriad.Plugins 2.2.1, WoofWare.Myriad.Plugins.Attributes 3.2.1
New generator: `ArgParser`, a basic reflection-free argument parser.

View File

@@ -190,3 +190,48 @@ type ManyLongForms =
[<ArgumentLongForm "dont-turn-it-off">]
SomeFlag : bool
}
[<RequireQualifiedAccess>]
type private IrrelevantDu =
| Foo
| Bar
[<ArgParser true>]
type FlagsIntoPositionalArgs =
{
A : string
[<PositionalArgs true>]
GrabEverything : string list
}
[<ArgParser true>]
type FlagsIntoPositionalArgsChoice =
{
A : string
[<PositionalArgs true>]
GrabEverything : Choice<string, string> list
}
[<ArgParser true>]
type FlagsIntoPositionalArgsInt =
{
A : string
[<PositionalArgs true>]
GrabEverything : int list
}
[<ArgParser true>]
type FlagsIntoPositionalArgsIntChoice =
{
A : string
[<PositionalArgs true>]
GrabEverything : Choice<int, int> list
}
[<ArgParser true>]
type FlagsIntoPositionalArgs' =
{
A : string
[<PositionalArgs false>]
DontGrabEverything : string list
}

File diff suppressed because it is too large Load Diff

View File

@@ -29,7 +29,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri (("v1/gyms/"), System.UriKind.Relative)
)
@@ -59,7 +59,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri (
"v1/gyms/{gym_id}/attendance"
@@ -93,7 +93,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri (
"v1/gyms/{gym_id}/attendance"
@@ -127,7 +127,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("v1/member", System.UriKind.Relative)
)
@@ -157,7 +157,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri (
"v1/gyms/{gym}"
@@ -191,7 +191,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("v1/member/activity", System.UriKind.Relative)
)
@@ -221,7 +221,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("some/url", System.UriKind.Relative)
)
@@ -251,7 +251,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("some/url", System.UriKind.Relative)
)
@@ -317,7 +317,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri (
("/v2/gymSessions/member"
@@ -358,7 +358,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri (
("/v2/gymSessions/member?foo=1"
@@ -399,7 +399,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("users/new", System.UriKind.Relative)
)
@@ -426,7 +426,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("users/new", System.UriKind.Relative)
)
@@ -453,7 +453,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("users/new", System.UriKind.Relative)
)
@@ -480,7 +480,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("users/new", System.UriKind.Relative)
)
@@ -507,7 +507,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("users/new", System.UriKind.Relative)
)
@@ -534,7 +534,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("users/new", System.UriKind.Relative)
)
@@ -567,7 +567,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("users/new", System.UriKind.Relative)
)
@@ -600,7 +600,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("users/new", System.UriKind.Relative)
)
@@ -633,7 +633,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("users/new", System.UriKind.Relative)
)
@@ -659,7 +659,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri (
"endpoint/{param}"
@@ -688,7 +688,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -713,7 +713,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -738,7 +738,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -763,7 +763,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -787,7 +787,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -811,7 +811,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -835,7 +835,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -859,7 +859,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -895,7 +895,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -931,7 +931,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -967,7 +967,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -1003,7 +1003,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -1026,7 +1026,7 @@ module PureGymApi =
let uri =
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/"
| v -> v),
System.Uri ("endpoint", System.UriKind.Relative)
)
@@ -1115,6 +1115,7 @@ module ApiWithBasePath =
let! ct = Async.CancellationToken
let uri =
System.Uri (
System.Uri (
(match client.BaseAddress with
| null ->
@@ -1125,6 +1126,8 @@ module ApiWithBasePath =
)
)
| v -> v),
System.Uri ("foo/", System.UriKind.Relative)
),
System.Uri (
"endpoint/{param}"
.Replace ("{param}", parameter.ToString () |> System.Web.HttpUtility.UrlEncode),
@@ -1166,10 +1169,13 @@ module ApiWithBasePathAndAddress =
let! ct = Async.CancellationToken
let uri =
System.Uri (
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com"
| null -> System.Uri "https://whatnot.com/thing/"
| v -> v),
System.Uri ("foo/", System.UriKind.Relative)
),
System.Uri (
"endpoint/{param}"
.Replace ("{param}", parameter.ToString () |> System.Web.HttpUtility.UrlEncode),
@@ -1200,6 +1206,312 @@ open System.Net
open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module ApiWithAbsoluteBasePath =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IApiWithAbsoluteBasePath =
{ new IApiWithAbsoluteBasePath with
member _.GetPathParam (parameter : string, cancellationToken : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let uri =
System.Uri (
System.Uri (
(match client.BaseAddress with
| null ->
raise (
System.ArgumentNullException (
nameof (client.BaseAddress),
"No base address was supplied on the type, and no BaseAddress was on the HttpClient."
)
)
| v -> v),
System.Uri ("/foo/", System.UriKind.Relative)
),
System.Uri (
"endpoint/{param}"
.Replace ("{param}", parameter.ToString () |> System.Web.HttpUtility.UrlEncode),
System.UriKind.Relative
)
)
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri = uri
)
let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask
let response = response.EnsureSuccessStatusCode ()
let! responseString = response.Content.ReadAsStringAsync ct |> Async.AwaitTask
return responseString
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = cancellationToken))
}
namespace PureGym
open System
open System.Threading
open System.Threading.Tasks
open System.IO
open System.Net
open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module ApiWithAbsoluteBasePathAndAddress =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IApiWithAbsoluteBasePathAndAddress =
{ new IApiWithAbsoluteBasePathAndAddress with
member _.GetPathParam (parameter : string, ct : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let uri =
System.Uri (
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com/thing/"
| v -> v),
System.Uri ("/foo/", System.UriKind.Relative)
),
System.Uri (
"endpoint/{param}"
.Replace ("{param}", parameter.ToString () |> System.Web.HttpUtility.UrlEncode),
System.UriKind.Relative
)
)
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri = uri
)
let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask
let response = response.EnsureSuccessStatusCode ()
let! responseString = response.Content.ReadAsStringAsync ct |> Async.AwaitTask
return responseString
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct))
}
namespace PureGym
open System
open System.Threading
open System.Threading.Tasks
open System.IO
open System.Net
open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module ApiWithBasePathAndAbsoluteEndpoint =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IApiWithBasePathAndAbsoluteEndpoint =
{ new IApiWithBasePathAndAbsoluteEndpoint with
member _.GetPathParam (parameter : string, cancellationToken : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let uri =
System.Uri (
System.Uri (
(match client.BaseAddress with
| null ->
raise (
System.ArgumentNullException (
nameof (client.BaseAddress),
"No base address was supplied on the type, and no BaseAddress was on the HttpClient."
)
)
| v -> v),
System.Uri ("foo/", System.UriKind.Relative)
),
System.Uri (
"/endpoint/{param}"
.Replace ("{param}", parameter.ToString () |> System.Web.HttpUtility.UrlEncode),
System.UriKind.Relative
)
)
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri = uri
)
let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask
let response = response.EnsureSuccessStatusCode ()
let! responseString = response.Content.ReadAsStringAsync ct |> Async.AwaitTask
return responseString
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = cancellationToken))
}
namespace PureGym
open System
open System.Threading
open System.Threading.Tasks
open System.IO
open System.Net
open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module ApiWithBasePathAndAddressAndAbsoluteEndpoint =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IApiWithBasePathAndAddressAndAbsoluteEndpoint =
{ new IApiWithBasePathAndAddressAndAbsoluteEndpoint with
member _.GetPathParam (parameter : string, ct : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let uri =
System.Uri (
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com/thing/"
| v -> v),
System.Uri ("foo/", System.UriKind.Relative)
),
System.Uri (
"/endpoint/{param}"
.Replace ("{param}", parameter.ToString () |> System.Web.HttpUtility.UrlEncode),
System.UriKind.Relative
)
)
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri = uri
)
let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask
let response = response.EnsureSuccessStatusCode ()
let! responseString = response.Content.ReadAsStringAsync ct |> Async.AwaitTask
return responseString
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct))
}
namespace PureGym
open System
open System.Threading
open System.Threading.Tasks
open System.IO
open System.Net
open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module ApiWithAbsoluteBasePathAndAbsoluteEndpoint =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IApiWithAbsoluteBasePathAndAbsoluteEndpoint =
{ new IApiWithAbsoluteBasePathAndAbsoluteEndpoint with
member _.GetPathParam (parameter : string, cancellationToken : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let uri =
System.Uri (
System.Uri (
(match client.BaseAddress with
| null ->
raise (
System.ArgumentNullException (
nameof (client.BaseAddress),
"No base address was supplied on the type, and no BaseAddress was on the HttpClient."
)
)
| v -> v),
System.Uri ("/foo/", System.UriKind.Relative)
),
System.Uri (
"/endpoint/{param}"
.Replace ("{param}", parameter.ToString () |> System.Web.HttpUtility.UrlEncode),
System.UriKind.Relative
)
)
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri = uri
)
let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask
let response = response.EnsureSuccessStatusCode ()
let! responseString = response.Content.ReadAsStringAsync ct |> Async.AwaitTask
return responseString
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = cancellationToken))
}
namespace PureGym
open System
open System.Threading
open System.Threading.Tasks
open System.IO
open System.Net
open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module ApiWithAbsoluteBasePathAndAddressAndAbsoluteEndpoint =
/// Create a REST client.
let make (client : System.Net.Http.HttpClient) : IApiWithAbsoluteBasePathAndAddressAndAbsoluteEndpoint =
{ new IApiWithAbsoluteBasePathAndAddressAndAbsoluteEndpoint with
member _.GetPathParam (parameter : string, ct : CancellationToken option) =
async {
let! ct = Async.CancellationToken
let uri =
System.Uri (
System.Uri (
(match client.BaseAddress with
| null -> System.Uri "https://whatnot.com/thing/"
| v -> v),
System.Uri ("/foo/", System.UriKind.Relative)
),
System.Uri (
"/endpoint/{param}"
.Replace ("{param}", parameter.ToString () |> System.Web.HttpUtility.UrlEncode),
System.UriKind.Relative
)
)
let httpMessage =
new System.Net.Http.HttpRequestMessage (
Method = System.Net.Http.HttpMethod.Get,
RequestUri = uri
)
let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask
let response = response.EnsureSuccessStatusCode ()
let! responseString = response.Content.ReadAsStringAsync ct |> Async.AwaitTask
return responseString
}
|> (fun a -> Async.StartAsTask (a, ?cancellationToken = ct))
}
namespace PureGym
open System
open System.Threading
open System.Threading.Tasks
open System.IO
open System.Net
open System.Net.Http
open RestEase
/// Module for constructing a REST client.
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix) ; RequireQualifiedAccess>]
module ApiWithHeaders =
@@ -1245,6 +1557,7 @@ module ApiWithHeaders =
do httpMessage.Headers.Add ("X-Foo", this.SomeHeader.ToString ())
do httpMessage.Headers.Add ("Authorization", this.SomeOtherHeader.ToString ())
do httpMessage.Headers.Add ("Header-Name", "Header-Value")
do httpMessage.Headers.Add ("Something-Else", "val")
let! response = client.SendAsync (httpMessage, ct) |> Async.AwaitTask
let response = response.EnsureSuccessStatusCode ()
let! responseString = response.Content.ReadAsStringAsync ct |> Async.AwaitTask

View File

@@ -210,6 +210,8 @@ module JsonRecordTypeWithBothJsonSerializeExtension =
|> (fun field -> field.ToString "o" |> System.Text.Json.Nodes.JsonValue.Create<string>))
)
node.Add ("unit", (input.Unit |> (fun value -> System.Text.Json.Nodes.JsonObject ())))
node :> _
namespace ConsumePlugin
@@ -291,6 +293,60 @@ module FooJsonSerializeExtension =
)
node :> _
namespace ConsumePlugin
open System
open System.Collections.Generic
open System.Text.Json.Serialization
/// Module containing JSON serializing extension members for the CollectRemaining type
[<AutoOpen>]
module CollectRemainingJsonSerializeExtension =
/// Extension methods for JSON parsing
type CollectRemaining with
/// Serialize to a JSON node
static member toJsonNode (input : CollectRemaining) : System.Text.Json.Nodes.JsonNode =
let node = System.Text.Json.Nodes.JsonObject ()
do
node.Add (
"message",
(input.Message
|> (fun field ->
match field with
| None -> null :> System.Text.Json.Nodes.JsonNode
| Some field -> HeaderAndValue.toJsonNode field
))
)
for KeyValue (key, value) in input.Rest do
node.Add (key, id value)
node :> _
namespace ConsumePlugin
open System
open System.Collections.Generic
open System.Text.Json.Serialization
/// Module containing JSON serializing extension members for the OuterCollectRemaining type
[<AutoOpen>]
module OuterCollectRemainingJsonSerializeExtension =
/// Extension methods for JSON parsing
type OuterCollectRemaining with
/// Serialize to a JSON node
static member toJsonNode (input : OuterCollectRemaining) : System.Text.Json.Nodes.JsonNode =
let node = System.Text.Json.Nodes.JsonObject ()
do
for KeyValue (key, value) in input.Others do
node.Add (key, System.Text.Json.Nodes.JsonValue.Create<int> value)
node.Add ("remaining", (input.Remaining |> CollectRemaining.toJsonNode))
node :> _
namespace ConsumePlugin
@@ -424,6 +480,8 @@ module JsonRecordTypeWithBothJsonParseExtension =
/// Parse from a JSON node.
static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : JsonRecordTypeWithBoth =
let arg_21 = ()
let arg_20 =
(match node.["timestamp"] with
| null ->
@@ -705,6 +763,7 @@ module JsonRecordTypeWithBothJsonParseExtension =
IntMeasureNullable = arg_18
Enum = arg_19
Timestamp = arg_20
Unit = arg_21
}
namespace ConsumePlugin
@@ -842,3 +901,83 @@ module FooJsonParseExtension =
{
Message = arg_0
}
namespace ConsumePlugin
/// Module containing JSON parsing extension members for the CollectRemaining type
[<AutoOpen>]
module CollectRemainingJsonParseExtension =
/// Extension methods for JSON parsing
type CollectRemaining with
/// Parse from a JSON node.
static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : CollectRemaining =
let arg_1 =
let result =
System.Collections.Generic.Dictionary<string, System.Text.Json.Nodes.JsonNode> ()
let node = node.AsObject ()
for KeyValue (key, value) in node do
if key = "message" then () else result.Add (key, node.[key])
result
let arg_0 =
match node.["message"] with
| null -> None
| v -> HeaderAndValue.jsonParse v |> Some
{
Message = arg_0
Rest = arg_1
}
namespace ConsumePlugin
/// Module containing JSON parsing extension members for the OuterCollectRemaining type
[<AutoOpen>]
module OuterCollectRemainingJsonParseExtension =
/// Extension methods for JSON parsing
type OuterCollectRemaining with
/// Parse from a JSON node.
static member jsonParse (node : System.Text.Json.Nodes.JsonNode) : OuterCollectRemaining =
let arg_1 =
CollectRemaining.jsonParse (
match node.["remaining"] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" ("remaining")
)
)
| v -> v
)
let arg_0 =
let result = System.Collections.Generic.Dictionary<string, int> ()
let node = node.AsObject ()
for KeyValue (key, value) in node do
if key = "remaining" then
()
else
result.Add (
key,
(match node.[key] with
| null ->
raise (
System.Collections.Generic.KeyNotFoundException (
sprintf "Required key '%s' not found on JSON object" (key)
)
)
| v -> v)
.AsValue()
.GetValue<System.Int32> ()
)
result
{
Others = arg_0
Remaining = arg_1
}

View File

@@ -122,8 +122,6 @@ type internal IApiWithoutBaseAddress =
[<Get "endpoint/{param}">]
abstract GetPathParam : [<Path "param">] parameter : string * ?ct : CancellationToken -> Task<string>
// TODO: implement BasePath support
[<WoofWare.Myriad.Plugins.HttpClient>]
[<BasePath "foo">]
type IApiWithBasePath =
@@ -132,12 +130,54 @@ type IApiWithBasePath =
abstract GetPathParam : [<Path "param">] parameter : string * ?cancellationToken : CancellationToken -> Task<string>
[<WoofWare.Myriad.Plugins.HttpClient>]
[<BaseAddress "https://whatnot.com">]
[<BaseAddress "https://whatnot.com/thing">]
[<BasePath "foo">]
type IApiWithBasePathAndAddress =
[<Get "endpoint/{param}">]
abstract GetPathParam : [<Path "param">] parameter : string * ?ct : CancellationToken -> Task<string>
[<WoofWare.Myriad.Plugins.HttpClient>]
[<BasePath "/foo">]
type IApiWithAbsoluteBasePath =
// Example where we use the bundled attributes rather than RestEase's
[<WoofWare.Myriad.Plugins.RestEase.Get "endpoint/{param}">]
abstract GetPathParam : [<Path "param">] parameter : string * ?cancellationToken : CancellationToken -> Task<string>
[<WoofWare.Myriad.Plugins.HttpClient>]
[<BaseAddress "https://whatnot.com/thing">]
[<BasePath "/foo">]
type IApiWithAbsoluteBasePathAndAddress =
[<Get "endpoint/{param}">]
abstract GetPathParam : [<Path "param">] parameter : string * ?ct : CancellationToken -> Task<string>
[<WoofWare.Myriad.Plugins.HttpClient>]
[<BasePath "foo">]
type IApiWithBasePathAndAbsoluteEndpoint =
// Example where we use the bundled attributes rather than RestEase's
[<WoofWare.Myriad.Plugins.RestEase.Get "/endpoint/{param}">]
abstract GetPathParam : [<Path "param">] parameter : string * ?cancellationToken : CancellationToken -> Task<string>
[<WoofWare.Myriad.Plugins.HttpClient>]
[<BaseAddress "https://whatnot.com/thing">]
[<BasePath "foo">]
type IApiWithBasePathAndAddressAndAbsoluteEndpoint =
[<Get "/endpoint/{param}">]
abstract GetPathParam : [<Path "param">] parameter : string * ?ct : CancellationToken -> Task<string>
[<WoofWare.Myriad.Plugins.HttpClient>]
[<BasePath "/foo">]
type IApiWithAbsoluteBasePathAndAbsoluteEndpoint =
// Example where we use the bundled attributes rather than RestEase's
[<WoofWare.Myriad.Plugins.RestEase.Get "/endpoint/{param}">]
abstract GetPathParam : [<Path "param">] parameter : string * ?cancellationToken : CancellationToken -> Task<string>
[<WoofWare.Myriad.Plugins.HttpClient>]
[<BaseAddress "https://whatnot.com/thing">]
[<BasePath "/foo">]
type IApiWithAbsoluteBasePathAndAddressAndAbsoluteEndpoint =
[<Get "/endpoint/{param}">]
abstract GetPathParam : [<Path "param">] parameter : string * ?ct : CancellationToken -> Task<string>
[<WoofWare.Myriad.Plugins.HttpClient>]
[<Header("Header-Name", "Header-Value")>]
type IApiWithHeaders =
@@ -148,6 +188,7 @@ type IApiWithHeaders =
abstract SomeOtherHeader : int
[<Get "endpoint/{param}">]
[<Header("Something-Else", "val")>]
abstract GetPathParam : [<Path "param">] parameter : string * ?ct : CancellationToken -> Task<string>
[<WoofWare.Myriad.Plugins.HttpClient>]

View File

@@ -50,6 +50,7 @@ type JsonRecordTypeWithBoth =
IntMeasureNullable : int<measure> Nullable
Enum : SomeEnum
Timestamp : DateTimeOffset
Unit : unit
}
[<WoofWare.Myriad.Plugins.JsonSerialize true>]
@@ -73,3 +74,21 @@ type Foo =
{
Message : HeaderAndValue option
}
[<WoofWare.Myriad.Plugins.JsonSerialize true>]
[<WoofWare.Myriad.Plugins.JsonParse true>]
type CollectRemaining =
{
Message : HeaderAndValue option
[<JsonExtensionData>]
Rest : Dictionary<string, System.Text.Json.Nodes.JsonNode>
}
[<WoofWare.Myriad.Plugins.JsonSerialize true>]
[<WoofWare.Myriad.Plugins.JsonParse true>]
type OuterCollectRemaining =
{
[<JsonExtensionData>]
Others : Dictionary<string, int>
Remaining : CollectRemaining
}

View File

@@ -19,9 +19,22 @@ type ArgParserAttribute (isExtensionMethod : bool) =
/// Attribute indicating that this field shall accumulate all unmatched args,
/// as well as any that appear after a bare `--`.
type PositionalArgsAttribute () =
///
/// Set `includeFlagLike = true` to include args that begin `--` in the
/// positional args.
/// (By default, `includeFlagLike = false` and we throw when encountering
/// an argument which looks like a flag but which we don't recognise.)
/// We will still interpret `--help` as requesting help, unless it comes after
/// a standalone `--` separator.
type PositionalArgsAttribute (includeFlagLike : bool) =
inherit Attribute ()
/// The default value of `isExtensionMethod`, the optional argument to the ArgParserAttribute constructor.
static member DefaultIncludeFlagLike = false
/// Shorthand for the "includeFlagLike = false" constructor; see documentation there for details.
new () = PositionalArgsAttribute PositionalArgsAttribute.DefaultIncludeFlagLike
/// Attribute indicating that this field shall have a default value derived
/// from calling an appropriately named static method on the type.
///

View File

@@ -45,6 +45,9 @@ module RestEase =
/// Indicates that this interface represents a REST client which accesses an API whose paths are
/// all relative to the given address.
///
/// We will essentially unconditionally append a slash to this for you, on the grounds that you probably don't
/// intend the base path *itself* to be an endpoint.
type BaseAddressAttribute (addr : string) =
inherit Attribute ()
@@ -61,3 +64,21 @@ module RestEase =
inherit Attribute ()
new (path : string) = PathAttribute (Some path)
new () = PathAttribute None
/// Indicates that this argument to a method is passed to the remote API by being serialised into the request
/// body.
type BodyAttribute () =
inherit Attribute ()
/// This is interpolated into every URL, between the BaseAddress and the path specified by e.g. [<Get>].
/// Note that if the [<Get>]-specified path starts with a slash, the BasePath is ignored, because then [<Get>]
/// is considered to be relative to the URL root (i.e. the host part of the BaseAddress).
/// Similarly, if the [<BasePath>] starts with a slash, then any path component of the BaseAddress is ignored.
///
/// We will essentially unconditionally append a slash to this for you, on the grounds that you probably don't
/// intend the base path *itself* to be an endpoint.
///
/// Can contain {placeholders}; hopefully your methods define values for those placeholders with [<Path>]
/// attributes!
type BasePathAttribute (path : string) =
inherit Attribute ()

View File

@@ -40,12 +40,19 @@ WoofWare.Myriad.Plugins.JsonSerializeAttribute.get_DefaultIsExtensionMethod [sta
WoofWare.Myriad.Plugins.ParseExactAttribute inherit System.Attribute
WoofWare.Myriad.Plugins.ParseExactAttribute..ctor [constructor]: string
WoofWare.Myriad.Plugins.PositionalArgsAttribute inherit System.Attribute
WoofWare.Myriad.Plugins.PositionalArgsAttribute..ctor [constructor]: bool
WoofWare.Myriad.Plugins.PositionalArgsAttribute..ctor [constructor]: unit
WoofWare.Myriad.Plugins.PositionalArgsAttribute.DefaultIncludeFlagLike [static property]: [read-only] bool
WoofWare.Myriad.Plugins.PositionalArgsAttribute.get_DefaultIncludeFlagLike [static method]: unit -> bool
WoofWare.Myriad.Plugins.RemoveOptionsAttribute inherit System.Attribute
WoofWare.Myriad.Plugins.RemoveOptionsAttribute..ctor [constructor]: unit
WoofWare.Myriad.Plugins.RestEase inherit obj
WoofWare.Myriad.Plugins.RestEase+BaseAddressAttribute inherit System.Attribute
WoofWare.Myriad.Plugins.RestEase+BaseAddressAttribute..ctor [constructor]: string
WoofWare.Myriad.Plugins.RestEase+BasePathAttribute inherit System.Attribute
WoofWare.Myriad.Plugins.RestEase+BasePathAttribute..ctor [constructor]: string
WoofWare.Myriad.Plugins.RestEase+BodyAttribute inherit System.Attribute
WoofWare.Myriad.Plugins.RestEase+BodyAttribute..ctor [constructor]: unit
WoofWare.Myriad.Plugins.RestEase+DeleteAttribute inherit System.Attribute
WoofWare.Myriad.Plugins.RestEase+DeleteAttribute..ctor [constructor]: string
WoofWare.Myriad.Plugins.RestEase+GetAttribute inherit System.Attribute

View File

@@ -18,7 +18,7 @@
<ItemGroup>
<PackageReference Include="ApiSurface" Version="4.1.5" />
<PackageReference Include="Microsoft.NET.Test.Sdk" Version="17.11.0"/>
<PackageReference Include="Microsoft.NET.Test.Sdk" Version="17.11.1"/>
<PackageReference Include="NUnit" Version="4.2.2"/>
<PackageReference Include="NUnit3TestAdapter" Version="4.6.0"/>
</ItemGroup>

View File

@@ -1,5 +1,5 @@
{
"version": "3.4",
"version": "3.6",
"publicReleaseRefSpec": [
"^refs/heads/main$"
],

View File

@@ -618,3 +618,89 @@ Required argument '--exact' received no value"""
"""Help text requested.
--do-something-else / --anotherarg string
--turn-it-on / --dont-turn-it-off bool"""
[<Test>]
let ``Can collect *all* non-help args into positional args with includeFlagLike`` () =
let getEnvVar (_ : string) = failwith "do not call"
FlagsIntoPositionalArgs.parse' getEnvVar [ "--a" ; "foo" ; "--b=false" ; "--c" ; "hi" ; "--" ; "--help" ]
|> shouldEqual
{
A = "foo"
GrabEverything = [ "--b=false" ; "--c" ; "hi" ; "--help" ]
}
// Users might consider this eccentric!
// But we're only a simple arg parser; we don't look around to see whether this is "almost"
// a valid parse.
FlagsIntoPositionalArgs.parse' getEnvVar [ "--a" ; "--b=false" ; "--c" ; "hi" ; "--" ; "--help" ]
|> shouldEqual
{
A = "--b=false"
GrabEverything = [ "--c" ; "hi" ; "--help" ]
}
[<Test>]
let ``Can collect non-help args into positional args with Choice`` () =
let getEnvVar (_ : string) = failwith "do not call"
FlagsIntoPositionalArgsChoice.parse' getEnvVar [ "--a" ; "foo" ; "--b=false" ; "--c" ; "hi" ; "--" ; "--help" ]
|> shouldEqual
{
A = "foo"
GrabEverything =
[
Choice1Of2 "--b=false"
Choice1Of2 "--c"
Choice1Of2 "hi"
Choice2Of2 "--help"
]
}
[<Test>]
let ``Can collect non-help args into positional args, and we parse on the way`` () =
let getEnvVar (_ : string) = failwith "do not call"
FlagsIntoPositionalArgsInt.parse' getEnvVar [ "3" ; "--a" ; "foo" ; "5" ; "--" ; "98" ]
|> shouldEqual
{
A = "foo"
GrabEverything = [ 3 ; 5 ; 98 ]
}
[<Test>]
let ``Can collect non-help args into positional args with Choice, and we parse on the way`` () =
let getEnvVar (_ : string) = failwith "do not call"
FlagsIntoPositionalArgsIntChoice.parse' getEnvVar [ "3" ; "--a" ; "foo" ; "5" ; "--" ; "98" ]
|> shouldEqual
{
A = "foo"
GrabEverything = [ Choice1Of2 3 ; Choice1Of2 5 ; Choice2Of2 98 ]
}
[<Test>]
let ``Can refuse to collect non-help args with PositionalArgs false`` () =
let getEnvVar (_ : string) = failwith "do not call"
let exc =
Assert.Throws<exn> (fun () ->
FlagsIntoPositionalArgs'.parse'
getEnvVar
[ "--a" ; "foo" ; "--b=false" ; "--c" ; "hi" ; "--" ; "--help" ]
|> ignore<FlagsIntoPositionalArgs'>
)
exc.Message
|> shouldEqual """Unable to process argument --b=false as key --b and value false"""
let exc =
Assert.Throws<exn> (fun () ->
FlagsIntoPositionalArgs'.parse' getEnvVar [ "--a" ; "--b=false" ; "--c=hi" ; "--" ; "--help" ]
|> ignore<FlagsIntoPositionalArgs'>
)
// Again perhaps eccentric!
// Again, we don't try to detect that the user has missed out the desired argument to `--a`.
exc.Message
|> shouldEqual """Unable to process argument --c=hi as key --c and value hi"""

View File

@@ -9,9 +9,7 @@ open FsUnitTyped
[<TestFixture>]
module TestBasePath =
[<Test>]
let ``Base address is respected`` () =
let proc (message : HttpRequestMessage) : HttpResponseMessage Async =
let replyWithUrl (message : HttpRequestMessage) : HttpResponseMessage Async =
async {
message.Method |> shouldEqual HttpMethod.Get
let content = new StringContent (message.RequestUri.ToString ())
@@ -20,7 +18,9 @@ module TestBasePath =
return resp
}
use client = HttpClientMock.makeNoUri proc
[<Test>]
let ``Base address is respected`` () =
use client = HttpClientMock.makeNoUri replyWithUrl
let api = PureGymApi.make client
let observedUri = api.GetPathParam("param").Result
@@ -28,38 +28,28 @@ module TestBasePath =
[<Test>]
let ``Without a base address attr but with BaseAddress on client, request goes through`` () =
let proc (message : HttpRequestMessage) : HttpResponseMessage Async =
async {
message.Method |> shouldEqual HttpMethod.Get
let content = new StringContent (message.RequestUri.ToString ())
let resp = new HttpResponseMessage (HttpStatusCode.OK)
resp.Content <- content
return resp
}
use client = HttpClientMock.make (System.Uri "https://baseaddress.com") proc
use client = HttpClientMock.make (Uri "https://baseaddress.com") replyWithUrl
let api = ApiWithoutBaseAddress.make client
let observedUri = api.GetPathParam("param").Result
observedUri |> shouldEqual "https://baseaddress.com/endpoint/param"
[<Test>]
let ``Without a base address attr or BaseAddress on client, request throws`` () =
let proc (message : HttpRequestMessage) : HttpResponseMessage Async =
async {
message.Method |> shouldEqual HttpMethod.Get
let content = new StringContent (message.RequestUri.ToString ())
let resp = new HttpResponseMessage (HttpStatusCode.OK)
resp.Content <- content
return resp
}
let ``Base address on client takes precedence`` () =
use client = HttpClientMock.make (Uri "https://baseaddress.com") replyWithUrl
let api = PureGymApi.make client
use client = HttpClientMock.makeNoUri proc
let observedUri = api.GetPathParam("param").Result
observedUri |> shouldEqual "https://baseaddress.com/endpoint/param"
[<Test>]
let ``Without a base address attr or BaseAddress on client, request throws`` () =
use client = HttpClientMock.makeNoUri replyWithUrl
let api = ApiWithoutBaseAddress.make client
let observedExc =
async {
let! result = api.GetPathParam ("param") |> Async.AwaitTask |> Async.Catch
let! result = api.GetPathParam "param" |> Async.AwaitTask |> Async.Catch
match result with
| Choice1Of2 _ -> return failwith "test failure"
@@ -78,3 +68,103 @@ module TestBasePath =
observedExc.Message
|> shouldEqual
"No base address was supplied on the type, and no BaseAddress was on the HttpClient. (Parameter 'BaseAddress')"
[<Test>]
let ``Relative base path, no base address, relative attribute`` () : unit =
do
use client = HttpClientMock.makeNoUri replyWithUrl
let api = ApiWithBasePath.make client
let exc =
Assert.Throws<AggregateException> (fun () -> api.GetPathParam("hi").Result |> ignore<string>)
exc.InnerException.Message
|> shouldEqual
"No base address was supplied on the type, and no BaseAddress was on the HttpClient. (Parameter 'BaseAddress')"
use client = HttpClientMock.make (Uri "https://whatnot.com/thing/") replyWithUrl
let api = ApiWithBasePath.make client
let result = api.GetPathParam("hi").Result
result |> shouldEqual "https://whatnot.com/thing/foo/endpoint/hi"
[<Test>]
let ``Relative base path, base address, relative attribute`` () : unit =
use client = HttpClientMock.makeNoUri replyWithUrl
let api = ApiWithBasePathAndAddress.make client
let result = api.GetPathParam("hi").Result
result |> shouldEqual "https://whatnot.com/thing/foo/endpoint/hi"
[<Test>]
let ``Absolute base path, no base address, relative attribute`` () : unit =
do
use client = HttpClientMock.makeNoUri replyWithUrl
let api = ApiWithAbsoluteBasePath.make client
let exc =
Assert.Throws<AggregateException> (fun () -> api.GetPathParam("hi").Result |> ignore<string>)
exc.InnerException.Message
|> shouldEqual
"No base address was supplied on the type, and no BaseAddress was on the HttpClient. (Parameter 'BaseAddress')"
use client = HttpClientMock.make (Uri "https://whatnot.com/thing/") replyWithUrl
let api = ApiWithAbsoluteBasePath.make client
let result = api.GetPathParam("hi").Result
result |> shouldEqual "https://whatnot.com/foo/endpoint/hi"
[<Test>]
let ``Absolute base path, base address, relative attribute`` () : unit =
use client = HttpClientMock.makeNoUri replyWithUrl
let api = ApiWithAbsoluteBasePathAndAddress.make client
let result = api.GetPathParam("hi").Result
result |> shouldEqual "https://whatnot.com/foo/endpoint/hi"
[<Test>]
let ``Relative base path, no base address, absolute attribute`` () : unit =
do
use client = HttpClientMock.makeNoUri replyWithUrl
let api = ApiWithBasePathAndAbsoluteEndpoint.make client
let exc =
Assert.Throws<AggregateException> (fun () -> api.GetPathParam("hi").Result |> ignore<string>)
exc.InnerException.Message
|> shouldEqual
"No base address was supplied on the type, and no BaseAddress was on the HttpClient. (Parameter 'BaseAddress')"
use client = HttpClientMock.make (Uri "https://whatnot.com/thing/") replyWithUrl
let api = ApiWithBasePathAndAbsoluteEndpoint.make client
let result = api.GetPathParam("hi").Result
result |> shouldEqual "https://whatnot.com/endpoint/hi"
[<Test>]
let ``Relative base path, base address, absolute attribute`` () : unit =
use client = HttpClientMock.makeNoUri replyWithUrl
let api = ApiWithBasePathAndAddressAndAbsoluteEndpoint.make client
let result = api.GetPathParam("hi").Result
result |> shouldEqual "https://whatnot.com/endpoint/hi"
[<Test>]
let ``Absolute base path, no base address, absolute attribute`` () : unit =
do
use client = HttpClientMock.makeNoUri replyWithUrl
let api = ApiWithAbsoluteBasePathAndAbsoluteEndpoint.make client
let exc =
Assert.Throws<AggregateException> (fun () -> api.GetPathParam("hi").Result |> ignore<string>)
exc.InnerException.Message
|> shouldEqual
"No base address was supplied on the type, and no BaseAddress was on the HttpClient. (Parameter 'BaseAddress')"
use client = HttpClientMock.make (Uri "https://whatnot.com/thing/") replyWithUrl
let api = ApiWithAbsoluteBasePathAndAbsoluteEndpoint.make client
let result = api.GetPathParam("hi").Result
result |> shouldEqual "https://whatnot.com/endpoint/hi"
[<Test>]
let ``Absolute base path, base address, absolute attribute`` () : unit =
use client = HttpClientMock.makeNoUri replyWithUrl
let api = ApiWithAbsoluteBasePathAndAddressAndAbsoluteEndpoint.make client
let result = api.GetPathParam("hi").Result
result |> shouldEqual "https://whatnot.com/endpoint/hi"

View File

@@ -52,7 +52,13 @@ module TestVariableHeader =
api.GetPathParam("param").Result.Split "\n"
|> Array.sort
|> shouldEqual [| "Authorization: -99" ; "Header-Name: Header-Value" ; "X-Foo: 11" |]
|> shouldEqual
[|
"Authorization: -99"
"Header-Name: Header-Value"
"Something-Else: val"
"X-Foo: 11"
|]
someHeaderCount.Value |> shouldEqual 11
someOtherHeaderCount.Value |> shouldEqual -99
@@ -98,11 +104,23 @@ module TestVariableHeader =
api.GetPathParam("param").Result.Split "\n"
|> Array.sort
|> shouldEqual [| "Authorization: -99" ; "Header-Name: Header-Value" ; "X-Foo: 11" |]
|> shouldEqual
[|
"Authorization: -99"
"Header-Name: Header-Value"
"Something-Else: val"
"X-Foo: 11"
|]
api.GetPathParam("param").Result.Split "\n"
|> Array.sort
|> shouldEqual [| "Authorization: -98" ; "Header-Name: Header-Value" ; "X-Foo: 12" |]
|> shouldEqual
[|
"Authorization: -98"
"Header-Name: Header-Value"
"Something-Else: val"
"X-Foo: 12"
|]
someHeaderCount.Value |> shouldEqual 12
someOtherHeaderCount.Value |> shouldEqual -98

View File

@@ -117,6 +117,7 @@ module TestJsonSerde =
IntMeasureNullable = intMeasureNullable
Enum = enum<SomeEnum> someEnum
Timestamp = timestamp
Unit = ()
}
}
@@ -168,6 +169,7 @@ module TestJsonSerde =
IntMeasureNullable = Nullable -883<measure>
Enum = enum<SomeEnum> 1
Timestamp = DateTimeOffset (2024, 07, 01, 17, 54, 00, TimeSpan.FromHours 1.0)
Unit = ()
}
let expected =
@@ -198,7 +200,8 @@ module TestJsonSerde =
"intMeasureOption": 981,
"intMeasureNullable": -883,
"enum": 1,
"timestamp": "2024-07-01T17:54:00.0000000\u002B01:00"
"timestamp": "2024-07-01T17:54:00.0000000\u002B01:00",
"unit": {}
}
"""
|> fun s -> s.ToCharArray ()
@@ -306,3 +309,166 @@ module TestJsonSerde =
for i in counts do
i |> shouldBeGreaterThan 0
let dict<'a, 'b when 'a : equality> (xs : ('a * 'b) seq) : Dictionary<'a, 'b> =
let result = Dictionary ()
for k, v in xs do
result.Add (k, v)
result
let inline makeJsonArr< ^t, ^u when ^u : (static member op_Implicit : ^t -> JsonNode) and ^u :> JsonNode>
(arr : ^t seq)
: JsonNode
=
let result = JsonArray ()
for a in arr do
result.Add a
result :> JsonNode
let normalise (d : Dictionary<'a, 'b>) : ('a * 'b) list =
d |> Seq.map (fun (KeyValue (a, b)) -> a, b) |> Seq.toList |> List.sortBy fst
[<Test>]
let ``Can collect extension data`` () =
let str =
"""{
"message": { "header": "hi", "value": "bye" },
"something": 3,
"arr": ["egg", "toast"],
"str": "whatnot"
}"""
|> JsonNode.Parse
let expected =
{
Rest =
[
"something", JsonNode.op_Implicit 3
"arr", makeJsonArr [| "egg" ; "toast" |]
"str", JsonNode.op_Implicit "whatnot"
]
|> dict
Message =
Some
{
Header = "hi"
Value = "bye"
}
}
let actual = CollectRemaining.jsonParse str
actual.Message |> shouldEqual expected.Message
normalise actual.Rest
|> List.map (fun (k, v) -> k, v.ToJsonString ())
|> shouldEqual (normalise expected.Rest |> List.map (fun (k, v) -> k, v.ToJsonString ()))
[<Test>]
let ``Can write out extension data`` () =
let expected =
"""{"message":{"header":"hi","value":"bye"},"something":3,"arr":["egg","toast"],"str":"whatnot"}"""
let toWrite =
{
Rest =
[
"something", JsonNode.op_Implicit 3
"arr", makeJsonArr [| "egg" ; "toast" |]
"str", JsonNode.op_Implicit "whatnot"
]
|> dict
Message =
Some
{
Header = "hi"
Value = "bye"
}
}
let actual = CollectRemaining.toJsonNode toWrite |> fun s -> s.ToJsonString ()
actual |> shouldEqual expected
[<Test>]
let ``Can collect extension data, nested`` () =
let str =
"""{
"thing": 99,
"baz": -123,
"remaining": {
"message": { "header": "hi", "value": "bye" },
"something": 3,
"arr": ["egg", "toast"],
"str": "whatnot"
}
}"""
|> JsonNode.Parse
let expected : OuterCollectRemaining =
{
Remaining =
{
Message =
Some
{
Header = "hi"
Value = "bye"
}
Rest =
[
"something", JsonNode.op_Implicit 3
"arr", makeJsonArr [| "egg" ; "toast" |]
"str", JsonNode.op_Implicit "whatnot"
]
|> dict
}
Others = [ "thing", 99 ; "baz", -123 ] |> dict
}
let actual = OuterCollectRemaining.jsonParse str
normalise actual.Others |> shouldEqual (normalise expected.Others)
let actual = actual.Remaining
let expected = expected.Remaining
actual.Message |> shouldEqual expected.Message
normalise actual.Rest
|> List.map (fun (k, v) -> k, v.ToJsonString ())
|> shouldEqual (normalise expected.Rest |> List.map (fun (k, v) -> k, v.ToJsonString ()))
[<Test>]
let ``Can write out extension data, nested`` () =
let expected =
"""{"thing":99,"baz":-123,"remaining":{"message":{"header":"hi","value":"bye"},"something":3,"arr":["egg","toast"],"str":"whatnot"}}"""
let toWrite : OuterCollectRemaining =
{
Others = [ "thing", 99 ; "baz", -123 ] |> dict
Remaining =
{
Rest =
[
"something", JsonNode.op_Implicit 3
"arr", makeJsonArr [| "egg" ; "toast" |]
"str", JsonNode.op_Implicit "whatnot"
]
|> dict
Message =
Some
{
Header = "hi"
Value = "bye"
}
}
}
let actual = OuterCollectRemaining.toJsonNode toWrite |> fun s -> s.ToJsonString ()
actual |> shouldEqual expected

View File

@@ -41,8 +41,8 @@
<ItemGroup>
<PackageReference Include="ApiSurface" Version="4.1.5"/>
<PackageReference Include="FsCheck" Version="2.16.6"/>
<PackageReference Include="FsUnit" Version="6.0.0"/>
<PackageReference Include="Microsoft.NET.Test.Sdk" Version="17.11.0"/>
<PackageReference Include="FsUnit" Version="6.0.1"/>
<PackageReference Include="Microsoft.NET.Test.Sdk" Version="17.11.1"/>
<PackageReference Include="NUnit" Version="4.2.2"/>
<PackageReference Include="NUnit3TestAdapter" Version="4.6.0"/>
</ItemGroup>

View File

@@ -85,8 +85,8 @@ type private ParseFunction<'acc> =
[<RequireQualifiedAccess>]
type private ChoicePositional =
| Normal
| Choice
| Normal of includeFlagLike : SynExpr option
| Choice of includeFlagLike : SynExpr option
type private ParseFunctionPositional = ParseFunction<ChoicePositional>
type private ParseFunctionNonPositional = ParseFunction<Accumulation<ArgumentDefaultSpec>>
@@ -506,11 +506,14 @@ module internal ArgParserGenerator =
let positionalArgAttr =
attrs
|> List.tryFind (fun a ->
|> List.tryPick (fun a ->
match (List.last a.TypeName.LongIdent).idText with
| "PositionalArgsAttribute"
| "PositionalArgs" -> true
| _ -> false
| "PositionalArgs" ->
match a.ArgExpr with
| SynExpr.Const (SynConst.Unit, _) -> Some None
| a -> Some (Some a)
| _ -> None
)
let parseExactModifier =
@@ -580,7 +583,7 @@ module internal ArgParserGenerator =
| None ->
match positionalArgAttr with
| Some _ ->
| Some includeFlagLike ->
let getChoice (spec : ArgumentDefaultSpec option) : unit =
match spec with
| Some _ ->
@@ -607,7 +610,7 @@ module internal ArgParserGenerator =
FieldName = ident
Parser = parser
TargetVariable = Ident.create $"arg_%i{counter}"
Accumulation = ChoicePositional.Choice
Accumulation = ChoicePositional.Choice includeFlagLike
TargetType = parseTy
ArgForm = longForms
Help = helpText
@@ -619,7 +622,7 @@ module internal ArgParserGenerator =
FieldName = ident
Parser = parser
TargetVariable = Ident.create $"arg_%i{counter}"
Accumulation = ChoicePositional.Normal
Accumulation = ChoicePositional.Normal includeFlagLike
TargetType = parseTy
ArgForm = longForms
Help = helpText
@@ -723,7 +726,10 @@ module internal ArgParserGenerator =
]
|> SynExpr.createMatch (SynExpr.callMethod var.idText (SynExpr.createIdent' typeName))
|> SynExpr.pipeThroughFunction (
SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst " (default value: %O)")
SynExpr.createLambda "x" (SynExpr.callMethod "ToString" (SynExpr.createIdent "x"))
)
|> SynExpr.pipeThroughFunction (
SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst " (default value: %s)")
)
|> SynExpr.paren
| Accumulation.List _ -> SynExpr.CreateConst " (can be repeated)"
@@ -786,10 +792,12 @@ module internal ArgParserGenerator =
| Accumulation.Optional ->
let multipleErrorMessage =
SynExpr.createIdent "sprintf"
|> SynExpr.applyTo (SynExpr.CreateConst "Argument '%s' was supplied multiple times: %O and %O")
|> SynExpr.applyTo (SynExpr.CreateConst "Argument '%s' was supplied multiple times: %s and %s")
|> SynExpr.applyTo arg.HumanReadableArgForm
|> SynExpr.applyTo (SynExpr.createIdent "x")
|> SynExpr.applyTo (SynExpr.createIdent "value")
|> SynExpr.applyTo (SynExpr.createIdent "x" |> SynExpr.callMethod "ToString" |> SynExpr.paren)
|> SynExpr.applyTo (
SynExpr.createIdent "value" |> SynExpr.callMethod "ToString" |> SynExpr.paren
)
let performAssignment =
[
@@ -850,8 +858,9 @@ module internal ArgParserGenerator =
|> SynExpr.pipeThroughFunction pos.Parser
|> fun p ->
match pos.Accumulation with
| ChoicePositional.Choice -> p |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2")
| ChoicePositional.Normal -> p
| ChoicePositional.Choice _ ->
p |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2")
| ChoicePositional.Normal _ -> p
|> SynExpr.pipeThroughFunction (
SynExpr.createLongIdent' [ pos.TargetVariable ; Ident.create "Add" ]
)
@@ -995,6 +1004,50 @@ module internal ArgParserGenerator =
|> SynExpr.applyTo (SynExpr.createIdent "key")
|> SynExpr.applyTo (SynExpr.createIdent "value")
let processAsPositional =
SynExpr.sequential
[
SynExpr.createIdent "arg"
|> SynExpr.pipeThroughFunction leftoverArgParser
|> fun p ->
match leftoverArgAcc with
| ChoicePositional.Normal _ -> p
| ChoicePositional.Choice _ ->
p |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2")
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' [ leftoverArgs ; Ident.create "Add" ])
recurseKey
]
let posAttr =
match leftoverArgAcc with
| ChoicePositional.Choice a
| ChoicePositional.Normal a -> a
let notMatched =
let handleFailure =
[
SynMatchClause.create (SynPat.named "None") fail
SynMatchClause.create
(SynPat.nameWithArgs "Some" [ SynPat.named "msg" ])
(SynExpr.sequential
[
SynExpr.createIdent "sprintf"
|> SynExpr.applyTo (SynExpr.CreateConst "%s (at arg %s)")
|> SynExpr.applyTo (SynExpr.createIdent "msg")
|> SynExpr.applyTo (SynExpr.createIdent "arg")
|> SynExpr.pipeThroughFunction (SynExpr.dotGet "Add" (SynExpr.createIdent' errorAcc))
recurseKey
])
]
|> SynExpr.createMatch (SynExpr.createIdent "x")
match posAttr with
| None -> handleFailure
| Some posAttr -> SynExpr.ifThenElse posAttr handleFailure processAsPositional
let argStartsWithDashes =
SynExpr.createIdent "arg"
|> SynExpr.callMethodArg
@@ -1008,19 +1061,7 @@ module internal ArgParserGenerator =
let processKey =
SynExpr.ifThenElse
argStartsWithDashes
(SynExpr.sequential
[
SynExpr.createIdent "arg"
|> SynExpr.pipeThroughFunction leftoverArgParser
|> fun p ->
match leftoverArgAcc with
| ChoicePositional.Normal -> p
| ChoicePositional.Choice ->
p |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2")
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' [ leftoverArgs ; Ident.create "Add" ])
recurseKey
])
processAsPositional
(SynExpr.ifThenElse
(SynExpr.equals (SynExpr.createIdent "arg") (SynExpr.CreateConst "--help"))
(SynExpr.createLet
@@ -1056,23 +1097,9 @@ module internal ArgParserGenerator =
[
SynMatchClause.create (SynPat.nameWithArgs "Ok" [ SynPat.unit ]) recurseKey
SynMatchClause.create (SynPat.nameWithArgs "Error" [ SynPat.named "None" ]) fail
SynMatchClause.create
(SynPat.nameWithArgs
"Error"
[ SynPat.nameWithArgs "Some" [ SynPat.named "msg" ] |> SynPat.paren ])
(SynExpr.sequential
[
SynExpr.createIdent "sprintf"
|> SynExpr.applyTo (SynExpr.CreateConst "%s (at arg %s)")
|> SynExpr.applyTo (SynExpr.createIdent "msg")
|> SynExpr.applyTo (SynExpr.createIdent "arg")
|> SynExpr.pipeThroughFunction (
SynExpr.dotGet "Add" (SynExpr.createIdent' errorAcc)
)
recurseKey
])
(SynPat.nameWithArgs "Error" [ SynPat.named "x" ])
notMatched
]))
(SynExpr.createIdent "args" |> SynExpr.pipeThroughFunction recurseValue)))
(SynExpr.createIdent "helpText"
@@ -1086,6 +1113,8 @@ module internal ArgParserGenerator =
let processValue =
// During failure, we've received an optional exception message that happened when we tried to parse
// the value; it's in the variable `exc`.
// `fail` is for the case where we're genuinely emitting an error.
// If we're in `PositionalArgs true` mode, though, we won't call `fail`.
let fail =
[
SynExpr.createIdent "failwithf"
@@ -1105,6 +1134,27 @@ module internal ArgParserGenerator =
]
|> SynExpr.createMatch (SynExpr.createIdent "exc")
let onFailure =
match posAttr with
| None -> fail
| Some includeFlagLike ->
[
SynExpr.createIdent "key"
|> SynExpr.pipeThroughFunction leftoverArgParser
|> fun i ->
match leftoverArgAcc with
| ChoicePositional.Choice _ ->
i |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2")
| ChoicePositional.Normal _ -> i
|> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' [ leftoverArgs ; Ident.create "Add" ])
SynExpr.createIdent "go"
|> SynExpr.applyTo (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingKey" ])
|> SynExpr.applyTo (SynExpr.listCons (SynExpr.createIdent "arg") (SynExpr.createIdent "args"))
]
|> SynExpr.sequential
|> SynExpr.ifThenElse includeFlagLike fail
[
SynMatchClause.create
(SynPat.nameWithArgs "Ok" [ SynPat.unit ])
@@ -1117,7 +1167,7 @@ module internal ArgParserGenerator =
(SynPat.nameWithArgs "Error" [ SynPat.named "exc" ])
(SynExpr.ifThenElse
(SynExpr.applyFunction (SynExpr.createIdent "setFlagValue") (SynExpr.createIdent "key"))
fail
onFailure
(SynExpr.createIdent "go"
|> SynExpr.applyTo (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingKey" ])
|> SynExpr.applyTo (SynExpr.listCons (SynExpr.createIdent "arg") (SynExpr.createIdent "args"))))
@@ -1184,8 +1234,8 @@ module internal ArgParserGenerator =
)
|> fun p ->
match leftoverArgAcc with
| ChoicePositional.Normal -> p
| ChoicePositional.Choice ->
| ChoicePositional.Normal _ -> p
| ChoicePositional.Choice _ ->
p
|> SynExpr.pipeThroughFunction (
SynExpr.applyFunction
@@ -1257,9 +1307,9 @@ module internal ArgParserGenerator =
SynType.string
| Some pf ->
match pf.Accumulation with
| ChoicePositional.Choice ->
| ChoicePositional.Choice _ ->
pf.TargetVariable, pf.Parser, SynType.app "Choice" [ pf.TargetType ; pf.TargetType ]
| ChoicePositional.Normal -> pf.TargetVariable, pf.Parser, pf.TargetType
| ChoicePositional.Normal _ -> pf.TargetVariable, pf.Parser, pf.TargetType
let bindings =
SynExpr.createIdent "ResizeArray"
@@ -1487,7 +1537,7 @@ module internal ArgParserGenerator =
let leftoverArgAcc =
match pos with
| None -> ChoicePositional.Normal
| None -> ChoicePositional.Normal None
| Some pos -> pos.Accumulation
[
@@ -1521,8 +1571,6 @@ module internal ArgParserGenerator =
|> List.choose (fun ty ->
match ty.Cases with
| [ c1 ; c2 ] ->
match c1.Fields, c2.Fields with
| [], [] ->
let c1Attr =
c1.Attributes
|> List.tryPick (fun attr ->
@@ -1546,7 +1594,13 @@ module internal ArgParserGenerator =
)
match c1Attr, c2Attr with
| Some _, None
| None, Some _ ->
failwith
"[<ArgumentFlag>] must be placed on both cases of a two-case discriminated union, with opposite argument values on each case."
| None, None -> None
| Some c1Attr, Some c2Attr ->
// Sanity check where possible
match c1Attr, c2Attr with
| SynExpr.Const (SynConst.Bool b1, _), SynExpr.Const (SynConst.Bool b2, _) ->
@@ -1555,6 +1609,8 @@ module internal ArgParserGenerator =
"[<ArgumentFlag>] must have opposite argument values on each case in a two-case discriminated union."
| _, _ -> ()
match c1.Fields, c2.Fields with
| [], [] ->
{
Name = ty.Name
Case1Name = c1.Name
@@ -1563,11 +1619,6 @@ module internal ArgParserGenerator =
Case2Arg = c2Attr
}
|> Some
| Some _, None
| None, Some _ ->
failwith
"[<ArgumentFlag>] must be placed on both cases of a two-case discriminated union, with opposite argument values on each case."
| _, _ -> None
| _, _ ->
failwith "[<ArgumentFlag>] may only be placed on discriminated union members with no data."
| _ -> None

View File

@@ -67,7 +67,8 @@ type internal RecordType =
Members : SynMemberDefns option
XmlDoc : PreXmlDoc option
Generics : SynTyparDecls option
Accessibility : SynAccess option
TypeAccessibility : SynAccess option
ImplAccessibility : SynAccess option
Attributes : SynAttribute list
}
@@ -80,17 +81,15 @@ type internal RecordType =
: RecordType
=
match sci with
| SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, access2, _) ->
if access <> access2 then
failwith $"TODO what's happened, two different accessibility modifiers: %O{access} and %O{access2}"
| SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, implAccess, _) ->
{
Name = List.last longId
Fields = recordFields
Members = if smd.IsEmpty then None else Some smd
XmlDoc = if doc.IsEmpty then None else Some doc
Generics = typars
Accessibility = access
ImplAccessibility = implAccess
TypeAccessibility = access
Attributes = attrs |> List.collect (fun l -> l.Attributes)
}
@@ -144,7 +143,9 @@ type internal UnionType =
/// Attributes of the DU (not its cases): `[<Attr>] type Foo = | ...`
Attributes : SynAttribute list
/// Accessibility modifier of the DU: `type private Foo = ...`
Accessibility : SynAccess option
TypeAccessibility : SynAccess option
/// Accessibility modifier of the DU's implementation: `type Foo = private | ...`
ImplAccessibility : SynAccess option
/// The actual DU cases themselves.
Cases : UnionCase<Ident option> list
}
@@ -157,17 +158,15 @@ type internal UnionType =
: UnionType
=
match sci with
| SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, access2, _) ->
if access <> access2 then
failwith $"TODO what's happened, two different accessibility modifiers: %O{access} and %O{access2}"
| SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, implAccess, _) ->
{
Name = List.last longId
Members = if smd.IsEmpty then None else Some smd
XmlDoc = if doc.IsEmpty then None else Some doc
Generics = typars
Attributes = attrs |> List.collect (fun l -> l.Attributes)
Accessibility = access
TypeAccessibility = access
ImplAccessibility = implAccess
Cases = cases |> List.map UnionCase.ofSynUnionCase
}
@@ -213,13 +212,13 @@ module internal AstHelper =
let defineRecordType (record : RecordType) : SynTypeDefn =
let name =
SynComponentInfo.create record.Name
|> SynComponentInfo.setAccessibility record.Accessibility
|> SynComponentInfo.setAccessibility record.TypeAccessibility
|> match record.XmlDoc with
| None -> id
| Some doc -> SynComponentInfo.withDocString doc
|> SynComponentInfo.setGenerics record.Generics
SynTypeDefnRepr.record (Seq.toList record.Fields)
SynTypeDefnRepr.recordWithAccess record.ImplAccessibility (Seq.toList record.Fields)
|> SynTypeDefn.create name
|> SynTypeDefn.withMemberDefns (defaultArg record.Members SynMemberDefns.Empty)

View File

@@ -564,11 +564,12 @@ module internal CataGenerator =
let domain =
field.FieldName
|> Option.map Ident.lowerFirstLetter
|> SynType.signatureParamOfType place
|> SynType.signatureParamOfType [] place false
acc |> SynType.funFromDomain domain
)
|> SynMemberDefn.abstractMember
[]
case.CataMethodIdent
None
arity

View File

@@ -1,5 +1,6 @@
namespace WoofWare.Myriad.Plugins
open System.IO
open System.Net.Http
open Fantomas.FCS.Syntax
@@ -12,6 +13,17 @@ type internal HttpClientGeneratorOutputSpec =
module internal HttpClientGenerator =
open Fantomas.FCS.Text.Range
let outputFile = FileInfo "/tmp/output.txt"
// do
// use _ = File.Create outputFile.FullName
// ()
let log (line : string) =
// use w = outputFile.AppendText ()
// w.WriteLine line
()
[<RequireQualifiedAccess>]
type PathSpec =
| Verbatim of string
@@ -60,6 +72,9 @@ module internal HttpClientGenerator =
BaseAddress : SynExpr option
BasePath : SynExpr option
Accessibility : SynAccess option
/// Headers which apply *only* to this endpoint.
/// For example, SynConst "Authorization" and SynConst "token BLAH".
Headers : (SynExpr * SynExpr) list
}
let httpMethodString (m : HttpMethod) : string =
@@ -321,8 +336,26 @@ module internal HttpClientGenerator =
|> SynExpr.createMatch baseAddress
|> SynExpr.paren
let baseAddress =
match info.BasePath with
| None -> baseAddress
| Some basePath ->
[
baseAddress
yield baseAddress
yield
SynExpr.applyFunction
uriIdent
(SynExpr.tuple
[ basePath ; SynExpr.createLongIdent [ "System" ; "UriKind" ; "Relative" ] ])
]
|> SynExpr.tuple
|> SynExpr.applyFunction uriIdent
[
yield baseAddress
yield
SynExpr.applyFunction
uriIdent
(SynExpr.tuple
@@ -404,14 +437,54 @@ module internal HttpClientGenerator =
retType
(SynExpr.createIdent "jsonNode")
let contentTypeHeader, memberHeaders =
info.Headers
|> List.partition (fun (headerName, headerValue) ->
match headerName |> SynExpr.stripOptionalParen with
| SynExpr.Const (SynConst.String ("Content-Type", _, _), _) -> true
| _ -> false
)
let contentTypeHeader =
match contentTypeHeader with
| [] -> None
| [ _, ct ] -> Some (SynExpr.stripOptionalParen ct)
| _ -> failwith "Unexpectedly got multiple Content-Type headers"
let createStringContent (contents : SynExpr) =
SynExpr.createNew
(SynType.createLongIdent' [ "System" ; "Net" ; "Http" ; "StringContent" ])
(SynExpr.tupleNoParen
[
yield contents
match contentTypeHeader with
| None -> ()
| Some ch ->
yield SynExpr.createNull ()
// Sigh, Gitea in particular passes "json" here
match ch with
| SynExpr.Const (SynConst.String ("json", _, _), _) ->
yield SynExpr.CreateConst "application/json"
| SynExpr.Const (SynConst.String ("html", _, _), _) -> yield SynExpr.CreateConst "text/html"
| _ -> yield ch
])
let handleBodyParams =
match bodyParam with
| None -> []
| Some (bodyParamType, bodyParamName) ->
match bodyParamType with
| BodyParamMethods.StreamContent
| BodyParamMethods.ByteArrayContent
| BodyParamMethods.StringContent ->
[
Let ("queryParams", createStringContent (SynExpr.createIdent' bodyParamName))
Do (
SynExpr.assign
(SynLongIdent.createS' [ "httpMessage" ; "Content" ])
(SynExpr.createIdent "queryParams")
)
]
| BodyParamMethods.StreamContent
| BodyParamMethods.ByteArrayContent ->
[
Let (
"queryParams",
@@ -438,9 +511,8 @@ module internal HttpClientGenerator =
[
Let (
"queryParams",
SynExpr.createNew
(SynType.createLongIdent' [ "System" ; "Net" ; "Http" ; "StringContent" ])
(SynExpr.createIdent' bodyParamName
createStringContent (
SynExpr.createIdent' bodyParamName
|> SynExpr.pipeThroughFunction (fst (JsonSerializeGenerator.serializeNode ty))
|> SynExpr.pipeThroughFunction (
SynExpr.createLambda
@@ -453,7 +525,8 @@ module internal HttpClientGenerator =
(SynExpr.createLongIdent [ "node" ; "ToJsonString" ])
(SynExpr.CreateConst ()))
(SynExpr.CreateConst "null"))
))
)
)
)
Do (
SynExpr.assign
@@ -522,6 +595,16 @@ module internal HttpClientGenerator =
|> Do
)
let setMemberHeaders =
memberHeaders
|> List.map (fun (headerName, headerValue) ->
// Best-effort: assume this is a message header.
SynExpr.applyFunction
(SynExpr.createLongIdent [ "httpMessage" ; "Headers" ; "Add" ])
(SynExpr.tuple [ headerName ; headerValue ])
|> Do
)
[
yield LetBang ("ct", SynExpr.createLongIdent [ "Async" ; "CancellationToken" ])
yield Let ("uri", requestUri)
@@ -537,6 +620,7 @@ module internal HttpClientGenerator =
yield! setVariableHeaders
yield! setConstantHeaders
yield! setMemberHeaders
yield
LetBang (
@@ -563,6 +647,9 @@ module internal HttpClientGenerator =
yield jsonNode
| String -> yield responseString
| Stream -> yield responseStream
| Unit ->
// What we're returning doesn't depend on the content, so don't bother!
()
| _ ->
yield responseStream
yield jsonNode
@@ -647,6 +734,15 @@ module internal HttpClientGenerator =
| _ -> None
)
let insertTrailingSlash (path : SynExpr) : SynExpr =
match path |> SynExpr.stripOptionalParen with
| SynExpr.Const (SynConst.String (s, _, _), _) ->
if s.EndsWith '/' then
path
else
SynExpr.CreateConst (s + "/")
| _ -> SynExpr.plus (SynExpr.paren path) (SynExpr.CreateConst "/")
let createModule
(opens : SynOpenDeclTarget list)
(ns : LongIdent)
@@ -676,8 +772,17 @@ module internal HttpClientGenerator =
"Expected constant header parameters to be of the form [<Header (key, value)>], but got more than two args"
)
let baseAddress = extractBaseAddress interfaceType.Attributes
let basePath = extractBasePath interfaceType.Attributes
let baseAddress =
extractBaseAddress interfaceType.Attributes
// We artificially insert a trailing slash because this is almost certainly
// not meant to be an endpoint itself.
|> Option.map insertTrailingSlash
let basePath =
extractBasePath interfaceType.Attributes
// We artificially insert a trailing slash because this is almost certainly
// not meant to be an endpoint itself.
|> Option.map insertTrailingSlash
let properties =
interfaceType.Properties
@@ -705,6 +810,16 @@ module internal HttpClientGenerator =
|> List.map (fun mem ->
let httpMethod, url = extractHttpInformation mem.Attributes
let specificHeaders =
extractHeaderInformation mem.Attributes
|> List.map (fun l ->
match l with
| [ x ; y ] -> x, y
| _ ->
failwith
$"Expected Header attribute on member %s{mem.Identifier.idText} to have exactly two arguments."
)
let shouldEnsureSuccess = not (shouldAllowAnyStatusCode mem.Attributes)
let returnType =
@@ -745,6 +860,7 @@ module internal HttpClientGenerator =
BaseAddress = baseAddress
BasePath = basePath
Accessibility = mem.Accessibility
Headers = specificHeaders
}
)
|> List.map (constructMember constantHeaders properties)

View File

@@ -212,7 +212,8 @@ module internal InterfaceMockGenerator =
Members = Some ([ constructor ; interfaceMembers ] @ extraInterfaces)
XmlDoc = Some xmlDoc
Generics = interfaceType.Generics
Accessibility = Some access
TypeAccessibility = Some access
ImplAccessibility = None
Attributes = []
}
@@ -227,14 +228,11 @@ module internal InterfaceMockGenerator =
x.Type
let private constructMemberSinglePlace (tuple : TupledArg) : SynType =
match tuple.Args |> List.rev |> List.map buildType with
| [] -> failwith "no-arg functions not supported yet"
| [ x ] -> x
| last :: rest ->
([ SynTupleTypeSegment.Type last ], rest)
||> List.fold (fun ty nextArg -> SynTupleTypeSegment.Type nextArg :: SynTupleTypeSegment.Star range0 :: ty)
|> fun segs -> SynType.Tuple (false, segs, range0)
|> fun ty -> if tuple.HasParen then SynType.Paren (ty, range0) else ty
tuple.Args
|> List.map buildType
|> SynType.tupleNoParen
|> Option.defaultWith (fun () -> failwith "no-arg functions not supported yet")
|> if tuple.HasParen then SynType.paren else id
let constructMember (mem : MemberInfo) : SynField =
let inputType = mem.Args |> List.map constructMemberSinglePlace

View File

@@ -59,7 +59,7 @@ module internal JsonParseGenerator =
| None -> node
| Some propertyName -> assertNotNull propertyName node
|> SynExpr.callMethod "AsValue"
|> SynExpr.callGenericMethod "GetValue" typeName
|> SynExpr.callGenericMethod (SynLongIdent.createS "GetValue") [ SynType.createLongIdent typeName ]
/// {node}.AsObject()
/// If `propertyName` is Some, uses `assertNotNull {node}` instead of `{node}`.
@@ -279,6 +279,8 @@ module internal JsonParseGenerator =
| Measure (_measure, primType) ->
parseNumberType options propertyName node primType
|> SynExpr.pipeThroughFunction (Measure.getLanguagePrimitivesMeasure primType)
| JsonNode -> node
| Unit -> SynExpr.CreateConst ()
| _ ->
// Let's just hope that we've also got our own type annotation!
let typeName =
@@ -375,9 +377,9 @@ module internal JsonParseGenerator =
)
let createRecordMaker (spec : JsonParseOutputSpec) (fields : SynFieldData<Ident> list) =
let assignments =
let propertyFields =
fields
|> List.mapi (fun i fieldData ->
|> List.map (fun fieldData ->
let propertyNameAttr =
fieldData.Attrs
|> List.tryFind (fun attr ->
@@ -385,7 +387,12 @@ module internal JsonParseGenerator =
.EndsWith ("JsonPropertyName", StringComparison.Ordinal)
)
let options = getParseOptions fieldData.Attrs
let extensionDataAttr =
fieldData.Attrs
|> List.tryFind (fun attr ->
(SynLongIdent.toString attr.TypeName)
.EndsWith ("JsonExtensionData", StringComparison.Ordinal)
)
let propertyName =
match propertyNameAttr with
@@ -401,8 +408,77 @@ module internal JsonParseGenerator =
sb.ToString () |> SynExpr.CreateConst
| Some name -> name.ArgExpr
propertyName, extensionDataAttr
)
let namedPropertyFields =
propertyFields
|> List.choose (fun (name, extension) ->
match extension with
| Some _ -> None
| None -> Some name
)
let isNamedPropertyField =
match namedPropertyFields with
| [] -> SynExpr.CreateConst false
| _ ->
namedPropertyFields
|> List.map (fun fieldName -> SynExpr.equals (SynExpr.createIdent "key") fieldName)
|> List.reduce SynExpr.booleanOr
let assignments =
List.zip fields propertyFields
|> List.mapi (fun i (fieldData, (propertyName, extensionDataAttr)) ->
let options = getParseOptions fieldData.Attrs
let accIdent = Ident.create $"arg_%i{i}"
match extensionDataAttr with
| Some _ ->
// Can't go through the usual parse logic here, because that will try and identify the node that's
// been labelled. The whole point of JsonExtensionData is that there is no such node!
let valType =
match fieldData.Type with
| DictionaryType (String, v) -> v
| _ -> failwith "Expected JsonExtensionData to be Dictionary<string, _>"
SynExpr.ifThenElse
isNamedPropertyField
(SynExpr.callMethodArg
"Add"
(SynExpr.tuple
[
SynExpr.createIdent "key"
createParseRhs options (SynExpr.createIdent "key") valType
])
(SynExpr.createIdent "result"))
(SynExpr.CreateConst ())
|> SynExpr.createForEach
(SynPat.nameWithArgs "KeyValue" [ SynPat.named "key" ; SynPat.named "value" ])
(SynExpr.createIdent "node")
|> fun forEach -> [ forEach ; SynExpr.createIdent "result" ]
|> SynExpr.sequential
|> SynExpr.createLet
[
SynBinding.basic
[ Ident.create "result" ]
[]
(SynExpr.typeApp
[ SynType.string ; valType ]
(SynExpr.createLongIdent [ "System" ; "Collections" ; "Generic" ; "Dictionary" ])
|> SynExpr.applyTo (SynExpr.CreateConst ()))
SynBinding.basic
[ Ident.create "node" ]
[]
(SynExpr.createIdent "node" |> SynExpr.callMethod "AsObject")
]
|> SynBinding.basic [ accIdent ] []
| None ->
createParseRhs options propertyName fieldData.Type
|> SynBinding.basic [ Ident.create $"arg_%i{i}" ] []
|> SynBinding.basic [ accIdent ] []
)
let finalConstruction =
@@ -483,9 +559,7 @@ module internal JsonParseGenerator =
|> SynExpr.index property
|> assertNotNull property
|> SynExpr.pipeThroughFunction (
SynExpr.createLambda
"v"
(SynExpr.callGenericMethod "GetValue" [ Ident.create "string" ] (SynExpr.createIdent "v"))
SynExpr.createLambda "v" (SynExpr.callGenericMethod' "GetValue" "string" (SynExpr.createIdent "v"))
)
|> SynBinding.basic [ Ident.create "ty" ] []
]

View File

@@ -146,6 +146,13 @@ module internal JsonSerializeGenerator =
]
|> SynExpr.createLambda "field"
|> fun e -> e, false
| JsonNode -> SynExpr.createIdent "id", true
| Unit ->
SynExpr.createLambda
"value"
(SynExpr.createLongIdent [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonObject" ]
|> SynExpr.applyTo (SynExpr.CreateConst ())),
false
| _ ->
// {type}.toJsonNode
let typeName =
@@ -187,6 +194,14 @@ module internal JsonSerializeGenerator =
sb.ToString () |> SynExpr.CreateConst
| Some name -> name.ArgExpr
let getIsJsonExtension (attrs : SynAttribute list) : bool =
attrs
|> List.tryFind (fun attr ->
(SynLongIdent.toString attr.TypeName)
.EndsWith ("JsonExtensionData", StringComparison.Ordinal)
)
|> Option.isSome
/// `populateNode` will be inserted before we return the `node` variable.
///
/// That is, we give you access to a `JsonObject` called `node`,
@@ -256,6 +271,30 @@ module internal JsonSerializeGenerator =
fields
|> List.map (fun fieldData ->
let propertyName = getPropertyName fieldData.Ident fieldData.Attrs
let isJsonExtension = getIsJsonExtension fieldData.Attrs
if isJsonExtension then
let valType =
match fieldData.Type with
| DictionaryType (String, v) -> v
| _ -> failwith "Expected JsonExtensionData to be a Dictionary<string, something>"
let serialise = fst (serializeNode valType)
SynExpr.createIdent "node"
|> SynExpr.callMethodArg
"Add"
(SynExpr.tuple
[
SynExpr.createIdent "key"
SynExpr.applyFunction serialise (SynExpr.createIdent "value")
])
|> SynExpr.createForEach
(SynPat.identWithArgs
[ Ident.create "KeyValue" ]
(SynArgPats.create [ SynPat.named "key" ; SynPat.named "value" ]))
(SynExpr.createLongIdent' [ Ident.create "input" ; fieldData.Ident ])
else
createSerializeRhsRecord propertyName fieldData.Ident fieldData.Type
)
|> SynExpr.sequential

View File

@@ -36,7 +36,6 @@ module internal RemoveOptionsGenerator =
trivia
)
// TODO: this option seems a bit odd
let createType
(xmlDoc : PreXmlDoc option)
(accessibility : SynAccess option)
@@ -54,7 +53,8 @@ module internal RemoveOptionsGenerator =
Members = None
XmlDoc = xmlDoc
Generics = generics
Accessibility = accessibility
TypeAccessibility = accessibility
ImplAccessibility = None
Attributes = []
}
@@ -62,7 +62,7 @@ module internal RemoveOptionsGenerator =
SynModuleDecl.Types ([ typeDecl ], range0)
let createMaker (withOptionsType : LongIdent) (withoutOptionsType : LongIdent) (fields : SynFieldData<Ident> list) =
let createMaker (withOptionsType : LongIdent) (withoutOptionsType : Ident) (fields : SynFieldData<Ident> list) =
let xmlDoc = PreXmlDoc.create "Remove the optional members of the input."
let inputArg = Ident.create "input"
@@ -87,7 +87,7 @@ module internal RemoveOptionsGenerator =
SynExpr.applyFunction
(SynExpr.createLongIdent [ "Option" ; "defaultWith" ])
(SynExpr.createLongIdent' (
withoutOptionsType
[ withoutOptionsType ]
@ [ Ident.create (sprintf "Default%s" fieldData.Ident.idText) ]
))
)
@@ -101,39 +101,28 @@ module internal RemoveOptionsGenerator =
[ functionName ]
[
SynPat.named inputArg.idText
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create withoutOptionsType))
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.createI 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, _, _)) =
typeDefn
let (SynComponentInfo (_attributes, typeParams, _constraints, recordId, doc, _preferPostfix, _access, _)) =
synComponentInfo
match synTypeDefnRepr with
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (accessibility, fields, _range), _) ->
let fieldData = fields |> List.map SynField.extractWithIdent
let createRecordModule (namespaceId : LongIdent) (typeDefn : RecordType) =
let fieldData = typeDefn.Fields |> List.map SynField.extractWithIdent
let decls =
[
createType (Some doc) accessibility typeParams fields
createMaker [ Ident.create "Short" ] recordId fieldData
createType typeDefn.XmlDoc typeDefn.TypeAccessibility typeDefn.Generics typeDefn.Fields
createMaker [ Ident.create "Short" ] typeDefn.Name fieldData
]
let xmlDoc =
recordId
|> Seq.map (fun i -> i.idText)
|> String.concat "."
|> sprintf "Module containing an option-truncated version of the %s type"
sprintf "Module containing an option-truncated version of the %s type" typeDefn.Name.idText
|> PreXmlDoc.create
let info =
SynComponentInfo.createLong recordId
SynComponentInfo.create typeDefn.Name
|> SynComponentInfo.withDocString xmlDoc
|> SynComponentInfo.addAttributes [ SynAttribute.compilationRepresentation ]
|> SynComponentInfo.addAttributes [ SynAttribute.requireQualifiedAccess ]
@@ -141,7 +130,6 @@ module internal RemoveOptionsGenerator =
SynModuleDecl.nestedModule info decls
|> List.singleton
|> SynModuleOrNamespace.createNamespace namespaceId
| _ -> failwithf "Not a record type"
open Myriad.Core
@@ -164,7 +152,24 @@ type RemoveOptionsGenerator () =
|> List.choose (fun (ns, types) ->
match types |> List.filter Ast.hasAttribute<RemoveOptionsAttribute> with
| [] -> None
| types -> Some (ns, types)
| types ->
let types =
types
|> List.map (fun ty ->
match ty with
| SynTypeDefn.SynTypeDefn (sci,
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (access,
fields,
_),
_),
smd,
smdo,
_,
_) -> RecordType.OfRecord sci smd access fields
| _ -> failwith "unexpectedly not a record"
)
Some (ns, types)
)
let modules =

View File

@@ -2,6 +2,7 @@ namespace WoofWare.Myriad.Plugins
open System
open System.Text
open System.Text.RegularExpressions
open Fantomas.FCS.Syntax
open Fantomas.FCS.Text.Range
@@ -9,6 +10,54 @@ open Fantomas.FCS.Text.Range
module internal Ident =
let inline create (s : string) = Ident (s, range0)
/// Fantomas bug, perhaps? "type" is not rendered as ``type``, although the ASTs are identical
/// apart from the ranges?
/// Awful hack: here is a function that does this sort of thing.
let createSanitisedParamName (s : string) =
match s with
| "type" -> create "type'"
| "private" -> create "private'"
| _ ->
let result = StringBuilder ()
for i = 0 to s.Length - 1 do
if Char.IsLetter s.[i] then
result.Append s.[i] |> ignore<StringBuilder>
elif Char.IsNumber s.[i] then
if result.Length > 0 then
result.Append s.[i] |> ignore<StringBuilder>
elif s.[i] = '_' || s.[i] = '-' then
result.Append '_' |> ignore<StringBuilder>
else
failwith $"could not convert to ident: %s{s}"
create (result.ToString ())
let private alnum = Regex @"^[a-zA-Z][a-zA-Z0-9]*$"
let createSanitisedTypeName (s : string) =
let result = StringBuilder ()
let mutable capitalize = true
for i = 0 to s.Length - 1 do
if Char.IsLetter s.[i] then
if capitalize then
result.Append (Char.ToUpperInvariant s.[i]) |> ignore<StringBuilder>
capitalize <- false
else
result.Append s.[i] |> ignore<StringBuilder>
elif Char.IsNumber s.[i] then
if result.Length > 0 then
result.Append s.[i] |> ignore<StringBuilder>
elif s.[i] = '_' then
capitalize <- true
if result.Length = 0 then
failwith $"String %s{s} was not suitable as a type identifier"
Ident (result.ToString (), range0)
let lowerFirstLetter (x : Ident) : Ident =
let result = StringBuilder x.idText.Length
result.Append (Char.ToLowerInvariant x.idText.[0]) |> ignore

View File

@@ -6,7 +6,12 @@ open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal PreXmlDoc =
let create (s : string) : PreXmlDoc =
PreXmlDoc.Create ([| " " + s |], range0)
let s = s.Split "\n"
for i = 0 to s.Length - 1 do
s.[i] <- " " + s.[i]
PreXmlDoc.Create (s, range0)
let create' (s : string seq) : PreXmlDoc =
PreXmlDoc.Create (Array.ofSeq s, range0)

View File

@@ -9,12 +9,12 @@ module internal SynArgPats =
match caseNames.Length with
| 0 -> SynArgPats.Pats []
| 1 ->
SynPat.Named (SynIdent.SynIdent (Ident.create caseNames.[0], None), false, None, range0)
SynPat.Named (SynIdent.createS caseNames.[0], false, None, range0)
|> List.singleton
|> SynArgPats.Pats
| len ->
caseNames
|> List.map (fun name -> SynPat.Named (SynIdent.SynIdent (Ident.create name, None), false, None, range0))
|> List.map (fun name -> SynPat.Named (SynIdent.createS name, false, None, range0))
|> fun t -> SynPat.Tuple (false, t, List.replicate (len - 1) range0, range0)
|> fun t -> SynPat.Paren (t, range0)
|> List.singleton

View File

@@ -5,32 +5,23 @@ open Fantomas.FCS.Text.Range
[<RequireQualifiedAccess>]
module internal SynAttribute =
let internal compilationRepresentation : SynAttribute =
let inline create (typeName : SynLongIdent) (arg : SynExpr) : SynAttribute =
{
TypeName = SynLongIdent.createS "CompilationRepresentation"
ArgExpr =
TypeName = typeName
ArgExpr = arg
Target = None
AppliesToGetterAndSetter = false
Range = range0
}
let internal compilationRepresentation : SynAttribute =
[ "CompilationRepresentationFlags" ; "ModuleSuffix" ]
|> SynExpr.createLongIdent
|> SynExpr.paren
Target = None
AppliesToGetterAndSetter = false
Range = range0
}
|> create (SynLongIdent.createS "CompilationRepresentation")
let internal requireQualifiedAccess : SynAttribute =
{
TypeName = SynLongIdent.createS "RequireQualifiedAccess"
ArgExpr = SynExpr.CreateConst ()
Target = None
AppliesToGetterAndSetter = false
Range = range0
}
create (SynLongIdent.createS "RequireQualifiedAccess") (SynExpr.CreateConst ())
let internal autoOpen : SynAttribute =
{
TypeName = SynLongIdent.createS "AutoOpen"
ArgExpr = SynExpr.CreateConst ()
Target = None
AppliesToGetterAndSetter = false
Range = range0
}
create (SynLongIdent.createS "AutoOpen") (SynExpr.CreateConst ())

View File

@@ -80,6 +80,16 @@ module internal SynExpr =
let equals (a : SynExpr) (b : SynExpr) =
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.eq, a) |> applyTo b
/// {a} && {b}
let booleanAnd (a : SynExpr) (b : SynExpr) =
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.booleanAnd, a)
|> applyTo b
/// {a} || {b}
let booleanOr (a : SynExpr) (b : SynExpr) =
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.booleanOr, a)
|> applyTo b
/// {a} + {b}
let plus (a : SynExpr) (b : SynExpr) =
SynExpr.CreateAppInfix (
@@ -131,16 +141,15 @@ module internal SynExpr =
let typeApp (types : SynType list) (operand : SynExpr) =
SynExpr.TypeApp (operand, range0, types, List.replicate (types.Length - 1) range0, Some range0, range0, range0)
let callGenericMethod (meth : string) (ty : LongIdent) (obj : SynExpr) : SynExpr =
SynExpr.DotGet (obj, range0, SynLongIdent.createS meth, range0)
|> typeApp [ SynType.LongIdent (SynLongIdent.create ty) ]
/// {obj}.{meth}<types,...>()
let callGenericMethod (meth : SynLongIdent) (types : SynType list) (obj : SynExpr) : SynExpr =
SynExpr.DotGet (obj, range0, meth, range0)
|> typeApp types
|> applyTo (SynExpr.CreateConst ())
/// {obj}.{meth}<ty>()
let callGenericMethod' (meth : string) (ty : string) (obj : SynExpr) : SynExpr =
SynExpr.DotGet (obj, range0, SynLongIdent.createS meth, range0)
|> typeApp [ SynType.createLongIdent' [ ty ] ]
|> applyTo (SynExpr.CreateConst ())
callGenericMethod (SynLongIdent.createS meth) [ SynType.createLongIdent' [ ty ] ] obj
let inline index (property : SynExpr) (obj : SynExpr) : SynExpr =
SynExpr.DotIndexedGet (obj, property, range0, range0)
@@ -232,6 +241,8 @@ module internal SynExpr =
let inline createLet (bindings : SynBinding list) (body : SynExpr) : SynExpr =
SynExpr.LetOrUse (false, false, bindings, body, range0, SynExprLetOrUseTrivia.empty)
let inline createDo (body : SynExpr) : SynExpr = SynExpr.Do (body, range0)
let inline createMatch (matchOn : SynExpr) (cases : SynMatchClause list) : SynExpr =
SynExpr.Match (
DebugPointAtBinding.Yes range0,

View File

@@ -0,0 +1,10 @@
namespace WoofWare.Myriad.Plugins
open Fantomas.FCS.Syntax
[<RequireQualifiedAccess>]
module internal SynIdent =
let inline createI (i : Ident) : SynIdent = SynIdent.SynIdent (i, None)
let inline createS (i : string) : SynIdent =
SynIdent.SynIdent (Ident.create i, None)

View File

@@ -33,6 +33,12 @@ module internal SynLongIdent =
let eq =
SynLongIdent.SynLongIdent ([ Ident.create "op_Equality" ], [], [ Some (IdentTrivia.OriginalNotation "=") ])
let booleanAnd =
SynLongIdent.SynLongIdent ([ Ident.create "op_BooleanAnd" ], [], [ Some (IdentTrivia.OriginalNotation "&&") ])
let booleanOr =
SynLongIdent.SynLongIdent ([ Ident.create "op_BooleanOr" ], [], [ Some (IdentTrivia.OriginalNotation "||") ])
let pipe =
SynLongIdent.SynLongIdent ([ Ident.create "op_PipeRight" ], [], [ Some (IdentTrivia.OriginalNotation "|>") ])

View File

@@ -17,8 +17,8 @@ module internal SynMemberDefn =
SynMemberFlags.MemberKind = SynMemberKind.Member
}
let abstractMember
(attrs : SynAttribute list)
(ident : SynIdent)
(typars : SynTyparDecls option)
(arity : SynValInfo)
@@ -28,7 +28,13 @@ module internal SynMemberDefn =
=
let slot =
SynValSig.SynValSig (
[],
attrs
|> List.map (fun attr ->
{
Attributes = [ attr ]
Range = range0
}
),
ident,
SynValTyparDecls.SynValTyparDecls (typars, true),
returnType,

View File

@@ -181,6 +181,29 @@ module internal SynTypePatterns =
_) -> Some (ident, outer)
| _ -> None
let (|JsonNode|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText) with
| [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
| [ "Text" ; "Json" ; "Nodes" ; "JsonNode" ]
| [ "Json" ; "Nodes" ; "JsonNode" ]
| [ "Nodes" ; "JsonNode" ]
| [ "JsonNode" ] -> Some ()
| _ -> None
| _ -> None
let (|Unit|_|) (fieldType : SynType) : unit option =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
match ident |> List.map (fun i -> i.idText.ToLowerInvariant ()) with
| [ "microsoft" ; "fsharp" ; "core" ; "unit" ]
| [ "fsharp" ; "core" ; "unit" ]
| [ "core" ; "unit" ]
| [ "unit" ] -> Some ()
| _ -> None
| _ -> None
let (|DateOnly|_|) (fieldType : SynType) =
match fieldType with
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
@@ -267,6 +290,8 @@ module internal SynType =
| SynType.Paren (ty, _) -> stripOptionalParen ty
| ty -> ty
let inline paren (ty : SynType) : SynType = SynType.Paren (ty, range0)
let inline createLongIdent (ident : LongIdent) : SynType =
SynType.LongIdent (SynLongIdent.create ident)
@@ -283,6 +308,17 @@ module internal SynType =
let inline app (name : string) (args : SynType list) : SynType = app' (named name) args
/// Returns None if the input list was empty.
let inline tupleNoParen (ty : SynType list) : SynType option =
match List.rev ty with
| [] -> None
| [ t ] -> Some t
| t :: rest ->
([ SynTupleTypeSegment.Type t ], rest)
||> List.fold (fun ty nextArg -> SynTupleTypeSegment.Type nextArg :: SynTupleTypeSegment.Star range0 :: ty)
|> fun segs -> SynType.Tuple (false, segs, range0)
|> Some
let inline appPostfix (name : string) (arg : SynType) : SynType =
SynType.App (named name, None, [ arg ], [], None, true, range0)
@@ -299,16 +335,54 @@ module internal SynType =
}
)
let inline signatureParamOfType (ty : SynType) (name : Ident option) : SynType =
SynType.SignatureParameter ([], false, name, ty, range0)
let inline signatureParamOfType
(attrs : SynAttribute list)
(ty : SynType)
(optional : bool)
(name : Ident option)
: SynType
=
SynType.SignatureParameter (
attrs
|> List.map (fun attr ->
{
Attributes = [ attr ]
Range = range0
}
),
optional,
name,
ty,
range0
)
let inline var (ty : SynTypar) : SynType = SynType.Var (ty, range0)
let unit : SynType = named "unit"
let obj : SynType = named "obj"
let bool : SynType = named "bool"
let int : SynType = named "int"
let array (elt : SynType) : SynType = SynType.Array (1, elt, range0)
let list (elt : SynType) : SynType =
SynType.App (named "list", None, [ elt ], [], None, true, range0)
let option (elt : SynType) : SynType =
SynType.App (named "option", None, [ elt ], [], None, true, range0)
let anon : SynType = SynType.Anon range0
let task (elt : SynType) : SynType =
SynType.App (
createLongIdent' [ "System" ; "Threading" ; "Tasks" ; "Task" ],
None,
[ elt ],
[],
None,
true,
range0
)
let string : SynType = named "string"
/// Given ['a1, 'a2] and 'ret, returns 'a1 -> 'a2 -> 'ret.

View File

@@ -13,8 +13,12 @@ module internal SynTypeDefnRepr =
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 unionWithAccess (implAccess : SynAccess option) (cases : SynUnionCase list) : SynTypeDefnRepr =
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (implAccess, cases, range0), range0)
let inline record (fields : SynField list) : SynTypeDefnRepr =
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, fields, range0), range0)
let inline union (cases : SynUnionCase list) : SynTypeDefnRepr = unionWithAccess None cases
let inline recordWithAccess (implAccess : SynAccess option) (fields : SynField list) : SynTypeDefnRepr =
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (implAccess, fields, range0), range0)
let inline record (fields : SynField list) : SynTypeDefnRepr = recordWithAccess None fields

View File

@@ -44,7 +44,7 @@ module internal SynUnionCase =
SynUnionCase.SynUnionCase (
SynAttributes.ofAttrs case.Attributes,
SynIdent.SynIdent (case.Name, None),
SynIdent.createI case.Name,
SynUnionCaseKind.Fields fields,
case.XmlDoc |> Option.defaultValue PreXmlDoc.Empty,
case.Access,

View File

@@ -30,6 +30,7 @@
<Compile Include="SynExpr\SynAttributes.fs" />
<Compile Include="SynExpr\PreXmlDoc.fs" />
<Compile Include="SynExpr\Ident.fs" />
<Compile Include="SynExpr\SynIdent.fs" />
<Compile Include="SynExpr\SynLongIdent.fs" />
<Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" />
<Compile Include="SynExpr\SynArgPats.fs" />

View File

@@ -1,5 +1,5 @@
{
"version": "2.3",
"version": "3.0",
"publicReleaseRefSpec": [
"^refs/heads/main$"
],

6
flake.lock generated
View File

@@ -20,11 +20,11 @@
},
"nixpkgs": {
"locked": {
"lastModified": 1725099143,
"narHash": "sha256-CHgumPZaC7z+WYx72WgaLt2XF0yUVzJS60rO4GZ7ytY=",
"lastModified": 1725534445,
"narHash": "sha256-Yd0FK9SkWy+ZPuNqUgmVPXokxDgMJoGuNpMEtkfcf84=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "5629520edecb69630a3f4d17d3d33fc96c13f6fe",
"rev": "9bb1e7571aadf31ddb4af77fc64b2d59580f9a39",
"type": "github"
},
"original": {

View File

@@ -8,8 +8,8 @@
})
(fetchNuGet {
pname = "fantomas";
version = "6.3.11";
hash = "sha256-11bHGEAZTNtdp2pTg5zqLrQiyI/j/AT7GGL/2CR4+dw=";
version = "6.3.15";
hash = "sha256-Gjw7MxjUNckMWSfnOye4UTe5fZWnor6RHCls3PNsuG8=";
})
(fetchNuGet {
pname = "Fantomas.Core";
@@ -48,8 +48,8 @@
})
(fetchNuGet {
pname = "FsUnit";
version = "6.0.0";
hash = "sha256-q87WQf6MqGhzvaQ7WkkUlCdoE94DY0CD5PaXEj64A6M=";
version = "6.0.1";
hash = "sha256-vka/aAgWhDCl5tu+kgO7GtSaHOOvlSaWxG+tExwGXpI=";
})
(fetchNuGet {
pname = "Microsoft.AspNetCore.App.Ref";
@@ -78,13 +78,13 @@
})
(fetchNuGet {
pname = "Microsoft.CodeCoverage";
version = "17.11.0";
hash = "sha256-XglInnx5GePUYHG7n2NLX+WfK7kJnornsWOW/5FnOXE=";
version = "17.11.1";
hash = "sha256-1dLlK3NGh88PuFYZiYpT+izA96etxhU3BSgixDgdtGA=";
})
(fetchNuGet {
pname = "Microsoft.NET.Test.Sdk";
version = "17.11.0";
hash = "sha256-WjyA78+PG9ZloWTt9Hf1ek3VVj2FfJ9fAjqklnN+fWw=";
version = "17.11.1";
hash = "sha256-0JUEucQ2lzaPgkrjm/NFLBTbqU1dfhvhN3Tl3moE6mI=";
})
(fetchNuGet {
pname = "Microsoft.NETCore.App.Host.linux-arm64";
@@ -153,13 +153,13 @@
})
(fetchNuGet {
pname = "Microsoft.TestPlatform.ObjectModel";
version = "17.11.0";
hash = "sha256-mCI3MCV6nyrGLrBat5VvK5LrXTEKlsdp9NkpZyJYwVg=";
version = "17.11.1";
hash = "sha256-5vX+vCzFY3S7xfMVIv8OlMMFtdedW9UIJzc0WEc+vm4=";
})
(fetchNuGet {
pname = "Microsoft.TestPlatform.TestHost";
version = "17.11.0";
hash = "sha256-gViDLobza22kuLvB4JdlGtbANqwBHRwf1wLmIHMw9Eo=";
version = "17.11.1";
hash = "sha256-wSkY0H1fQAq0H3LcKT4u7Y5RzhAAPa6yueVN84g8HxU=";
})
(fetchNuGet {
pname = "Myriad.Core";