mirror of
https://github.com/Smaug123/WoofWare.Myriad
synced 2025-10-06 12:38:40 +00:00
Compare commits
8 Commits
WoofWare.M
...
WoofWare.M
Author | SHA1 | Date | |
---|---|---|---|
|
417ca45c37 | ||
|
569b3cc553 | ||
|
20226b9da9 | ||
|
f800e53bff | ||
|
5358f5da0e | ||
|
a868b8c08e | ||
|
a4f945a3ee | ||
|
8434730ba7 |
14
.github/workflows/assert-contents.sh
vendored
14
.github/workflows/assert-contents.sh
vendored
@@ -1,14 +0,0 @@
|
||||
#!/bin/bash
|
||||
|
||||
echo "Unzipping version from NuGet"
|
||||
ls from-nuget.nupkg
|
||||
mkdir from-nuget && cp from-nuget.nupkg from-nuget/zip.zip && cd from-nuget && unzip zip.zip && rm zip.zip && cd - || exit 1
|
||||
|
||||
echo "Unzipping version from local build"
|
||||
ls packed/
|
||||
mkdir from-local && cp packed/*.nupkg from-local/zip.zip && cd from-local && unzip zip.zip && rm zip.zip && cd - || exit 1
|
||||
|
||||
cd from-local && find . -type f -exec sha256sum {} \; | sort > ../from-local.txt && cd .. || exit 1
|
||||
cd from-nuget && find . -type f -and -not -name '.signature.p7s' -exec sha256sum {} \; | sort > ../from-nuget.txt && cd .. || exit 1
|
||||
|
||||
diff from-local.txt from-nuget.txt
|
52
.github/workflows/dotnet.yaml
vendored
52
.github/workflows/dotnet.yaml
vendored
@@ -222,7 +222,7 @@ jobs:
|
||||
if: ${{ always() }}
|
||||
runs-on: ubuntu-latest
|
||||
steps:
|
||||
- uses: Smaug123/all-required-checks-complete-action@05b40a8c47ef0b175ea326e9abb09802cb67b44e
|
||||
- uses: Smaug123/all-required-checks-complete-action@d0ef051668d922e3591cc7c97156702946437f8d
|
||||
with:
|
||||
needs-context: ${{ toJSON(needs) }}
|
||||
|
||||
@@ -285,26 +285,17 @@ jobs:
|
||||
with:
|
||||
name: nuget-package-attribute
|
||||
path: packed
|
||||
- name: Identify `dotnet`
|
||||
id: dotnet-identify
|
||||
run: nix develop --command bash -c 'echo "dotnet=$(which dotnet)" >> $GITHUB_OUTPUT'
|
||||
- name: Publish to NuGet
|
||||
id: publish-success
|
||||
env:
|
||||
NUGET_API_KEY: ${{ secrets.NUGET_API_KEY }}
|
||||
run: 'nix develop --command bash ./.github/workflows/nuget-push.sh "packed/WoofWare.Myriad.Plugins.Attributes.*.nupkg"'
|
||||
- name: Wait for availability
|
||||
if: steps.publish-success.outputs.result == 'published'
|
||||
env:
|
||||
PACKAGE_VERSION: ${{ steps.publish-success.outputs.version }}
|
||||
run: 'echo "$PACKAGE_VERSION" && while ! curl -L --fail -o from-nuget.nupkg "https://www.nuget.org/api/v2/package/WoofWare.Myriad.Plugins.Attributes/$PACKAGE_VERSION" ; do sleep 10; done'
|
||||
# Astonishingly, NuGet.org considers it to be "more secure" to tamper with my package after upload (https://devblogs.microsoft.com/nuget/introducing-repository-signatures/).
|
||||
# So we have to *re-attest* it after it's uploaded. Mind-blowing.
|
||||
- name: Assert package contents
|
||||
if: steps.publish-success.outputs.result == 'published'
|
||||
run: 'bash ./.github/workflows/assert-contents.sh'
|
||||
- name: Attest Build Provenance
|
||||
if: steps.publish-success.outputs.result == 'published'
|
||||
uses: actions/attest-build-provenance@310b0a4a3b0b78ef57ecda988ee04b132db73ef8 # v1.4.1
|
||||
uses: Smaug123/publish-nuget-action@76df889166633c2dc613560c092882aabe260df0
|
||||
with:
|
||||
subject-path: "from-nuget.nupkg"
|
||||
package-name: WoofWare.Myriad.Plugins.Attributes
|
||||
nuget-key: ${{ secrets.NUGET_API_KEY }}
|
||||
nupkg-dir: packed/
|
||||
dotnet: ${{ steps.dotnet-identify.outputs.dotnet }}
|
||||
|
||||
nuget-publish-plugin:
|
||||
runs-on: ubuntu-latest
|
||||
@@ -327,26 +318,17 @@ jobs:
|
||||
with:
|
||||
name: nuget-package-plugin
|
||||
path: packed
|
||||
- name: Identify `dotnet`
|
||||
id: dotnet-identify
|
||||
run: nix develop --command bash -c 'echo "dotnet=$(which dotnet)" >> $GITHUB_OUTPUT'
|
||||
- name: Publish to NuGet
|
||||
id: publish-success
|
||||
env:
|
||||
NUGET_API_KEY: ${{ secrets.NUGET_API_KEY }}
|
||||
run: 'nix develop --command bash ./.github/workflows/nuget-push.sh "packed/WoofWare.Myriad.Plugins.*.nupkg"'
|
||||
- name: Wait for availability
|
||||
if: steps.publish-success.outputs.result == 'published'
|
||||
env:
|
||||
PACKAGE_VERSION: ${{ steps.publish-success.outputs.version }}
|
||||
run: 'echo "$PACKAGE_VERSION" && while ! curl -L --fail -o from-nuget.nupkg "https://www.nuget.org/api/v2/package/WoofWare.Myriad.Plugins/$PACKAGE_VERSION" ; do sleep 10; done'
|
||||
# Astonishingly, NuGet.org considers it to be "more secure" to tamper with my package after upload (https://devblogs.microsoft.com/nuget/introducing-repository-signatures/).
|
||||
# So we have to *re-attest* it after it's uploaded. Mind-blowing.
|
||||
- name: Assert package contents
|
||||
if: steps.publish-success.outputs.result == 'published'
|
||||
run: 'bash ./.github/workflows/assert-contents.sh'
|
||||
- name: Attest Build Provenance
|
||||
if: steps.publish-success.outputs.result == 'published'
|
||||
uses: actions/attest-build-provenance@310b0a4a3b0b78ef57ecda988ee04b132db73ef8 # v1.4.1
|
||||
uses: Smaug123/publish-nuget-action@76df889166633c2dc613560c092882aabe260df0
|
||||
with:
|
||||
subject-path: "from-nuget.nupkg"
|
||||
package-name: WoofWare.Myriad.Plugins
|
||||
nuget-key: ${{ secrets.NUGET_API_KEY }}
|
||||
nupkg-dir: packed/
|
||||
dotnet: ${{ steps.dotnet-identify.outputs.dotnet }}
|
||||
|
||||
github-release-plugin:
|
||||
runs-on: ubuntu-latest
|
||||
|
24
.github/workflows/nuget-push.sh
vendored
24
.github/workflows/nuget-push.sh
vendored
@@ -1,24 +0,0 @@
|
||||
#!/bin/bash
|
||||
|
||||
SOURCE_NUPKG=$(find . -type f -name '*.nupkg')
|
||||
|
||||
PACKAGE_VERSION=$(basename "$SOURCE_NUPKG" | rev | cut -d '.' -f 2-4 | rev)
|
||||
|
||||
echo "version=$PACKAGE_VERSION" >> "$GITHUB_OUTPUT"
|
||||
|
||||
tmp=$(mktemp)
|
||||
|
||||
if ! dotnet nuget push "$SOURCE_NUPKG" --api-key "$NUGET_API_KEY" --source https://api.nuget.org/v3/index.json > "$tmp" ; then
|
||||
cat "$tmp"
|
||||
if grep 'already exists and cannot be modified' "$tmp" ; then
|
||||
echo "result=skipped" >> "$GITHUB_OUTPUT"
|
||||
exit 0
|
||||
else
|
||||
echo "Unexpected failure to upload"
|
||||
exit 1
|
||||
fi
|
||||
fi
|
||||
|
||||
cat "$tmp"
|
||||
|
||||
echo "result=published" >> "$GITHUB_OUTPUT"
|
95
ConsumePlugin/Args.fs
Normal file
95
ConsumePlugin/Args.fs
Normal file
@@ -0,0 +1,95 @@
|
||||
namespace ConsumePlugin
|
||||
|
||||
open System
|
||||
open System.IO
|
||||
open WoofWare.Myriad.Plugins
|
||||
|
||||
[<ArgParser>]
|
||||
type BasicNoPositionals =
|
||||
{
|
||||
Foo : int
|
||||
Bar : string
|
||||
Baz : bool
|
||||
Rest : int list
|
||||
}
|
||||
|
||||
[<ArgParser>]
|
||||
type Basic =
|
||||
{
|
||||
[<ArgumentHelpText "This is a foo!">]
|
||||
Foo : int
|
||||
Bar : string
|
||||
Baz : bool
|
||||
[<ArgumentHelpText "Here's where the rest of the args go">]
|
||||
[<PositionalArgs>]
|
||||
Rest : string list
|
||||
}
|
||||
|
||||
[<ArgParser>]
|
||||
type BasicWithIntPositionals =
|
||||
{
|
||||
Foo : int
|
||||
Bar : string
|
||||
Baz : bool
|
||||
[<PositionalArgs>]
|
||||
Rest : int list
|
||||
}
|
||||
|
||||
[<ArgParser>]
|
||||
type LoadsOfTypes =
|
||||
{
|
||||
Foo : int
|
||||
Bar : string
|
||||
Baz : bool
|
||||
SomeFile : FileInfo
|
||||
SomeDirectory : DirectoryInfo
|
||||
SomeList : DirectoryInfo list
|
||||
OptionalThingWithNoDefault : int option
|
||||
[<PositionalArgs>]
|
||||
Positionals : int list
|
||||
[<ArgumentDefaultFunction>]
|
||||
OptionalThing : Choice<bool, bool>
|
||||
[<ArgumentDefaultFunction>]
|
||||
AnotherOptionalThing : Choice<int, int>
|
||||
[<ArgumentDefaultEnvironmentVariable "CONSUMEPLUGIN_THINGS">]
|
||||
YetAnotherOptionalThing : Choice<string, string>
|
||||
}
|
||||
|
||||
static member DefaultOptionalThing () = true
|
||||
|
||||
static member DefaultAnotherOptionalThing () = 3
|
||||
|
||||
[<ArgParser>]
|
||||
type LoadsOfTypesNoPositionals =
|
||||
{
|
||||
Foo : int
|
||||
Bar : string
|
||||
Baz : bool
|
||||
SomeFile : FileInfo
|
||||
SomeDirectory : DirectoryInfo
|
||||
SomeList : DirectoryInfo list
|
||||
OptionalThingWithNoDefault : int option
|
||||
[<ArgumentDefaultFunction>]
|
||||
OptionalThing : Choice<bool, bool>
|
||||
[<ArgumentDefaultFunction>]
|
||||
AnotherOptionalThing : Choice<int, int>
|
||||
[<ArgumentDefaultEnvironmentVariable "CONSUMEPLUGIN_THINGS">]
|
||||
YetAnotherOptionalThing : Choice<string, string>
|
||||
}
|
||||
|
||||
static member DefaultOptionalThing () = false
|
||||
|
||||
static member DefaultAnotherOptionalThing () = 3
|
||||
|
||||
[<ArgParser true>]
|
||||
type DatesAndTimes =
|
||||
{
|
||||
Plain : TimeSpan
|
||||
[<InvariantCulture>]
|
||||
Invariant : TimeSpan
|
||||
[<ParseExact @"hh\:mm\:ss">]
|
||||
[<ArgumentHelpText "An exact time please">]
|
||||
Exact : TimeSpan
|
||||
[<InvariantCulture ; ParseExact @"hh\:mm\:ss">]
|
||||
InvariantExact : TimeSpan
|
||||
}
|
@@ -3,6 +3,7 @@
|
||||
<PropertyGroup>
|
||||
<TargetFramework>net8.0</TargetFramework>
|
||||
<IsPackable>false</IsPackable>
|
||||
<OtherFlags>--reflectionfree $(OtherFlags)</OtherFlags>
|
||||
</PropertyGroup>
|
||||
<ItemGroup>
|
||||
<MyriadSdkGenerator Include="$(MSBuildThisFileDirectory)..\WoofWare.Myriad.Plugins\bin\$(Configuration)\net6.0\WoofWare.Myriad.Plugins.dll"/>
|
||||
@@ -51,14 +52,17 @@
|
||||
<Compile Include="ListCata.fs">
|
||||
<MyriadFile>List.fs</MyriadFile>
|
||||
</Compile>
|
||||
<Compile Include="Args.fs" />
|
||||
<Compile Include="GeneratedArgs.fs">
|
||||
<MyriadFile>Args.fs</MyriadFile>
|
||||
</Compile>
|
||||
</ItemGroup>
|
||||
|
||||
<ItemGroup>
|
||||
<PackageReference Include="RestEase" Version="1.6.4"/>
|
||||
<ProjectReference Include="..\WoofWare.Myriad.Plugins.Attributes\WoofWare.Myriad.Plugins.Attributes.fsproj" />
|
||||
<ProjectReference Include="..\WoofWare.Myriad.Plugins\WoofWare.Myriad.Plugins.fsproj"/>
|
||||
<PackageReference Include="Myriad.Sdk" Version="0.8.3"/>
|
||||
<PackageReference Include="Myriad.Core" Version="0.8.3"/>
|
||||
<ProjectReference Include="..\WoofWare.Myriad.Plugins\WoofWare.Myriad.Plugins.fsproj" PrivateAssets="all" />
|
||||
<PackageReference Include="Myriad.Sdk" Version="0.8.3" PrivateAssets="all" />
|
||||
</ItemGroup>
|
||||
|
||||
</Project>
|
||||
|
@@ -30,6 +30,12 @@ type ChocolateType =
|
||||
| Milk
|
||||
| SeventyPercent
|
||||
|
||||
override this.ToString () =
|
||||
match this with
|
||||
| ChocolateType.Dark -> "Dark"
|
||||
| ChocolateType.Milk -> "Milk"
|
||||
| ChocolateType.SeventyPercent -> "SeventyPercent"
|
||||
|
||||
type Chocolate =
|
||||
{
|
||||
chocType : ChocolateType
|
||||
@@ -43,6 +49,12 @@ type WrappingPaperStyle =
|
||||
| HappyHolidays
|
||||
| SolidColor
|
||||
|
||||
override this.ToString () =
|
||||
match this with
|
||||
| WrappingPaperStyle.HappyBirthday -> "HappyBirthday"
|
||||
| WrappingPaperStyle.HappyHolidays -> "HappyHolidays"
|
||||
| WrappingPaperStyle.SolidColor -> "SolidColor"
|
||||
|
||||
[<CreateCatamorphism "GiftCata">]
|
||||
type Gift =
|
||||
| Book of Book
|
||||
|
1579
ConsumePlugin/GeneratedArgs.fs
Normal file
1579
ConsumePlugin/GeneratedArgs.fs
Normal file
File diff suppressed because it is too large
Load Diff
@@ -1,9 +1,5 @@
|
||||
namespace ConsumePlugin
|
||||
|
||||
type ParseState =
|
||||
| AwaitingKey
|
||||
| AwaitingValue of string
|
||||
|
||||
/// My whatnot
|
||||
[<WoofWare.Myriad.Plugins.RemoveOptions>]
|
||||
type RecordType =
|
||||
|
68
README.md
68
README.md
@@ -14,6 +14,7 @@ Currently implemented:
|
||||
* `JsonSerialize` (to stamp out `toJsonNode : 'T -> JsonNode` methods).
|
||||
* `HttpClient` (to stamp out a [RestEase](https://github.com/canton7/RestEase)-style HTTP client).
|
||||
* `GenerateMock` (to stamp out a record type corresponding to an interface, like a compile-time [Foq](https://github.com/fsprojects/Foq)).
|
||||
* `ArgParser` (to stamp out a basic argument parser)
|
||||
* `CreateCatamorphism` (to stamp out a non-stack-overflowing [catamorphism](https://fsharpforfunandprofit.com/posts/recursive-types-and-folds/) for a discriminated union).
|
||||
* `RemoveOptions` (to strip `option` modifiers from a type) - this one is particularly half-baked!
|
||||
|
||||
@@ -150,6 +151,73 @@ The same limitations generally apply to `JsonSerialize` as do to `JsonParse`.
|
||||
|
||||
For an example of using both `JsonParse` and `JsonSerialize` together with complex types, see [the type definitions](./ConsumePlugin/SerializationAndDeserialization.fs) and [tests](./WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs).
|
||||
|
||||
## `ArgParser`
|
||||
|
||||
Takes a record like this:
|
||||
|
||||
```fsharp
|
||||
[<ArgParser>]
|
||||
type Foo =
|
||||
{
|
||||
[<ArgumentHelpText "Enable the frobnicator">]
|
||||
SomeFlag : bool
|
||||
A : int option
|
||||
[<ArgumentDefaultFunction>]
|
||||
B : Choice<int, int>
|
||||
[<ArgumentDefaultEnvironmentVariable "MY_ENV_VAR">]
|
||||
BWithEnv : Choice<int, int>
|
||||
C : float list
|
||||
// optionally:
|
||||
[<PositionalArgs>]
|
||||
Rest : string list // or e.g. `int list` if you want them parsed into a type too
|
||||
}
|
||||
static member DefaultB () = 4
|
||||
```
|
||||
|
||||
and stamps out a basic `parse` method of this signature:
|
||||
|
||||
```fsharp
|
||||
[<RequireQualifiedAccess>]
|
||||
module Foo =
|
||||
// in case you want to test it
|
||||
let parse' (getEnvVar : string -> string) (args : string list) : Foo = ...
|
||||
// the one we expect you actually want to use
|
||||
let parse (args : string list) : Foo = ...
|
||||
```
|
||||
|
||||
Default arguments are handled as `Choice<'a, 'a>`:
|
||||
you get a `Choice1Of2` if the user provided the input, or a `Choice2Of2` if the parser filled in your specified default value.
|
||||
|
||||
You can control `TimeSpan` and friends with the `[<InvariantCulture>]` and `[<ParseExact @"hh\:mm\:ss">]` attributes.
|
||||
|
||||
You can generate extension methods for the type, instead of a module with the type's name, using `[<ArgParser (* isExtensionMethod = *) true>]`.
|
||||
|
||||
If `--help` appears in a position where the parser is expecting a key (e.g. in the first position, or after a `--foo=bar`), the parser fails with help text.
|
||||
The parser also makes a limited effort to supply help text when encountering an invalid parse.
|
||||
|
||||
### What's the point?
|
||||
|
||||
I got fed up of waiting for us to find time to rewrite the in-house one at work.
|
||||
That one has a bunch of nice compositional properties, which my version lacks:
|
||||
I can basically only deal with primitive types, and e.g. you can't stack records and discriminated unions inside each other.
|
||||
|
||||
But I *do* want an F#-native argument parser suitable for AOT-compilation.
|
||||
|
||||
Why not [Argu](https://fsprojects.github.io/Argu/)?
|
||||
Answer: I got annoyed with having to construct my records by hand even after Argu returned and said the parsing was all "done".
|
||||
|
||||
### Limitations
|
||||
|
||||
This is very bare-bones, but do raise GitHub issues if you like (or if you find cases where the parser does the wrong thing).
|
||||
|
||||
* Help is signalled by throwing an exception, so you'll get an unsightly stack trace and a nonzero exit code.
|
||||
* Help doesn't take into account any arguments the user has entered. Ideally you'd get contextual information like an identification of which args the user has supplied at the point where the parse failed or help was requested.
|
||||
* I don't handle very many types, and in particular a real arg parser would handle DUs and records with nesting.
|
||||
* I don't try very hard to find a valid parse. It may well be possible to find a case where I fail to parse despite there existing a valid parse.
|
||||
* There's no subcommand support (you'll have to do that yourself).
|
||||
|
||||
It should work fine if you just want to compose a few primitive types, though.
|
||||
|
||||
## `RemoveOptions`
|
||||
|
||||
Takes a record like this:
|
||||
|
63
WoofWare.Myriad.Plugins.Attributes/ArgParserAttributes.fs
Normal file
63
WoofWare.Myriad.Plugins.Attributes/ArgParserAttributes.fs
Normal file
@@ -0,0 +1,63 @@
|
||||
namespace WoofWare.Myriad.Plugins
|
||||
|
||||
open System
|
||||
|
||||
/// Attribute indicating a record type to which the "build arg parser" Myriad
|
||||
/// generator should apply during build.
|
||||
///
|
||||
/// If you supply isExtensionMethod = true, you will get extension methods.
|
||||
/// These can only be consumed from F#, but the benefit is that they don't use up the module name
|
||||
/// (since by default we create a module called "{TypeName}").
|
||||
type ArgParserAttribute (isExtensionMethod : bool) =
|
||||
inherit Attribute ()
|
||||
|
||||
/// The default value of `isExtensionMethod`, the optional argument to the ArgParserAttribute constructor.
|
||||
static member DefaultIsExtensionMethod = false
|
||||
|
||||
/// Shorthand for the "isExtensionMethod = false" constructor; see documentation there for details.
|
||||
new () = ArgParserAttribute ArgParserAttribute.DefaultIsExtensionMethod
|
||||
|
||||
/// Attribute indicating that this field shall accumulate all unmatched args,
|
||||
/// as well as any that appear after a bare `--`.
|
||||
type PositionalArgsAttribute () =
|
||||
inherit Attribute ()
|
||||
|
||||
/// Attribute indicating that this field shall have a default value derived
|
||||
/// from calling an appropriately named static method on the type.
|
||||
///
|
||||
/// This attribute can only be placed on fields of type `Choice<_, _>` where both type parameters
|
||||
/// are the same.
|
||||
/// After a successful parse, the value is Choice1Of2 if the user supplied an input,
|
||||
/// or Choice2Of2 if the input was obtained by calling the default function.
|
||||
///
|
||||
/// The static method we call for field `FieldName : 'a` is `DefaultFieldName : unit -> 'a`.
|
||||
type ArgumentDefaultFunctionAttribute () =
|
||||
inherit Attribute ()
|
||||
|
||||
/// Attribute indicating that this field shall have a default value derived
|
||||
/// from an environment variable (whose name you give in the attribute constructor).
|
||||
///
|
||||
/// This attribute can only be placed on fields of type `Choice<_, _>` where both type parameters
|
||||
/// are the same.
|
||||
/// After a successful parse, the value is Choice1Of2 if the user supplied an input,
|
||||
/// or Choice2Of2 if the input was obtained by pulling a value from `Environment.GetEnvironmentVariable`.
|
||||
type ArgumentDefaultEnvironmentVariableAttribute (envVar : string) =
|
||||
inherit Attribute ()
|
||||
|
||||
/// Attribute indicating that this field shall have the given help text, when `--help` is invoked
|
||||
/// or when a parse error causes us to print help text.
|
||||
type ArgumentHelpTextAttribute (helpText : string) =
|
||||
inherit Attribute ()
|
||||
|
||||
/// Attribute indicating that this field should be parsed with a ParseExact method on its type.
|
||||
/// For example, on a TimeSpan field, with [<ArgumentParseExact @"hh\:mm\:ss">], we will call
|
||||
/// `TimeSpan.ParseExact (s, @"hh\:mm\:ss", CultureInfo.CurrentCulture).
|
||||
type ParseExactAttribute (format : string) =
|
||||
inherit Attribute ()
|
||||
|
||||
/// Attribute indicating that this field should be parsed in the invariant culture, rather than the
|
||||
/// default current culture.
|
||||
/// For example, on a TimeSpan field, with [<InvariantCulture>] and [<ArgumentParseExact @"hh\:mm\:ss">], we will call
|
||||
/// `TimeSpan.ParseExact (s, @"hh\:mm\:ss", CultureInfo.InvariantCulture).
|
||||
type InvariantCultureAttribute () =
|
||||
inherit Attribute ()
|
@@ -1,3 +1,14 @@
|
||||
WoofWare.Myriad.Plugins.ArgParserAttribute inherit System.Attribute
|
||||
WoofWare.Myriad.Plugins.ArgParserAttribute..ctor [constructor]: bool
|
||||
WoofWare.Myriad.Plugins.ArgParserAttribute..ctor [constructor]: unit
|
||||
WoofWare.Myriad.Plugins.ArgParserAttribute.DefaultIsExtensionMethod [static property]: [read-only] bool
|
||||
WoofWare.Myriad.Plugins.ArgParserAttribute.get_DefaultIsExtensionMethod [static method]: unit -> bool
|
||||
WoofWare.Myriad.Plugins.ArgumentDefaultEnvironmentVariableAttribute inherit System.Attribute
|
||||
WoofWare.Myriad.Plugins.ArgumentDefaultEnvironmentVariableAttribute..ctor [constructor]: string
|
||||
WoofWare.Myriad.Plugins.ArgumentDefaultFunctionAttribute inherit System.Attribute
|
||||
WoofWare.Myriad.Plugins.ArgumentDefaultFunctionAttribute..ctor [constructor]: unit
|
||||
WoofWare.Myriad.Plugins.ArgumentHelpTextAttribute inherit System.Attribute
|
||||
WoofWare.Myriad.Plugins.ArgumentHelpTextAttribute..ctor [constructor]: string
|
||||
WoofWare.Myriad.Plugins.CreateCatamorphismAttribute inherit System.Attribute
|
||||
WoofWare.Myriad.Plugins.CreateCatamorphismAttribute..ctor [constructor]: string
|
||||
WoofWare.Myriad.Plugins.GenerateMockAttribute inherit System.Attribute
|
||||
@@ -10,6 +21,8 @@ WoofWare.Myriad.Plugins.HttpClientAttribute..ctor [constructor]: bool
|
||||
WoofWare.Myriad.Plugins.HttpClientAttribute..ctor [constructor]: unit
|
||||
WoofWare.Myriad.Plugins.HttpClientAttribute.DefaultIsExtensionMethod [static property]: [read-only] bool
|
||||
WoofWare.Myriad.Plugins.HttpClientAttribute.get_DefaultIsExtensionMethod [static method]: unit -> bool
|
||||
WoofWare.Myriad.Plugins.InvariantCultureAttribute inherit System.Attribute
|
||||
WoofWare.Myriad.Plugins.InvariantCultureAttribute..ctor [constructor]: unit
|
||||
WoofWare.Myriad.Plugins.JsonParseAttribute inherit System.Attribute
|
||||
WoofWare.Myriad.Plugins.JsonParseAttribute..ctor [constructor]: bool
|
||||
WoofWare.Myriad.Plugins.JsonParseAttribute..ctor [constructor]: unit
|
||||
@@ -20,6 +33,10 @@ WoofWare.Myriad.Plugins.JsonSerializeAttribute..ctor [constructor]: bool
|
||||
WoofWare.Myriad.Plugins.JsonSerializeAttribute..ctor [constructor]: unit
|
||||
WoofWare.Myriad.Plugins.JsonSerializeAttribute.DefaultIsExtensionMethod [static property]: [read-only] bool
|
||||
WoofWare.Myriad.Plugins.JsonSerializeAttribute.get_DefaultIsExtensionMethod [static method]: unit -> bool
|
||||
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]: unit
|
||||
WoofWare.Myriad.Plugins.RemoveOptionsAttribute inherit System.Attribute
|
||||
WoofWare.Myriad.Plugins.RemoveOptionsAttribute..ctor [constructor]: unit
|
||||
WoofWare.Myriad.Plugins.RestEase inherit obj
|
||||
|
@@ -12,7 +12,7 @@
|
||||
</ItemGroup>
|
||||
|
||||
<ItemGroup>
|
||||
<PackageReference Include="ApiSurface" Version="4.0.43" />
|
||||
<PackageReference Include="ApiSurface" Version="4.0.44" />
|
||||
<PackageReference Include="Microsoft.NET.Test.Sdk" Version="17.10.0"/>
|
||||
<PackageReference Include="NUnit" Version="4.1.0"/>
|
||||
<PackageReference Include="NUnit3TestAdapter" Version="4.6.0"/>
|
||||
|
@@ -19,6 +19,7 @@
|
||||
|
||||
<ItemGroup>
|
||||
<Compile Include="Attributes.fs"/>
|
||||
<Compile Include="ArgParserAttributes.fs" />
|
||||
<Compile Include="RestEase.fs" />
|
||||
<EmbeddedResource Include="version.json"/>
|
||||
<EmbeddedResource Include="SurfaceBaseline.txt"/>
|
||||
|
@@ -1,5 +1,5 @@
|
||||
{
|
||||
"version": "3.1",
|
||||
"version": "3.2",
|
||||
"publicReleaseRefSpec": [
|
||||
"^refs/heads/main$"
|
||||
],
|
||||
|
343
WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParser.fs
Normal file
343
WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParser.fs
Normal file
@@ -0,0 +1,343 @@
|
||||
namespace WoofWare.Myriad.Plugins.Test
|
||||
|
||||
open System
|
||||
open System.Threading
|
||||
open NUnit.Framework
|
||||
open FsUnitTyped
|
||||
open ConsumePlugin
|
||||
open FsCheck
|
||||
|
||||
[<TestFixture>]
|
||||
module TestArgParser =
|
||||
|
||||
[<TestCase true>]
|
||||
[<TestCase false>]
|
||||
let ``Positionals get parsed: they don't have to be strings`` (sep : bool) =
|
||||
let getEnvVar (_ : string) = failwith "should not call"
|
||||
|
||||
let property
|
||||
(fooSep : bool)
|
||||
(barSep : bool)
|
||||
(bazSep : bool)
|
||||
(pos0 : int list)
|
||||
(pos1 : int list)
|
||||
(pos2 : int list)
|
||||
(pos3 : int list)
|
||||
(pos4 : int list)
|
||||
=
|
||||
let args =
|
||||
[
|
||||
yield! pos0 |> List.map string<int>
|
||||
if fooSep then
|
||||
yield "--foo=3"
|
||||
else
|
||||
yield "--foo"
|
||||
yield "3"
|
||||
yield! pos1 |> List.map string<int>
|
||||
if barSep then
|
||||
yield "--bar=4"
|
||||
else
|
||||
yield "--bar"
|
||||
yield "4"
|
||||
yield! pos2 |> List.map string<int>
|
||||
if bazSep then
|
||||
yield "--baz=true"
|
||||
else
|
||||
yield "--baz"
|
||||
yield "true"
|
||||
yield! pos3 |> List.map string<int>
|
||||
if sep then
|
||||
yield "--"
|
||||
yield! pos4 |> List.map string<int>
|
||||
]
|
||||
|
||||
BasicWithIntPositionals.parse' getEnvVar args
|
||||
|> shouldEqual
|
||||
{
|
||||
Foo = 3
|
||||
Bar = "4"
|
||||
Baz = true
|
||||
Rest = pos0 @ pos1 @ pos2 @ pos3 @ pos4
|
||||
}
|
||||
|
||||
Check.QuickThrowOnFailure property
|
||||
|
||||
[<Test>]
|
||||
let ``Arg-like thing appearing before double dash`` () =
|
||||
let envCalls = ref 0
|
||||
|
||||
let getEnvVar (_ : string) =
|
||||
Interlocked.Increment envCalls |> ignore<int>
|
||||
""
|
||||
|
||||
let args = [ "--foo=3" ; "--non-existent" ; "--bar=4" ; "--baz=true" ]
|
||||
|
||||
let exc =
|
||||
Assert.Throws<exn> (fun () -> Basic.parse' getEnvVar args |> ignore<Basic>)
|
||||
|
||||
envCalls.Value |> shouldEqual 0
|
||||
|
||||
exc.Message
|
||||
|> shouldEqual
|
||||
"""Unable to process supplied arg --non-existent. Help text follows.
|
||||
--foo int32 : This is a foo!
|
||||
--bar string
|
||||
--baz bool
|
||||
--rest string (positional args) (can be repeated) : Here's where the rest of the args go"""
|
||||
|
||||
[<Test>]
|
||||
let ``Can supply positional args with key`` () =
|
||||
let envCalls = ref 0
|
||||
|
||||
let getEnvVar (_ : string) =
|
||||
Interlocked.Increment envCalls |> ignore<int>
|
||||
""
|
||||
|
||||
let property (args : (int * bool) list) (afterDoubleDash : int list option) =
|
||||
let flatArgs =
|
||||
args
|
||||
|> List.collect (fun (value, sep) ->
|
||||
if sep then
|
||||
[ $"--rest=%i{value}" ]
|
||||
else
|
||||
[ "--rest" ; string<int> value ]
|
||||
)
|
||||
|> fun l -> l @ [ "--foo=3" ; "--bar=4" ; "--baz=true" ]
|
||||
|
||||
let flatArgs, expected =
|
||||
match afterDoubleDash with
|
||||
| None -> flatArgs, List.map fst args
|
||||
| Some rest -> flatArgs @ [ "--" ] @ (List.map string<int> rest), List.map fst args @ rest
|
||||
|
||||
BasicWithIntPositionals.parse' getEnvVar flatArgs
|
||||
|> shouldEqual
|
||||
{
|
||||
Foo = 3
|
||||
Bar = "4"
|
||||
Baz = true
|
||||
Rest = expected
|
||||
}
|
||||
|
||||
Check.QuickThrowOnFailure property
|
||||
envCalls.Value |> shouldEqual 0
|
||||
|
||||
[<Test>]
|
||||
let ``Consume multiple occurrences of required arg`` () =
|
||||
let envCalls = ref 0
|
||||
|
||||
let getEnvVar (_ : string) =
|
||||
Interlocked.Increment envCalls |> ignore<int>
|
||||
""
|
||||
|
||||
let args = [ "--foo=3" ; "--rest" ; "7" ; "--bar=4" ; "--baz=true" ; "--rest=8" ]
|
||||
|
||||
let result = BasicNoPositionals.parse' getEnvVar args
|
||||
|
||||
envCalls.Value |> shouldEqual 0
|
||||
|
||||
result
|
||||
|> shouldEqual
|
||||
{
|
||||
Foo = 3
|
||||
Bar = "4"
|
||||
Baz = true
|
||||
Rest = [ 7 ; 8 ]
|
||||
}
|
||||
|
||||
[<Test>]
|
||||
let ``Gracefully handle invalid multiple occurrences of required arg`` () =
|
||||
let envCalls = ref 0
|
||||
|
||||
let getEnvVar (_ : string) =
|
||||
Interlocked.Increment envCalls |> ignore<int>
|
||||
""
|
||||
|
||||
let args = [ "--foo=3" ; "--foo" ; "9" ; "--bar=4" ; "--baz=true" ; "--baz=false" ]
|
||||
|
||||
let exc =
|
||||
Assert.Throws<exn> (fun () -> Basic.parse' getEnvVar args |> ignore<Basic>)
|
||||
|
||||
envCalls.Value |> shouldEqual 0
|
||||
|
||||
exc.Message
|
||||
|> shouldEqual
|
||||
"""Errors during parse!
|
||||
Argument '--foo' was supplied multiple times: 3 and 9
|
||||
Argument '--baz' was supplied multiple times: True and false"""
|
||||
|
||||
[<Test>]
|
||||
let ``Args appearing after double dash are positional`` () =
|
||||
let envCalls = ref 0
|
||||
|
||||
let getEnvVar (_ : string) =
|
||||
Interlocked.Increment envCalls |> ignore<int>
|
||||
""
|
||||
|
||||
let args = [ "--" ; "--foo=3" ; "--bar=4" ; "--baz=true" ]
|
||||
|
||||
let exc =
|
||||
Assert.Throws<exn> (fun () -> Basic.parse' getEnvVar args |> ignore<Basic>)
|
||||
|
||||
exc.Message
|
||||
|> shouldEqual
|
||||
"""Errors during parse!
|
||||
Required argument '--foo' received no value
|
||||
Required argument '--bar' received no value
|
||||
Required argument '--baz' received no value"""
|
||||
|
||||
envCalls.Value |> shouldEqual 0
|
||||
|
||||
[<Test>]
|
||||
let ``Help text`` () =
|
||||
let getEnvVar (s : string) =
|
||||
s |> shouldEqual "CONSUMEPLUGIN_THINGS"
|
||||
"hi!"
|
||||
|
||||
let exc =
|
||||
Assert.Throws<exn> (fun () -> Basic.parse' getEnvVar [ "--help" ] |> ignore<Basic>)
|
||||
|
||||
exc.Message
|
||||
|> shouldEqual
|
||||
"""Help text requested.
|
||||
--foo int32 : This is a foo!
|
||||
--bar string
|
||||
--baz bool
|
||||
--rest string (positional args) (can be repeated) : Here's where the rest of the args go"""
|
||||
|
||||
[<Test>]
|
||||
let ``Help text, with default values`` () =
|
||||
let envVars = ref 0
|
||||
|
||||
let getEnvVar (_ : string) =
|
||||
Interlocked.Increment envVars |> ignore<int>
|
||||
""
|
||||
|
||||
let exc =
|
||||
Assert.Throws<exn> (fun () -> LoadsOfTypes.parse' getEnvVar [ "--help" ] |> ignore<LoadsOfTypes>)
|
||||
|
||||
exc.Message
|
||||
|> shouldEqual
|
||||
"""Help text requested.
|
||||
--foo int32
|
||||
--bar string
|
||||
--baz bool
|
||||
--some-file FileInfo
|
||||
--some-directory DirectoryInfo
|
||||
--some-list DirectoryInfo (can be repeated)
|
||||
--optional-thing-with-no-default int32 (optional)
|
||||
--optional-thing bool (default value: True)
|
||||
--another-optional-thing int32 (default value: 3)
|
||||
--yet-another-optional-thing string (default value populated from env var CONSUMEPLUGIN_THINGS)
|
||||
--positionals int32 (positional args) (can be repeated)"""
|
||||
|
||||
envVars.Value |> shouldEqual 0
|
||||
|
||||
[<Test>]
|
||||
let ``Default values`` () =
|
||||
let getEnvVar (s : string) =
|
||||
s |> shouldEqual "CONSUMEPLUGIN_THINGS"
|
||||
"hi!"
|
||||
|
||||
let args =
|
||||
[
|
||||
"--foo"
|
||||
"3"
|
||||
"--bar=some string"
|
||||
"--baz"
|
||||
"--some-file=/path/to/file"
|
||||
"--some-directory"
|
||||
"/a/dir"
|
||||
"--another-optional-thing"
|
||||
"3000"
|
||||
]
|
||||
|
||||
let result = LoadsOfTypes.parse' getEnvVar args
|
||||
|
||||
result.OptionalThing |> shouldEqual (Choice2Of2 true)
|
||||
result.OptionalThingWithNoDefault |> shouldEqual None
|
||||
result.AnotherOptionalThing |> shouldEqual (Choice1Of2 3000)
|
||||
result.YetAnotherOptionalThing |> shouldEqual (Choice2Of2 "hi!")
|
||||
|
||||
[<Test>]
|
||||
let ``ParseExact and help`` () =
|
||||
let count = ref 0
|
||||
|
||||
let getEnvVar (_ : string) =
|
||||
Interlocked.Increment count |> ignore<int>
|
||||
""
|
||||
|
||||
let exc =
|
||||
Assert.Throws<exn> (fun () -> DatesAndTimes.parse' getEnvVar [ "--help" ] |> ignore<DatesAndTimes>)
|
||||
|
||||
exc.Message
|
||||
|> shouldEqual
|
||||
@"Help text requested.
|
||||
--plain TimeSpan
|
||||
--invariant TimeSpan
|
||||
--exact TimeSpan : An exact time please [Parse format (.NET): hh\:mm\:ss]
|
||||
--invariant-exact TimeSpan : [Parse format (.NET): hh\:mm\:ss]"
|
||||
|
||||
count.Value |> shouldEqual 0
|
||||
|
||||
[<Test>]
|
||||
let rec ``TimeSpans and their attributes`` () =
|
||||
let count = ref 0
|
||||
|
||||
let getEnvVar (_ : string) =
|
||||
Interlocked.Increment count |> ignore<int>
|
||||
""
|
||||
|
||||
let parsed =
|
||||
DatesAndTimes.parse'
|
||||
getEnvVar
|
||||
[
|
||||
"--exact=11:34:00"
|
||||
"--plain=1"
|
||||
"--invariant=23:59"
|
||||
"--invariant-exact=23:59:00"
|
||||
]
|
||||
|
||||
parsed.Plain |> shouldEqual (TimeSpan (1, 0, 0, 0))
|
||||
parsed.Invariant |> shouldEqual (TimeSpan (23, 59, 00))
|
||||
parsed.Exact |> shouldEqual (TimeSpan (11, 34, 00))
|
||||
parsed.InvariantExact |> shouldEqual (TimeSpan (23, 59, 00))
|
||||
|
||||
let exc =
|
||||
Assert.Throws<exn> (fun () ->
|
||||
DatesAndTimes.parse'
|
||||
getEnvVar
|
||||
[
|
||||
"--exact=11:34:00"
|
||||
"--plain=1"
|
||||
"--invariant=23:59"
|
||||
"--invariant-exact=23:59"
|
||||
]
|
||||
|> ignore<DatesAndTimes>
|
||||
)
|
||||
|
||||
exc.Message
|
||||
|> shouldEqual
|
||||
"""Errors during parse!
|
||||
Input string was not in a correct format. (at arg --invariant-exact=23:59)
|
||||
Required argument '--invariant-exact' received no value"""
|
||||
|
||||
let exc =
|
||||
Assert.Throws<exn> (fun () ->
|
||||
DatesAndTimes.parse'
|
||||
getEnvVar
|
||||
[
|
||||
"--exact=11:34"
|
||||
"--plain=1"
|
||||
"--invariant=23:59"
|
||||
"--invariant-exact=23:59:00"
|
||||
]
|
||||
|> ignore<DatesAndTimes>
|
||||
)
|
||||
|
||||
exc.Message
|
||||
|> shouldEqual
|
||||
"""Errors during parse!
|
||||
Input string was not in a correct format. (at arg --exact=11:34)
|
||||
Required argument '--exact' received no value"""
|
||||
|
||||
count.Value |> shouldEqual 0
|
@@ -43,7 +43,7 @@ module TestGift =
|
||||
member _.WithACard g message =
|
||||
$"%s{g} with a card saying '%s{message}'"
|
||||
|
||||
member _.Wrapped g paper = $"%s{g} wrapped in %A{paper} paper"
|
||||
member _.Wrapped g paper = $"%s{g} wrapped in %O{paper} paper"
|
||||
}
|
||||
}
|
||||
|
||||
|
@@ -27,13 +27,14 @@
|
||||
<Compile Include="TestCataGenerator\TestGift.fs" />
|
||||
<Compile Include="TestCataGenerator\TestMyList.fs" />
|
||||
<Compile Include="TestCataGenerator\TestMyList2.fs" />
|
||||
<Compile Include="TestArgParser\TestArgParser.fs" />
|
||||
<Compile Include="TestRemoveOptions.fs"/>
|
||||
<Compile Include="TestSurface.fs"/>
|
||||
<None Include="../.github/workflows/dotnet.yaml" />
|
||||
</ItemGroup>
|
||||
|
||||
<ItemGroup>
|
||||
<PackageReference Include="ApiSurface" Version="4.0.43"/>
|
||||
<PackageReference Include="ApiSurface" Version="4.0.44"/>
|
||||
<PackageReference Include="FsCheck" Version="2.16.6"/>
|
||||
<PackageReference Include="FsUnit" Version="6.0.0"/>
|
||||
<PackageReference Include="Microsoft.NET.Test.Sdk" Version="17.10.0"/>
|
||||
|
1214
WoofWare.Myriad.Plugins/ArgParserGenerator.fs
Normal file
1214
WoofWare.Myriad.Plugins/ArgParserGenerator.fs
Normal file
File diff suppressed because it is too large
Load Diff
@@ -62,13 +62,46 @@ type internal InterfaceType =
|
||||
type internal RecordType =
|
||||
{
|
||||
Name : Ident
|
||||
Fields : SynField seq
|
||||
Fields : SynField list
|
||||
/// Any additional members which are not record fields.
|
||||
Members : SynMemberDefns option
|
||||
XmlDoc : PreXmlDoc option
|
||||
Generics : SynTyparDecls option
|
||||
Accessibility : SynAccess option
|
||||
Attributes : SynAttribute list
|
||||
}
|
||||
|
||||
/// Parse from the AST.
|
||||
static member OfRecord (record : SynTypeDefn) : RecordType =
|
||||
let sci, sdr, smd, smdo =
|
||||
match record with
|
||||
| SynTypeDefn.SynTypeDefn (sci, sdr, smd, smdo, _, _) -> sci, sdr, smd, smdo
|
||||
|
||||
let synAccessOption, recordFields =
|
||||
match sdr with
|
||||
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (sa, fields, _), _) -> sa, fields
|
||||
| _ -> failwith $"expected a record; got: %+A{record}"
|
||||
|
||||
match sci with
|
||||
| SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, access, _) ->
|
||||
if access <> synAccessOption then
|
||||
failwith
|
||||
$"TODO what's happened, two different accessibility modifiers: %O{access} and %O{synAccessOption}"
|
||||
|
||||
match smdo with
|
||||
| Some v -> failwith $"TODO what's happened, got a synMemberDefn of %O{v}"
|
||||
| None -> ()
|
||||
|
||||
{
|
||||
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 = synAccessOption
|
||||
Attributes = attrs |> List.collect (fun l -> l.Attributes)
|
||||
}
|
||||
|
||||
/// Anything that is part of an ADT.
|
||||
/// A record is a product of stuff; this type represents one of those stuffs.
|
||||
type internal AdtNode =
|
||||
@@ -101,10 +134,10 @@ module internal AstHelper =
|
||||
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Enum _, _) -> true
|
||||
| _ -> false
|
||||
|
||||
let instantiateRecord (fields : (RecordFieldName * SynExpr option) list) : SynExpr =
|
||||
let instantiateRecord (fields : (SynLongIdent * SynExpr) list) : SynExpr =
|
||||
let fields =
|
||||
fields
|
||||
|> List.map (fun (rfn, synExpr) -> SynExprRecordField (rfn, Some range0, synExpr, None))
|
||||
|> List.map (fun (rfn, synExpr) -> SynExprRecordField ((rfn, true), Some range0, Some synExpr, None))
|
||||
|
||||
SynExpr.Record (None, None, fields, range0)
|
||||
|
||||
|
@@ -858,7 +858,7 @@ module internal CataGenerator =
|
||||
|
||||
SynExpr.createMatch (SynExpr.createIdent "x") matchCases
|
||||
|> SynMatchClause.create (
|
||||
SynPat.identWithArgs analysis.AssociatedProcessInstruction (SynArgPats.create [ Ident.create "x" ])
|
||||
SynPat.identWithArgs analysis.AssociatedProcessInstruction (SynArgPats.createNamed [ "x" ])
|
||||
)
|
||||
|
||||
/// Create the state-machine matches which deal with receiving the instruction
|
||||
@@ -896,8 +896,8 @@ module internal CataGenerator =
|
||||
|> Seq.mapi (fun i x -> (i, x))
|
||||
|> Seq.choose (fun (i, case) ->
|
||||
match case.Description with
|
||||
| FieldDescription.NonRecursive _ -> case.ArgName |> Some
|
||||
| FieldDescription.ListSelf _ -> case.ArgName |> Some
|
||||
| FieldDescription.NonRecursive _ -> case.ArgName |> SynPat.namedI |> Some
|
||||
| FieldDescription.ListSelf _ -> case.ArgName |> SynPat.namedI |> Some
|
||||
| FieldDescription.Self _ -> None
|
||||
)
|
||||
|> Seq.toList
|
||||
@@ -1100,7 +1100,7 @@ module internal CataGenerator =
|
||||
let moduleName = parentName + "Cata" |> Ident.create
|
||||
|
||||
let modInfo =
|
||||
SynComponentInfo.create (parentName + "Cata" |> Ident.create)
|
||||
SynComponentInfo.create moduleName
|
||||
|> SynComponentInfo.withDocString (
|
||||
PreXmlDoc.Create $" Methods to perform a catamorphism over the type %s{parentName}"
|
||||
)
|
||||
|
@@ -257,11 +257,7 @@ module internal HttpClientGenerator =
|
||||
| Some id -> id
|
||||
|
||||
let urlSeparator =
|
||||
// apparent Myriad bug: `IndexOf '?'` gets formatted as `IndexOf ?` which is clearly wrong
|
||||
let questionMark =
|
||||
SynExpr.CreateConst 63
|
||||
|> SynExpr.applyFunction (SynExpr.createIdent "char")
|
||||
|> SynExpr.paren
|
||||
let questionMark = SynExpr.CreateConst '?'
|
||||
|
||||
let containsQuestion =
|
||||
info.UrlTemplate
|
||||
@@ -425,21 +421,17 @@ module internal HttpClientGenerator =
|
||||
(SynExpr.createIdent' bodyParamName)
|
||||
)
|
||||
Do (
|
||||
SynExpr.LongIdentSet (
|
||||
SynLongIdent.createS' [ "httpMessage" ; "Content" ],
|
||||
SynExpr.createIdent "queryParams",
|
||||
range0
|
||||
)
|
||||
SynExpr.assign
|
||||
(SynLongIdent.createS' [ "httpMessage" ; "Content" ])
|
||||
(SynExpr.createIdent "queryParams")
|
||||
)
|
||||
]
|
||||
| BodyParamMethods.HttpContent ->
|
||||
[
|
||||
Do (
|
||||
SynExpr.LongIdentSet (
|
||||
SynLongIdent.createS' [ "httpMessage" ; "Content" ],
|
||||
SynExpr.createIdent' bodyParamName,
|
||||
range0
|
||||
)
|
||||
SynExpr.assign
|
||||
(SynLongIdent.createS' [ "httpMessage" ; "Content" ])
|
||||
(SynExpr.createIdent' bodyParamName)
|
||||
)
|
||||
]
|
||||
| BodyParamMethods.Serialise ty ->
|
||||
@@ -464,11 +456,9 @@ module internal HttpClientGenerator =
|
||||
))
|
||||
)
|
||||
Do (
|
||||
SynExpr.LongIdentSet (
|
||||
SynLongIdent.createS' [ "httpMessage" ; "Content" ],
|
||||
SynExpr.createIdent "queryParams",
|
||||
range0
|
||||
)
|
||||
SynExpr.assign
|
||||
(SynLongIdent.createS' [ "httpMessage" ; "Content" ])
|
||||
(SynExpr.createIdent "queryParams")
|
||||
)
|
||||
]
|
||||
|
||||
@@ -695,7 +685,7 @@ module internal HttpClientGenerator =
|
||||
let headerInfo =
|
||||
match extractHeaderInformation pi.Attributes with
|
||||
| [ [ x ] ] -> x
|
||||
| [ xs ] ->
|
||||
| [ _ ] ->
|
||||
failwith
|
||||
"Expected exactly one Header parameter on the member, with exactly one arg; got one Header parameter with non-1-many args"
|
||||
| [] ->
|
||||
@@ -843,7 +833,7 @@ module internal HttpClientGenerator =
|
||||
|> SynTypeDefn.create componentInfo
|
||||
|> SynTypeDefn.withMemberDefns [ binding ]
|
||||
|
||||
SynModuleDecl.Types ([ containingType ], range0)
|
||||
SynModuleDecl.createTypes [ containingType ]
|
||||
|
||||
else
|
||||
SynBinding.basic [ Ident.create "make" ] (headerArgs @ [ clientCreationArg ]) interfaceImpl
|
||||
|
@@ -71,13 +71,13 @@ module internal InterfaceMockGenerator =
|
||||
if inherits.Contains KnownInheritance.IDisposable then
|
||||
let unitFun = SynExpr.createThunk (SynExpr.CreateConst ())
|
||||
|
||||
[ (SynLongIdent.createS "Dispose", true), Some unitFun ]
|
||||
[ SynLongIdent.createS "Dispose", unitFun ]
|
||||
else
|
||||
[]
|
||||
|
||||
let nonExtras =
|
||||
fields
|
||||
|> List.map (fun field -> (SynLongIdent.createI (getName field), true), Some (failwithFun field))
|
||||
|> List.map (fun field -> SynLongIdent.createI (getName field), failwithFun field)
|
||||
|
||||
extras @ nonExtras
|
||||
|
||||
@@ -213,6 +213,7 @@ module internal InterfaceMockGenerator =
|
||||
XmlDoc = Some xmlDoc
|
||||
Generics = interfaceType.Generics
|
||||
Accessibility = Some access
|
||||
Attributes = []
|
||||
}
|
||||
|
||||
let typeDecl = AstHelper.defineRecordType record
|
||||
|
@@ -407,9 +407,7 @@ module internal JsonParseGenerator =
|
||||
|
||||
let finalConstruction =
|
||||
fields
|
||||
|> List.mapi (fun i fieldData ->
|
||||
(SynLongIdent.createI fieldData.Ident, true), Some (SynExpr.createIdent $"arg_%i{i}")
|
||||
)
|
||||
|> List.mapi (fun i fieldData -> SynLongIdent.createI fieldData.Ident, SynExpr.createIdent $"arg_%i{i}")
|
||||
|> AstHelper.instantiateRecord
|
||||
|
||||
(finalConstruction, assignments)
|
||||
|
@@ -72,9 +72,7 @@ module internal JsonSerializeGenerator =
|
||||
target
|
||||
|> SynExpr.paren
|
||||
|> SynExpr.upcast' (SynType.createLongIdent' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ])
|
||||
|> SynMatchClause.create (
|
||||
SynPat.identWithArgs [ Ident.create "Some" ] (SynArgPats.create [ Ident.create "field" ])
|
||||
)
|
||||
|> SynMatchClause.create (SynPat.nameWithArgs "Some" [ SynPat.named "field" ])
|
||||
|
||||
[ noneClause ; someClause ]
|
||||
|> SynExpr.createMatch (SynExpr.createIdent "field")
|
||||
@@ -125,11 +123,7 @@ module internal JsonSerializeGenerator =
|
||||
DebugPointAtInOrTo.Yes range0,
|
||||
SeqExprOnly.SeqExprOnly false,
|
||||
true,
|
||||
SynPat.paren (
|
||||
SynPat.identWithArgs
|
||||
[ Ident.create "KeyValue" ]
|
||||
(SynArgPats.create [ Ident.create "key" ; Ident.create "value" ])
|
||||
),
|
||||
SynPat.paren (SynPat.nameWithArgs "KeyValue" [ SynPat.named "key" ; SynPat.named "value" ]),
|
||||
SynExpr.createIdent "field",
|
||||
SynExpr.applyFunction
|
||||
(SynExpr.createLongIdent [ "ret" ; "Add" ])
|
||||
@@ -275,9 +269,9 @@ module internal JsonSerializeGenerator =
|
||||
|> List.map (fun unionCase ->
|
||||
let propertyName = getPropertyName unionCase.Ident unionCase.Attrs
|
||||
|
||||
let caseNames = unionCase.Fields |> List.mapi (fun i _ -> Ident.create $"arg%i{i}")
|
||||
let caseNames = unionCase.Fields |> List.mapi (fun i _ -> $"arg%i{i}")
|
||||
|
||||
let argPats = SynArgPats.create caseNames
|
||||
let argPats = SynArgPats.createNamed caseNames
|
||||
|
||||
let pattern =
|
||||
SynPat.LongIdent (
|
||||
@@ -311,7 +305,7 @@ module internal JsonSerializeGenerator =
|
||||
let propertyName = getPropertyName (Option.get fieldData.Ident) fieldData.Attrs
|
||||
|
||||
let node =
|
||||
SynExpr.applyFunction (fst (serializeNode fieldData.Type)) (SynExpr.createIdent' caseName)
|
||||
SynExpr.applyFunction (fst (serializeNode fieldData.Type)) (SynExpr.createIdent caseName)
|
||||
|
||||
[ propertyName ; node ]
|
||||
|> SynExpr.tuple
|
||||
|
@@ -42,6 +42,7 @@ module internal RemoveOptionsGenerator =
|
||||
(accessibility : SynAccess option)
|
||||
(generics : SynTyparDecls option)
|
||||
(fields : SynField list)
|
||||
: SynModuleDecl
|
||||
=
|
||||
let fields : SynField list = fields |> List.map removeOption
|
||||
let name = Ident.create "Short"
|
||||
@@ -54,6 +55,7 @@ module internal RemoveOptionsGenerator =
|
||||
XmlDoc = xmlDoc
|
||||
Generics = generics
|
||||
Accessibility = accessibility
|
||||
Attributes = []
|
||||
}
|
||||
|
||||
let typeDecl = AstHelper.defineRecordType record
|
||||
@@ -91,7 +93,7 @@ module internal RemoveOptionsGenerator =
|
||||
)
|
||||
| _ -> accessor
|
||||
|
||||
(SynLongIdent.createI fieldData.Ident, true), Some body
|
||||
SynLongIdent.createI fieldData.Ident, body
|
||||
)
|
||||
|> AstHelper.instantiateRecord
|
||||
|
||||
|
@@ -1,3 +1,5 @@
|
||||
WoofWare.Myriad.Plugins.ArgParserGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
|
||||
WoofWare.Myriad.Plugins.ArgParserGenerator..ctor [constructor]: unit
|
||||
WoofWare.Myriad.Plugins.CreateCatamorphismGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
|
||||
WoofWare.Myriad.Plugins.CreateCatamorphismGenerator..ctor [constructor]: unit
|
||||
WoofWare.Myriad.Plugins.HttpClientGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
|
||||
|
@@ -7,3 +7,6 @@ open Fantomas.FCS.Text.Range
|
||||
module internal PreXmlDoc =
|
||||
let create (s : string) : PreXmlDoc =
|
||||
PreXmlDoc.Create ([| " " + s |], range0)
|
||||
|
||||
let create' (s : string seq) : PreXmlDoc =
|
||||
PreXmlDoc.Create (Array.ofSeq s, range0)
|
||||
|
@@ -1,16 +1,30 @@
|
||||
namespace WoofWare.Myriad.Plugins
|
||||
|
||||
open Fantomas.FCS.Syntax
|
||||
open Fantomas.FCS.Text.Range
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
module internal SynArgPats =
|
||||
let create (caseNames : Ident list) : SynArgPats =
|
||||
let createNamed (caseNames : string list) : SynArgPats =
|
||||
match caseNames.Length with
|
||||
| 0 -> SynArgPats.Pats []
|
||||
| 1 -> [ SynPat.named caseNames.[0].idText ] |> SynArgPats.Pats
|
||||
| _ ->
|
||||
caseNames
|
||||
|> List.map (fun i -> SynPat.named i.idText)
|
||||
|> SynPat.tuple
|
||||
| 1 ->
|
||||
SynPat.Named (SynIdent.SynIdent (Ident.create caseNames.[0], None), false, None, range0)
|
||||
|> List.singleton
|
||||
|> SynArgPats.Pats
|
||||
| len ->
|
||||
caseNames
|
||||
|> List.map (fun name -> SynPat.Named (SynIdent.SynIdent (Ident.create name, None), false, None, range0))
|
||||
|> fun t -> SynPat.Tuple (false, t, List.replicate (len - 1) range0, range0)
|
||||
|> fun t -> SynPat.Paren (t, range0)
|
||||
|> List.singleton
|
||||
|> SynArgPats.Pats
|
||||
|
||||
let create (pats : SynPat list) : SynArgPats =
|
||||
match pats.Length with
|
||||
| 0 -> SynArgPats.Pats []
|
||||
| 1 -> [ pats.[0] ] |> SynArgPats.Pats
|
||||
| len ->
|
||||
SynPat.Paren (SynPat.Tuple (false, pats, List.replicate (len - 1) range0, range0), range0)
|
||||
|> List.singleton
|
||||
|> SynArgPats.Pats
|
||||
|
15
WoofWare.Myriad.Plugins/SynExpr/SynAttributes.fs
Normal file
15
WoofWare.Myriad.Plugins/SynExpr/SynAttributes.fs
Normal file
@@ -0,0 +1,15 @@
|
||||
namespace WoofWare.Myriad.Plugins
|
||||
|
||||
open Fantomas.FCS.Syntax
|
||||
open Fantomas.FCS.Text.Range
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
module internal SynAttributes =
|
||||
let ofAttrs (attrs : SynAttribute list) : SynAttributes =
|
||||
attrs
|
||||
|> List.map (fun a ->
|
||||
{
|
||||
Attributes = [ a ]
|
||||
Range = range0
|
||||
}
|
||||
)
|
@@ -62,6 +62,35 @@ module internal SynBinding =
|
||||
triviaZero false
|
||||
)
|
||||
|
||||
let withMutability (mut : bool) (binding : SynBinding) : SynBinding =
|
||||
match binding with
|
||||
| SynBinding (pat, kind, inl, _, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
|
||||
SynBinding (pat, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia)
|
||||
|
||||
let withRecursion (isRec : bool) (binding : SynBinding) : SynBinding =
|
||||
match binding with
|
||||
| SynBinding (pat, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
|
||||
let trivia =
|
||||
{ trivia with
|
||||
LeadingKeyword =
|
||||
match trivia.LeadingKeyword with
|
||||
| SynLeadingKeyword.Let _ ->
|
||||
if isRec then
|
||||
SynLeadingKeyword.LetRec (range0, range0)
|
||||
else
|
||||
trivia.LeadingKeyword
|
||||
| SynLeadingKeyword.LetRec _ ->
|
||||
if isRec then
|
||||
trivia.LeadingKeyword
|
||||
else
|
||||
trivia.LeadingKeyword
|
||||
| existing ->
|
||||
failwith
|
||||
$"WoofWare.Myriad doesn't yet let you adjust the recursion modifier on a binding with modifier %O{existing}"
|
||||
}
|
||||
|
||||
SynBinding (pat, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia)
|
||||
|
||||
let withAccessibility (acc : SynAccess option) (binding : SynBinding) : SynBinding =
|
||||
match binding with
|
||||
| SynBinding (_, kind, inl, mut, attrs, xml, valData, headPat, returnInfo, expr, range, debugPoint, trivia) ->
|
||||
|
@@ -13,6 +13,13 @@ module internal SynExprExtensions =
|
||||
|
||||
static member CreateConst () : SynExpr = SynExpr.Const (SynConst.Unit, range0)
|
||||
|
||||
static member CreateConst (b : bool) : SynExpr = SynExpr.Const (SynConst.Bool b, range0)
|
||||
|
||||
static member CreateConst (c : char) : SynExpr =
|
||||
// apparent Myriad bug: `IndexOf '?'` gets formatted as `IndexOf ?` which is clearly wrong
|
||||
SynExpr.CreateApp (SynExpr.Ident (Ident.Create "char"), SynExpr.CreateConst (int c))
|
||||
|> fun e -> SynExpr.Paren (e, range0, Some range0, range0)
|
||||
|
||||
static member CreateConst (i : int32) : SynExpr =
|
||||
SynExpr.Const (SynConst.Int32 i, range0)
|
||||
|
||||
@@ -138,6 +145,14 @@ module internal SynExpr =
|
||||
let inline index (property : SynExpr) (obj : SynExpr) : SynExpr =
|
||||
SynExpr.DotIndexedGet (obj, property, range0, range0)
|
||||
|
||||
let inline arrayIndexRange (start : SynExpr option) (endRange : SynExpr option) (arr : SynExpr) : SynExpr =
|
||||
SynExpr.DotIndexedGet (
|
||||
arr,
|
||||
(SynExpr.IndexRange (start, range0, endRange, range0, range0, range0)),
|
||||
range0,
|
||||
range0
|
||||
)
|
||||
|
||||
let inline paren (e : SynExpr) : SynExpr =
|
||||
SynExpr.Paren (e, range0, Some range0, range0)
|
||||
|
||||
@@ -202,6 +217,18 @@ module internal SynExpr =
|
||||
|
||||
pipeThroughFunction lambda body
|
||||
|
||||
let inline createForEach (pat : SynPat) (enumExpr : SynExpr) (body : SynExpr) : SynExpr =
|
||||
SynExpr.ForEach (
|
||||
DebugPointAtFor.No,
|
||||
DebugPointAtInOrTo.No,
|
||||
SeqExprOnly.SeqExprOnly false,
|
||||
true,
|
||||
pat,
|
||||
enumExpr,
|
||||
body,
|
||||
range0
|
||||
)
|
||||
|
||||
let inline createLet (bindings : SynBinding list) (body : SynExpr) : SynExpr =
|
||||
SynExpr.LetOrUse (false, false, bindings, body, range0, SynExprLetOrUseTrivia.empty)
|
||||
|
||||
@@ -233,6 +260,12 @@ module internal SynExpr =
|
||||
exprs
|
||||
|> List.reduce (fun a b -> SynExpr.Sequential (DebugPointAtSequential.SuppressNeither, false, a, b, range0))
|
||||
|
||||
let listLiteral (elts : SynExpr list) : SynExpr =
|
||||
SynExpr.ArrayOrListComputed (false, sequential elts, range0)
|
||||
|
||||
let arrayLiteral (elts : SynExpr list) : SynExpr =
|
||||
SynExpr.ArrayOrListComputed (true, sequential elts, range0)
|
||||
|
||||
/// {compExpr} { {lets} ; return {ret} }
|
||||
let createCompExpr (compExpr : string) (retBody : SynExpr) (lets : CompExprBinding list) : SynExpr =
|
||||
let retStatement = SynExpr.YieldOrReturn ((false, true), retBody, range0)
|
||||
@@ -296,9 +329,37 @@ module internal SynExpr =
|
||||
|
||||
/// {y} > {x}
|
||||
let greaterThan (x : SynExpr) (y : SynExpr) : SynExpr =
|
||||
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.ge, y) |> applyTo x
|
||||
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.gt, y) |> applyTo x
|
||||
|
||||
/// {y} < {x}
|
||||
let lessThan (x : SynExpr) (y : SynExpr) : SynExpr =
|
||||
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.lt, y) |> applyTo x
|
||||
|
||||
/// {y} >= {x}
|
||||
let greaterThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr =
|
||||
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.geq, y)
|
||||
|> applyTo x
|
||||
|
||||
/// {y} <= {x}
|
||||
let lessThanOrEqual (x : SynExpr) (y : SynExpr) : SynExpr =
|
||||
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.leq, y)
|
||||
|> applyTo x
|
||||
|
||||
/// {x} :: {y}
|
||||
let listCons (x : SynExpr) (y : SynExpr) : SynExpr =
|
||||
SynExpr.CreateAppInfix (
|
||||
SynExpr.LongIdent (
|
||||
false,
|
||||
SynLongIdent.SynLongIdent (
|
||||
[ Ident.create "op_ColonColon" ],
|
||||
[],
|
||||
[ Some (IdentTrivia.OriginalNotation "::") ]
|
||||
),
|
||||
None,
|
||||
range0
|
||||
),
|
||||
tupleNoParen [ x ; y ]
|
||||
)
|
||||
|> paren
|
||||
|
||||
let assign (lhs : SynLongIdent) (rhs : SynExpr) : SynExpr = SynExpr.LongIdentSet (lhs, rhs, range0)
|
||||
|
@@ -14,9 +14,19 @@ module internal SynLongIdent =
|
||||
[ Some (IdentTrivia.OriginalNotation ">=") ]
|
||||
)
|
||||
|
||||
let ge =
|
||||
let leq =
|
||||
SynLongIdent.SynLongIdent (
|
||||
[ Ident.create "op_LessThanOrEqual" ],
|
||||
[],
|
||||
[ Some (IdentTrivia.OriginalNotation "<=") ]
|
||||
)
|
||||
|
||||
let gt =
|
||||
SynLongIdent.SynLongIdent ([ Ident.create "op_GreaterThan" ], [], [ Some (IdentTrivia.OriginalNotation ">") ])
|
||||
|
||||
let lt =
|
||||
SynLongIdent.SynLongIdent ([ Ident.create "op_LessThan" ], [], [ Some (IdentTrivia.OriginalNotation "<") ])
|
||||
|
||||
let sub =
|
||||
SynLongIdent.SynLongIdent ([ Ident.create "op_Subtraction" ], [], [ Some (IdentTrivia.OriginalNotation "-") ])
|
||||
|
||||
@@ -70,6 +80,12 @@ module internal SynLongIdent =
|
||||
// TODO: consider Microsoft.FSharp.Option or whatever it is
|
||||
| _ -> false
|
||||
|
||||
let isChoice (ident : SynLongIdent) : bool =
|
||||
match ident.LongIdent with
|
||||
| [ i ] when System.String.Equals (i.idText, "Choice", System.StringComparison.Ordinal) -> true
|
||||
// TODO: consider Microsoft.FSharp.Choice or whatever it is
|
||||
| _ -> false
|
||||
|
||||
let isNullable (ident : SynLongIdent) : bool =
|
||||
match ident.LongIdent |> List.map _.idText with
|
||||
| [ "System" ; "Nullable" ]
|
||||
|
@@ -14,6 +14,8 @@ module internal SynModuleDecl =
|
||||
|
||||
let inline createLet (binding : SynBinding) : SynModuleDecl = createLets [ binding ]
|
||||
|
||||
let inline createTypes (tys : SynTypeDefn list) : SynModuleDecl = SynModuleDecl.Types (tys, range0)
|
||||
|
||||
let nestedModule (info : SynComponentInfo) (decls : SynModuleDecl list) : SynModuleDecl =
|
||||
SynModuleDecl.NestedModule (
|
||||
info,
|
||||
|
@@ -7,6 +7,8 @@ open Fantomas.FCS.Text.Range
|
||||
module internal SynPat =
|
||||
let inline paren (pat : SynPat) : SynPat = SynPat.Paren (pat, range0)
|
||||
|
||||
let anon : SynPat = SynPat.Wild range0
|
||||
|
||||
let inline annotateTypeNoParen (ty : SynType) (pat : SynPat) = SynPat.Typed (pat, ty, range0)
|
||||
|
||||
let inline annotateType (ty : SynType) (pat : SynPat) = paren (annotateTypeNoParen ty pat)
|
||||
@@ -20,6 +22,9 @@ module internal SynPat =
|
||||
let inline identWithArgs (i : LongIdent) (args : SynArgPats) : SynPat =
|
||||
SynPat.LongIdent (SynLongIdent.create i, None, None, args, None, range0)
|
||||
|
||||
let inline nameWithArgs (i : string) (args : SynPat list) : SynPat =
|
||||
identWithArgs [ Ident.create i ] (SynArgPats.create args)
|
||||
|
||||
let inline tupleNoParen (elements : SynPat list) : SynPat =
|
||||
match elements with
|
||||
| [] -> failwith "Can't tuple no elements in a pattern"
|
||||
@@ -33,3 +38,17 @@ module internal SynPat =
|
||||
let unit = createConst SynConst.Unit
|
||||
|
||||
let createNull = SynPat.Null range0
|
||||
|
||||
let emptyList = SynPat.ArrayOrList (false, [], range0)
|
||||
|
||||
let listCons (lhs : SynPat) (rhs : SynPat) =
|
||||
SynPat.ListCons (
|
||||
lhs,
|
||||
rhs,
|
||||
range0,
|
||||
{
|
||||
ColonColonRange = range0
|
||||
}
|
||||
)
|
||||
|
||||
let emptyArray = SynPat.ArrayOrList (true, [], range0)
|
||||
|
@@ -1,56 +1,9 @@
|
||||
namespace WoofWare.Myriad.Plugins
|
||||
|
||||
open System
|
||||
open Fantomas.FCS.Syntax
|
||||
open Fantomas.FCS.Text.Range
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
module internal SynType =
|
||||
let rec stripOptionalParen (ty : SynType) : SynType =
|
||||
match ty with
|
||||
| SynType.Paren (ty, _) -> stripOptionalParen ty
|
||||
| ty -> ty
|
||||
|
||||
let inline createLongIdent (ident : LongIdent) : SynType =
|
||||
SynType.LongIdent (SynLongIdent.create ident)
|
||||
|
||||
let inline createLongIdent' (ident : string list) : SynType =
|
||||
SynType.LongIdent (SynLongIdent.createS' ident)
|
||||
|
||||
let inline named (name : string) = createLongIdent' [ name ]
|
||||
|
||||
let inline app' (name : SynType) (args : SynType list) : SynType =
|
||||
if args.IsEmpty then
|
||||
failwith "Type cannot be applied to no arguments"
|
||||
|
||||
SynType.App (name, Some range0, args, List.replicate (args.Length - 1) range0, Some range0, false, range0)
|
||||
|
||||
let inline app (name : string) (args : SynType list) : SynType = app' (named name) args
|
||||
|
||||
let inline appPostfix (name : string) (arg : SynType) : SynType =
|
||||
SynType.App (named name, None, [ arg ], [], None, true, range0)
|
||||
|
||||
let inline funFromDomain (domain : SynType) (range : SynType) : SynType =
|
||||
SynType.Fun (
|
||||
domain,
|
||||
range,
|
||||
range0,
|
||||
{
|
||||
ArrowRange = range0
|
||||
}
|
||||
)
|
||||
|
||||
let inline signatureParamOfType (ty : SynType) (name : Ident option) : SynType =
|
||||
SynType.SignatureParameter ([], false, name, ty, range0)
|
||||
|
||||
let inline var (ty : SynTypar) : SynType = SynType.Var (ty, range0)
|
||||
|
||||
let unit : SynType = named "unit"
|
||||
let int : SynType = named "int"
|
||||
|
||||
/// Given ['a1, 'a2] and 'ret, returns 'a1 -> 'a2 -> 'ret.
|
||||
let toFun (inputs : SynType list) (ret : SynType) : SynType =
|
||||
(ret, List.rev inputs) ||> List.fold (fun ty input -> funFromDomain input ty)
|
||||
|
||||
[<AutoOpen>]
|
||||
module internal SynTypePatterns =
|
||||
let (|OptionType|_|) (fieldType : SynType) =
|
||||
@@ -59,6 +12,11 @@ module internal SynTypePatterns =
|
||||
Some innerType
|
||||
| _ -> None
|
||||
|
||||
let (|ChoiceType|_|) (fieldType : SynType) =
|
||||
match fieldType with
|
||||
| SynType.App (SynType.LongIdent ident, _, inner, _, _, _, _) when SynLongIdent.isChoice ident -> Some inner
|
||||
| _ -> None
|
||||
|
||||
let (|NullableType|_|) (fieldType : SynType) =
|
||||
match fieldType with
|
||||
| SynType.App (SynType.LongIdent ident, _, [ innerType ], _, _, _, _) when SynLongIdent.isNullable ident ->
|
||||
@@ -272,3 +230,228 @@ module internal SynTypePatterns =
|
||||
| _ -> failwithf "Expected Task to be applied to exactly one arg, but got: %+A" args
|
||||
| _ -> None
|
||||
| _ -> None
|
||||
|
||||
let (|DirectoryInfo|_|) (fieldType : SynType) =
|
||||
match fieldType with
|
||||
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
|
||||
match ident |> List.map (fun i -> i.idText) with
|
||||
| [ "System" ; "IO" ; "DirectoryInfo" ]
|
||||
| [ "IO" ; "DirectoryInfo" ]
|
||||
| [ "DirectoryInfo" ] -> Some ()
|
||||
| _ -> None
|
||||
| _ -> None
|
||||
|
||||
let (|FileInfo|_|) (fieldType : SynType) =
|
||||
match fieldType with
|
||||
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
|
||||
match ident |> List.map (fun i -> i.idText) with
|
||||
| [ "System" ; "IO" ; "FileInfo" ]
|
||||
| [ "IO" ; "FileInfo" ]
|
||||
| [ "FileInfo" ] -> Some ()
|
||||
| _ -> None
|
||||
| _ -> None
|
||||
|
||||
let (|TimeSpan|_|) (fieldType : SynType) =
|
||||
match fieldType with
|
||||
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
|
||||
match ident |> List.map (fun i -> i.idText) with
|
||||
| [ "System" ; "TimeSpan" ]
|
||||
| [ "TimeSpan" ] -> Some ()
|
||||
| _ -> None
|
||||
| _ -> None
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
module internal SynType =
|
||||
let rec stripOptionalParen (ty : SynType) : SynType =
|
||||
match ty with
|
||||
| SynType.Paren (ty, _) -> stripOptionalParen ty
|
||||
| ty -> ty
|
||||
|
||||
let inline createLongIdent (ident : LongIdent) : SynType =
|
||||
SynType.LongIdent (SynLongIdent.create ident)
|
||||
|
||||
let inline createLongIdent' (ident : string list) : SynType =
|
||||
SynType.LongIdent (SynLongIdent.createS' ident)
|
||||
|
||||
let inline named (name : string) = createLongIdent' [ name ]
|
||||
|
||||
let inline app' (name : SynType) (args : SynType list) : SynType =
|
||||
if args.IsEmpty then
|
||||
failwith "Type cannot be applied to no arguments"
|
||||
|
||||
SynType.App (name, Some range0, args, List.replicate (args.Length - 1) range0, Some range0, false, range0)
|
||||
|
||||
let inline app (name : string) (args : SynType list) : SynType = app' (named name) args
|
||||
|
||||
let inline appPostfix (name : string) (arg : SynType) : SynType =
|
||||
SynType.App (named name, None, [ arg ], [], None, true, range0)
|
||||
|
||||
let inline appPostfix' (name : string list) (arg : SynType) : SynType =
|
||||
SynType.App (createLongIdent' name, None, [ arg ], [], None, true, range0)
|
||||
|
||||
let inline funFromDomain (domain : SynType) (range : SynType) : SynType =
|
||||
SynType.Fun (
|
||||
domain,
|
||||
range,
|
||||
range0,
|
||||
{
|
||||
ArrowRange = range0
|
||||
}
|
||||
)
|
||||
|
||||
let inline signatureParamOfType (ty : SynType) (name : Ident option) : SynType =
|
||||
SynType.SignatureParameter ([], false, name, ty, range0)
|
||||
|
||||
let inline var (ty : SynTypar) : SynType = SynType.Var (ty, range0)
|
||||
|
||||
let unit : SynType = named "unit"
|
||||
let int : SynType = named "int"
|
||||
|
||||
let anon : SynType = SynType.Anon range0
|
||||
|
||||
let string : SynType = named "string"
|
||||
|
||||
/// Given ['a1, 'a2] and 'ret, returns 'a1 -> 'a2 -> 'ret.
|
||||
let toFun (inputs : SynType list) (ret : SynType) : SynType =
|
||||
(ret, List.rev inputs) ||> List.fold (fun ty input -> funFromDomain input ty)
|
||||
|
||||
let primitiveToHumanReadableString (name : LongIdent) : string =
|
||||
match name |> List.map _.idText with
|
||||
| [ "System" ; "Single" ] -> "single"
|
||||
| [ "System" ; "Double" ] -> "double"
|
||||
| [ "System" ; "Byte" ] -> "byte"
|
||||
| [ "System" ; "SByte" ] -> "signed byte"
|
||||
| [ "System" ; "Int16" ] -> "int16"
|
||||
| [ "System" ; "Int32" ] -> "int32"
|
||||
| [ "System" ; "Int64" ] -> "int64"
|
||||
| [ "System" ; "UInt16" ] -> "uint16"
|
||||
| [ "System" ; "UInt32" ] -> "uint32"
|
||||
| [ "System" ; "UInt64" ] -> "uint64"
|
||||
| [ "System" ; "Char" ] -> "char"
|
||||
| [ "System" ; "Decimal" ] -> "decimal"
|
||||
| [ "System" ; "String" ] -> "string"
|
||||
| [ "System" ; "Boolean" ] -> "bool"
|
||||
| ty ->
|
||||
ty
|
||||
|> String.concat "."
|
||||
|> failwithf "could not create human-readable string for primitive type %s"
|
||||
|
||||
let rec toHumanReadableString (ty : SynType) : string =
|
||||
match ty with
|
||||
| PrimitiveType t1 -> primitiveToHumanReadableString t1
|
||||
| OptionType t1 -> toHumanReadableString t1 + " option"
|
||||
| NullableType t1 -> toHumanReadableString t1 + " Nullable"
|
||||
| ChoiceType ts ->
|
||||
ts
|
||||
|> List.map toHumanReadableString
|
||||
|> String.concat ", "
|
||||
|> sprintf "Choice<%s>"
|
||||
| MapType (k, v)
|
||||
| DictionaryType (k, v)
|
||||
| IDictionaryType (k, v)
|
||||
| IReadOnlyDictionaryType (k, v) -> sprintf "map<%s, %s>" (toHumanReadableString k) (toHumanReadableString v)
|
||||
| ListType t1 -> toHumanReadableString t1 + " list"
|
||||
| ArrayType t1 -> toHumanReadableString t1 + " array"
|
||||
| Task t1 -> toHumanReadableString t1 + " Task"
|
||||
| UnitType -> "unit"
|
||||
| FileInfo -> "FileInfo"
|
||||
| DirectoryInfo -> "DirectoryInfo"
|
||||
| Uri -> "URI"
|
||||
| Stream -> "Stream"
|
||||
| Guid -> "GUID"
|
||||
| BigInt -> "bigint"
|
||||
| DateTimeOffset -> "DateTimeOffset"
|
||||
| DateOnly -> "DateOnly"
|
||||
| TimeSpan -> "TimeSpan"
|
||||
| ty -> failwithf "could not compute human-readable string for type: %O" ty
|
||||
|
||||
/// Guess whether the types are equal. We err on the side of saying "no, they're different".
|
||||
let rec provablyEqual (ty1 : SynType) (ty2 : SynType) : bool =
|
||||
if Object.ReferenceEquals (ty1, ty2) then
|
||||
true
|
||||
else
|
||||
|
||||
match ty1 with
|
||||
| PrimitiveType t1 ->
|
||||
match ty2 with
|
||||
| PrimitiveType t2 -> (t1 |> List.map _.idText) = (t2 |> List.map _.idText)
|
||||
| _ -> false
|
||||
| OptionType t1 ->
|
||||
match ty2 with
|
||||
| OptionType t2 -> provablyEqual t1 t2
|
||||
| _ -> false
|
||||
| NullableType t1 ->
|
||||
match ty2 with
|
||||
| NullableType t2 -> provablyEqual t1 t2
|
||||
| _ -> false
|
||||
| ChoiceType t1 ->
|
||||
match ty2 with
|
||||
| ChoiceType t2 ->
|
||||
t1.Length = t2.Length
|
||||
&& List.forall (fun (a, b) -> provablyEqual a b) (List.zip t1 t2)
|
||||
| _ -> false
|
||||
| DictionaryType (k1, v1) ->
|
||||
match ty2 with
|
||||
| DictionaryType (k2, v2) -> provablyEqual k1 k2 && provablyEqual v1 v2
|
||||
| _ -> false
|
||||
| IDictionaryType (k1, v1) ->
|
||||
match ty2 with
|
||||
| IDictionaryType (k2, v2) -> provablyEqual k1 k2 && provablyEqual v1 v2
|
||||
| _ -> false
|
||||
| IReadOnlyDictionaryType (k1, v1) ->
|
||||
match ty2 with
|
||||
| IReadOnlyDictionaryType (k2, v2) -> provablyEqual k1 k2 && provablyEqual v1 v2
|
||||
| _ -> false
|
||||
| MapType (k1, v1) ->
|
||||
match ty2 with
|
||||
| MapType (k2, v2) -> provablyEqual k1 k2 && provablyEqual v1 v2
|
||||
| _ -> false
|
||||
| ListType t1 ->
|
||||
match ty2 with
|
||||
| ListType t2 -> provablyEqual t1 t2
|
||||
| _ -> false
|
||||
| ArrayType t1 ->
|
||||
match ty2 with
|
||||
| ArrayType t2 -> provablyEqual t1 t2
|
||||
| _ -> false
|
||||
| Task t1 ->
|
||||
match ty2 with
|
||||
| Task t2 -> provablyEqual t1 t2
|
||||
| _ -> false
|
||||
| UnitType ->
|
||||
match ty2 with
|
||||
| UnitType -> true
|
||||
| _ -> false
|
||||
| FileInfo ->
|
||||
match ty2 with
|
||||
| FileInfo -> true
|
||||
| _ -> false
|
||||
| DirectoryInfo ->
|
||||
match ty2 with
|
||||
| DirectoryInfo -> true
|
||||
| _ -> false
|
||||
| Uri ->
|
||||
match ty2 with
|
||||
| Uri -> true
|
||||
| _ -> false
|
||||
| Stream ->
|
||||
match ty2 with
|
||||
| Stream -> true
|
||||
| _ -> false
|
||||
| Guid ->
|
||||
match ty2 with
|
||||
| Guid -> true
|
||||
| _ -> false
|
||||
| BigInt ->
|
||||
match ty2 with
|
||||
| BigInt -> true
|
||||
| _ -> false
|
||||
| DateTimeOffset ->
|
||||
match ty2 with
|
||||
| DateTimeOffset -> true
|
||||
| _ -> false
|
||||
| DateOnly ->
|
||||
match ty2 with
|
||||
| DateOnly -> true
|
||||
| _ -> false
|
||||
| _ -> false
|
||||
|
@@ -1,6 +1,9 @@
|
||||
namespace WoofWare.Myriad.Plugins
|
||||
|
||||
open Fantomas.FCS.Syntax
|
||||
open Fantomas.FCS.Text.Range
|
||||
open Fantomas.FCS.Xml
|
||||
open Fantomas.FCS.SyntaxTrivia
|
||||
|
||||
type internal UnionCase<'Ident> =
|
||||
{
|
||||
@@ -39,3 +42,34 @@ module internal SynUnionCase =
|
||||
Attrs = attrs
|
||||
Ident = id
|
||||
}
|
||||
|
||||
let create (case : UnionCase<Ident>) : SynUnionCase =
|
||||
let fields =
|
||||
case.Fields
|
||||
|> List.map (fun field ->
|
||||
SynField.SynField (
|
||||
SynAttributes.ofAttrs field.Attrs,
|
||||
false,
|
||||
Some field.Ident,
|
||||
field.Type,
|
||||
false,
|
||||
PreXmlDoc.Empty,
|
||||
None,
|
||||
range0,
|
||||
{
|
||||
LeadingKeyword = None
|
||||
}
|
||||
)
|
||||
)
|
||||
|
||||
SynUnionCase.SynUnionCase (
|
||||
SynAttributes.ofAttrs case.Attrs,
|
||||
SynIdent.SynIdent (case.Ident, None),
|
||||
SynUnionCaseKind.Fields fields,
|
||||
PreXmlDoc.Empty,
|
||||
None,
|
||||
range0,
|
||||
{
|
||||
BarRange = Some range0
|
||||
}
|
||||
)
|
||||
|
@@ -1,4 +1,4 @@
|
||||
<Project Sdk="Microsoft.NET.Sdk">
|
||||
<Project Sdk="Microsoft.NET.Sdk">
|
||||
|
||||
<PropertyGroup>
|
||||
<TargetFramework>net6.0</TargetFramework>
|
||||
@@ -18,7 +18,7 @@
|
||||
</PropertyGroup>
|
||||
|
||||
<ItemGroup>
|
||||
<PackageReference Include="Myriad.Core" Version="0.8.3" PrivateAssets="all"/>
|
||||
<PackageReference Include="Myriad.Core" Version="0.8.3" />
|
||||
<!-- the lowest version allowed by Myriad.Core -->
|
||||
<PackageReference Update="FSharp.Core" Version="6.0.1" PrivateAssets="all"/>
|
||||
</ItemGroup>
|
||||
@@ -26,17 +26,18 @@
|
||||
<ItemGroup>
|
||||
<Compile Include="List.fs"/>
|
||||
<Compile Include="Primitives.fs" />
|
||||
<Compile Include="SynExpr\SynAttributes.fs" />
|
||||
<Compile Include="SynExpr\PreXmlDoc.fs" />
|
||||
<Compile Include="SynExpr\Ident.fs" />
|
||||
<Compile Include="SynExpr\SynLongIdent.fs" />
|
||||
<Compile Include="SynExpr\SynExprLetOrUseTrivia.fs" />
|
||||
<Compile Include="SynExpr\SynArgPats.fs" />
|
||||
<Compile Include="SynExpr\SynPat.fs" />
|
||||
<Compile Include="SynExpr\SynBinding.fs" />
|
||||
<Compile Include="SynExpr\SynType.fs" />
|
||||
<Compile Include="SynExpr\SynMatchClause.fs" />
|
||||
<Compile Include="SynExpr\CompExpr.fs" />
|
||||
<Compile Include="SynExpr\SynExpr.fs" />
|
||||
<Compile Include="SynExpr\SynArgPats.fs" />
|
||||
<Compile Include="SynExpr\SynField.fs" />
|
||||
<Compile Include="SynExpr\SynUnionCase.fs" />
|
||||
<Compile Include="SynExpr\SynTypeDefnRepr.fs" />
|
||||
@@ -54,6 +55,7 @@
|
||||
<Compile Include="JsonParseGenerator.fs"/>
|
||||
<Compile Include="HttpClientGenerator.fs"/>
|
||||
<Compile Include="CataGenerator.fs" />
|
||||
<Compile Include="ArgParserGenerator.fs" />
|
||||
<EmbeddedResource Include="version.json"/>
|
||||
<EmbeddedResource Include="SurfaceBaseline.txt"/>
|
||||
<None Include="..\README.md">
|
||||
|
@@ -1,5 +1,5 @@
|
||||
{
|
||||
"version": "2.1",
|
||||
"version": "2.2",
|
||||
"publicReleaseRefSpec": [
|
||||
"^refs/heads/main$"
|
||||
],
|
||||
|
6
flake.lock
generated
6
flake.lock
generated
@@ -20,11 +20,11 @@
|
||||
},
|
||||
"nixpkgs": {
|
||||
"locked": {
|
||||
"lastModified": 1723221148,
|
||||
"narHash": "sha256-7pjpeQlZUNQ4eeVntytU3jkw9dFK3k1Htgk2iuXjaD8=",
|
||||
"lastModified": 1724395761,
|
||||
"narHash": "sha256-zRkDV/nbrnp3Y8oCADf5ETl1sDrdmAW6/bBVJ8EbIdQ=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "154bcb95ad51bc257c2ce4043a725de6ca700ef6",
|
||||
"rev": "ae815cee91b417be55d43781eb4b73ae1ecc396c",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
@@ -3,8 +3,8 @@
|
||||
{fetchNuGet}: [
|
||||
(fetchNuGet {
|
||||
pname = "ApiSurface";
|
||||
version = "4.0.43";
|
||||
hash = "sha256-CO5a0ZCWvD4fZXQL9l0At0y0vqmN3TT2+TuUw4ZNoC8=";
|
||||
version = "4.0.44";
|
||||
hash = "sha256-1su3UcdsyG9OoPwiMqo07rUMKhkVKlohRK4fA8mbxvI=";
|
||||
})
|
||||
(fetchNuGet {
|
||||
pname = "fantomas";
|
||||
|
Reference in New Issue
Block a user