mirror of
https://github.com/Smaug123/WoofWare.Myriad
synced 2025-10-07 04:58:41 +00:00
Compare commits
12 Commits
WoofWare.M
...
WoofWare.M
Author | SHA1 | Date | |
---|---|---|---|
|
693b95106a | ||
|
49ecfbf5e5 | ||
|
5748ac3d5b | ||
|
913959a740 | ||
|
93ffc065cd | ||
|
d14efba7e7 | ||
|
f5cf0b79dd | ||
|
029e3746bb | ||
|
8ae749c529 | ||
|
e4cbab3209 | ||
|
bdce82fb7a | ||
|
8f9f933971 |
@@ -3,7 +3,7 @@
|
|||||||
"isRoot": true,
|
"isRoot": true,
|
||||||
"tools": {
|
"tools": {
|
||||||
"fantomas": {
|
"fantomas": {
|
||||||
"version": "6.3.11",
|
"version": "6.3.12",
|
||||||
"commands": [
|
"commands": [
|
||||||
"fantomas"
|
"fantomas"
|
||||||
]
|
]
|
||||||
|
4
.github/workflows/dotnet.yaml
vendored
4
.github/workflows/dotnet.yaml
vendored
@@ -241,7 +241,7 @@ jobs:
|
|||||||
name: nuget-package-attribute
|
name: nuget-package-attribute
|
||||||
path: packed
|
path: packed
|
||||||
- name: Attest Build Provenance
|
- name: Attest Build Provenance
|
||||||
uses: actions/attest-build-provenance@6149ea5740be74af77f260b9db67e633f6b0a9a1 # v1.4.2
|
uses: actions/attest-build-provenance@1c608d11d69870c2092266b3f9a6f3abbf17002c # v1.4.3
|
||||||
with:
|
with:
|
||||||
subject-path: "packed/*.nupkg"
|
subject-path: "packed/*.nupkg"
|
||||||
|
|
||||||
@@ -260,7 +260,7 @@ jobs:
|
|||||||
name: nuget-package-plugin
|
name: nuget-package-plugin
|
||||||
path: packed
|
path: packed
|
||||||
- name: Attest Build Provenance
|
- name: Attest Build Provenance
|
||||||
uses: actions/attest-build-provenance@6149ea5740be74af77f260b9db67e633f6b0a9a1 # v1.4.2
|
uses: actions/attest-build-provenance@1c608d11d69870c2092266b3f9a6f3abbf17002c # v1.4.3
|
||||||
with:
|
with:
|
||||||
subject-path: "packed/*.nupkg"
|
subject-path: "packed/*.nupkg"
|
||||||
|
|
||||||
|
@@ -111,7 +111,7 @@ type ChildRecordWithPositional =
|
|||||||
{
|
{
|
||||||
Thing1 : int
|
Thing1 : int
|
||||||
[<PositionalArgs>]
|
[<PositionalArgs>]
|
||||||
Thing2 : string list
|
Thing2 : Uri list
|
||||||
}
|
}
|
||||||
|
|
||||||
[<ArgParser true>]
|
[<ArgParser true>]
|
||||||
@@ -135,3 +135,103 @@ type ChoicePositionals =
|
|||||||
[<PositionalArgs>]
|
[<PositionalArgs>]
|
||||||
Args : Choice<string, string> list
|
Args : Choice<string, string> list
|
||||||
}
|
}
|
||||||
|
|
||||||
|
[<ArgParser true>]
|
||||||
|
type ContainsBoolEnvVar =
|
||||||
|
{
|
||||||
|
[<ArgumentDefaultEnvironmentVariable "CONSUMEPLUGIN_THINGS">]
|
||||||
|
BoolVar : Choice<bool, bool>
|
||||||
|
}
|
||||||
|
|
||||||
|
[<RequireQualifiedAccess>]
|
||||||
|
module Consts =
|
||||||
|
[<Literal>]
|
||||||
|
let FALSE = false
|
||||||
|
|
||||||
|
[<Literal>]
|
||||||
|
let TRUE = true
|
||||||
|
|
||||||
|
type DryRunMode =
|
||||||
|
| [<ArgumentFlag(Consts.FALSE)>] Wet
|
||||||
|
| [<ArgumentFlag true>] Dry
|
||||||
|
|
||||||
|
[<ArgParser true>]
|
||||||
|
type WithFlagDu =
|
||||||
|
{
|
||||||
|
DryRun : DryRunMode
|
||||||
|
}
|
||||||
|
|
||||||
|
[<ArgParser true>]
|
||||||
|
type ContainsFlagEnvVar =
|
||||||
|
{
|
||||||
|
// This phrasing is odd, but it's for a test. Nobody's really going to have `--dry-run`
|
||||||
|
// controlled by an env var!
|
||||||
|
[<ArgumentDefaultEnvironmentVariable "CONSUMEPLUGIN_THINGS">]
|
||||||
|
DryRun : Choice<DryRunMode, DryRunMode>
|
||||||
|
}
|
||||||
|
|
||||||
|
[<ArgParser true>]
|
||||||
|
type ContainsFlagDefaultValue =
|
||||||
|
{
|
||||||
|
[<ArgumentDefaultFunction>]
|
||||||
|
DryRun : Choice<DryRunMode, DryRunMode>
|
||||||
|
}
|
||||||
|
|
||||||
|
static member DefaultDryRun () = DryRunMode.Wet
|
||||||
|
|
||||||
|
[<ArgParser true>]
|
||||||
|
type ManyLongForms =
|
||||||
|
{
|
||||||
|
[<ArgumentLongForm "do-something-else">]
|
||||||
|
[<ArgumentLongForm "anotherarg">]
|
||||||
|
DoTheThing : string
|
||||||
|
|
||||||
|
[<ArgumentLongForm "turn-it-on">]
|
||||||
|
[<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
@@ -19,9 +19,22 @@ type ArgParserAttribute (isExtensionMethod : bool) =
|
|||||||
|
|
||||||
/// Attribute indicating that this field shall accumulate all unmatched args,
|
/// Attribute indicating that this field shall accumulate all unmatched args,
|
||||||
/// as well as any that appear after a bare `--`.
|
/// 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 ()
|
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
|
/// Attribute indicating that this field shall have a default value derived
|
||||||
/// from calling an appropriately named static method on the type.
|
/// from calling an appropriately named static method on the type.
|
||||||
///
|
///
|
||||||
@@ -61,3 +74,24 @@ type ParseExactAttribute (format : string) =
|
|||||||
/// `TimeSpan.ParseExact (s, @"hh\:mm\:ss", CultureInfo.InvariantCulture).
|
/// `TimeSpan.ParseExact (s, @"hh\:mm\:ss", CultureInfo.InvariantCulture).
|
||||||
type InvariantCultureAttribute () =
|
type InvariantCultureAttribute () =
|
||||||
inherit Attribute ()
|
inherit Attribute ()
|
||||||
|
|
||||||
|
/// Attribute placed on a field of a two-case no-data discriminated union, indicating that this is "basically a bool".
|
||||||
|
/// For example: `type DryRun = | [<ArgumentFlag true>] Dry | [<ArgumentFlag false>] Wet`
|
||||||
|
/// A record with `{ DryRun : DryRun }` will then be parsed like `{ DryRun : bool }` (so the user supplies `--dry-run`),
|
||||||
|
/// but that you get this strongly-typed value directly in the code (so you `match args.DryRun with | DryRun.Dry ...`).
|
||||||
|
///
|
||||||
|
/// You must put this attribute on both cases of the discriminated union, with opposite values in each case.
|
||||||
|
type ArgumentFlagAttribute (flagValue : bool) =
|
||||||
|
inherit Attribute ()
|
||||||
|
|
||||||
|
/// Attribute placed on a field of a record to specify a different long form from the default. If you place this
|
||||||
|
/// attribute, you won't get the default: ArgFoo would normally be expressed as `--arg-foo`, but if you instead
|
||||||
|
/// say `[<ArgumentLongForm "thingy-blah">]` or `[<ArgumentLongForm "thingy">]`, you instead use `--thingy-blah`
|
||||||
|
/// or `--thingy` respectively.
|
||||||
|
///
|
||||||
|
/// You can place this argument multiple times.
|
||||||
|
///
|
||||||
|
/// Omit the initial `--` that you expect the user to type.
|
||||||
|
[<AttributeUsage(AttributeTargets.Field, AllowMultiple = true)>]
|
||||||
|
type ArgumentLongForm (s : string) =
|
||||||
|
inherit Attribute ()
|
||||||
|
@@ -7,8 +7,12 @@ WoofWare.Myriad.Plugins.ArgumentDefaultEnvironmentVariableAttribute inherit Syst
|
|||||||
WoofWare.Myriad.Plugins.ArgumentDefaultEnvironmentVariableAttribute..ctor [constructor]: string
|
WoofWare.Myriad.Plugins.ArgumentDefaultEnvironmentVariableAttribute..ctor [constructor]: string
|
||||||
WoofWare.Myriad.Plugins.ArgumentDefaultFunctionAttribute inherit System.Attribute
|
WoofWare.Myriad.Plugins.ArgumentDefaultFunctionAttribute inherit System.Attribute
|
||||||
WoofWare.Myriad.Plugins.ArgumentDefaultFunctionAttribute..ctor [constructor]: unit
|
WoofWare.Myriad.Plugins.ArgumentDefaultFunctionAttribute..ctor [constructor]: unit
|
||||||
|
WoofWare.Myriad.Plugins.ArgumentFlagAttribute inherit System.Attribute
|
||||||
|
WoofWare.Myriad.Plugins.ArgumentFlagAttribute..ctor [constructor]: bool
|
||||||
WoofWare.Myriad.Plugins.ArgumentHelpTextAttribute inherit System.Attribute
|
WoofWare.Myriad.Plugins.ArgumentHelpTextAttribute inherit System.Attribute
|
||||||
WoofWare.Myriad.Plugins.ArgumentHelpTextAttribute..ctor [constructor]: string
|
WoofWare.Myriad.Plugins.ArgumentHelpTextAttribute..ctor [constructor]: string
|
||||||
|
WoofWare.Myriad.Plugins.ArgumentLongForm inherit System.Attribute
|
||||||
|
WoofWare.Myriad.Plugins.ArgumentLongForm..ctor [constructor]: string
|
||||||
WoofWare.Myriad.Plugins.CreateCatamorphismAttribute inherit System.Attribute
|
WoofWare.Myriad.Plugins.CreateCatamorphismAttribute inherit System.Attribute
|
||||||
WoofWare.Myriad.Plugins.CreateCatamorphismAttribute..ctor [constructor]: string
|
WoofWare.Myriad.Plugins.CreateCatamorphismAttribute..ctor [constructor]: string
|
||||||
WoofWare.Myriad.Plugins.GenerateMockAttribute inherit System.Attribute
|
WoofWare.Myriad.Plugins.GenerateMockAttribute inherit System.Attribute
|
||||||
@@ -36,7 +40,10 @@ WoofWare.Myriad.Plugins.JsonSerializeAttribute.get_DefaultIsExtensionMethod [sta
|
|||||||
WoofWare.Myriad.Plugins.ParseExactAttribute inherit System.Attribute
|
WoofWare.Myriad.Plugins.ParseExactAttribute inherit System.Attribute
|
||||||
WoofWare.Myriad.Plugins.ParseExactAttribute..ctor [constructor]: string
|
WoofWare.Myriad.Plugins.ParseExactAttribute..ctor [constructor]: string
|
||||||
WoofWare.Myriad.Plugins.PositionalArgsAttribute inherit System.Attribute
|
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..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 inherit System.Attribute
|
||||||
WoofWare.Myriad.Plugins.RemoveOptionsAttribute..ctor [constructor]: unit
|
WoofWare.Myriad.Plugins.RemoveOptionsAttribute..ctor [constructor]: unit
|
||||||
WoofWare.Myriad.Plugins.RestEase inherit obj
|
WoofWare.Myriad.Plugins.RestEase inherit obj
|
||||||
|
@@ -18,7 +18,7 @@
|
|||||||
|
|
||||||
<ItemGroup>
|
<ItemGroup>
|
||||||
<PackageReference Include="ApiSurface" Version="4.1.5" />
|
<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="NUnit" Version="4.2.2"/>
|
||||||
<PackageReference Include="NUnit3TestAdapter" Version="4.6.0"/>
|
<PackageReference Include="NUnit3TestAdapter" Version="4.6.0"/>
|
||||||
</ItemGroup>
|
</ItemGroup>
|
||||||
|
@@ -1,5 +1,5 @@
|
|||||||
{
|
{
|
||||||
"version": "3.2",
|
"version": "3.5",
|
||||||
"publicReleaseRefSpec": [
|
"publicReleaseRefSpec": [
|
||||||
"^refs/heads/main$"
|
"^refs/heads/main$"
|
||||||
],
|
],
|
||||||
@@ -12,4 +12,4 @@
|
|||||||
"./",
|
"./",
|
||||||
":^Test"
|
":^Test"
|
||||||
]
|
]
|
||||||
}
|
}
|
@@ -367,18 +367,19 @@ Required argument '--exact' received no value"""
|
|||||||
let parsed =
|
let parsed =
|
||||||
ParentRecordChildPos.parse'
|
ParentRecordChildPos.parse'
|
||||||
getEnvVar
|
getEnvVar
|
||||||
[ "--and-another=true" ; "--thing1=9" ; "--thing2=some" ; "--thing2=thing" ]
|
[
|
||||||
|
"--and-another=true"
|
||||||
|
"--thing1=9"
|
||||||
|
"--thing2=https://example.com"
|
||||||
|
"--thing2=http://example.com"
|
||||||
|
]
|
||||||
|
|
||||||
parsed
|
parsed.AndAnother |> shouldEqual true
|
||||||
|> shouldEqual
|
parsed.Child.Thing1 |> shouldEqual 9
|
||||||
{
|
|
||||||
Child =
|
parsed.Child.Thing2
|
||||||
{
|
|> List.map (fun (x : Uri) -> x.ToString ())
|
||||||
Thing1 = 9
|
|> shouldEqual [ "https://example.com/" ; "http://example.com/" ]
|
||||||
Thing2 = [ "some" ; "thing" ]
|
|
||||||
}
|
|
||||||
AndAnother = true
|
|
||||||
}
|
|
||||||
|
|
||||||
[<Test>]
|
[<Test>]
|
||||||
let ``Can consume stacked record, child has no positionals, parent has positionals`` () =
|
let ``Can consume stacked record, child has no positionals, parent has positionals`` () =
|
||||||
@@ -431,3 +432,275 @@ Required argument '--exact' received no value"""
|
|||||||
{
|
{
|
||||||
Args = [ Choice1Of2 "a" ; Choice1Of2 "b" ; Choice2Of2 "--c" ; Choice2Of2 "--help" ]
|
Args = [ Choice1Of2 "a" ; Choice1Of2 "b" ; Choice2Of2 "--c" ; Choice2Of2 "--help" ]
|
||||||
}
|
}
|
||||||
|
|
||||||
|
let boolCases =
|
||||||
|
[
|
||||||
|
"1", true
|
||||||
|
"0", false
|
||||||
|
"true", true
|
||||||
|
"false", false
|
||||||
|
"TRUE", true
|
||||||
|
"FALSE", false
|
||||||
|
]
|
||||||
|
|> List.map TestCaseData
|
||||||
|
|
||||||
|
[<TestCaseSource(nameof (boolCases))>]
|
||||||
|
let ``Bool env vars can be populated`` (envValue : string, boolValue : bool) =
|
||||||
|
let getEnvVar (s : string) =
|
||||||
|
s |> shouldEqual "CONSUMEPLUGIN_THINGS"
|
||||||
|
envValue
|
||||||
|
|
||||||
|
ContainsBoolEnvVar.parse' getEnvVar []
|
||||||
|
|> shouldEqual
|
||||||
|
{
|
||||||
|
BoolVar = Choice2Of2 boolValue
|
||||||
|
}
|
||||||
|
|
||||||
|
[<Test>]
|
||||||
|
let ``Bools can be treated with arity 0`` () =
|
||||||
|
let getEnvVar (_ : string) = failwith "do not call"
|
||||||
|
|
||||||
|
ContainsBoolEnvVar.parse' getEnvVar [ "--bool-var" ]
|
||||||
|
|> shouldEqual
|
||||||
|
{
|
||||||
|
BoolVar = Choice1Of2 true
|
||||||
|
}
|
||||||
|
|
||||||
|
[<TestCaseSource(nameof boolCases)>]
|
||||||
|
let ``Flag DUs can be parsed from env var`` (envValue : string, boolValue : bool) =
|
||||||
|
let getEnvVar (s : string) =
|
||||||
|
s |> shouldEqual "CONSUMEPLUGIN_THINGS"
|
||||||
|
envValue
|
||||||
|
|
||||||
|
let boolValue = if boolValue then DryRunMode.Dry else DryRunMode.Wet
|
||||||
|
|
||||||
|
ContainsFlagEnvVar.parse' getEnvVar []
|
||||||
|
|> shouldEqual
|
||||||
|
{
|
||||||
|
DryRun = Choice2Of2 boolValue
|
||||||
|
}
|
||||||
|
|
||||||
|
let dryRunData =
|
||||||
|
[
|
||||||
|
[ "--dry-run" ], DryRunMode.Dry
|
||||||
|
[ "--dry-run" ; "true" ], DryRunMode.Dry
|
||||||
|
[ "--dry-run=true" ], DryRunMode.Dry
|
||||||
|
[ "--dry-run" ; "True" ], DryRunMode.Dry
|
||||||
|
[ "--dry-run=True" ], DryRunMode.Dry
|
||||||
|
[ "--dry-run" ; "false" ], DryRunMode.Wet
|
||||||
|
[ "--dry-run=false" ], DryRunMode.Wet
|
||||||
|
[ "--dry-run" ; "False" ], DryRunMode.Wet
|
||||||
|
[ "--dry-run=False" ], DryRunMode.Wet
|
||||||
|
]
|
||||||
|
|> List.map TestCaseData
|
||||||
|
|
||||||
|
[<TestCaseSource(nameof dryRunData)>]
|
||||||
|
let ``Flag DUs can be parsed`` (args : string list, expected : DryRunMode) =
|
||||||
|
let getEnvVar (_ : string) = failwith "do not call"
|
||||||
|
|
||||||
|
ContainsFlagEnvVar.parse' getEnvVar args
|
||||||
|
|> shouldEqual
|
||||||
|
{
|
||||||
|
DryRun = Choice1Of2 expected
|
||||||
|
}
|
||||||
|
|
||||||
|
[<TestCaseSource(nameof dryRunData)>]
|
||||||
|
let ``Flag DUs can be parsed, ArgumentDefaultFunction`` (args : string list, expected : DryRunMode) =
|
||||||
|
let getEnvVar (_ : string) = failwith "do not call"
|
||||||
|
|
||||||
|
ContainsFlagDefaultValue.parse' getEnvVar args
|
||||||
|
|> shouldEqual
|
||||||
|
{
|
||||||
|
DryRun = Choice1Of2 expected
|
||||||
|
}
|
||||||
|
|
||||||
|
[<Test>]
|
||||||
|
let ``Flag DUs can be given a default value`` () =
|
||||||
|
let getEnvVar (_ : string) = failwith "do not call"
|
||||||
|
|
||||||
|
ContainsFlagDefaultValue.parse' getEnvVar []
|
||||||
|
|> shouldEqual
|
||||||
|
{
|
||||||
|
DryRun = Choice2Of2 DryRunMode.Wet
|
||||||
|
}
|
||||||
|
|
||||||
|
[<Test>]
|
||||||
|
let ``Help text for flag DU`` () =
|
||||||
|
let getEnvVar (_ : string) = failwith "do not call"
|
||||||
|
|
||||||
|
let exc =
|
||||||
|
Assert.Throws<exn> (fun () ->
|
||||||
|
ContainsFlagDefaultValue.parse' getEnvVar [ "--help" ]
|
||||||
|
|> ignore<ContainsFlagDefaultValue>
|
||||||
|
)
|
||||||
|
|
||||||
|
exc.Message
|
||||||
|
|> shouldEqual
|
||||||
|
"""Help text requested.
|
||||||
|
--dry-run bool (default value: false)"""
|
||||||
|
|
||||||
|
[<Test>]
|
||||||
|
let ``Help text for flag DU, non default`` () =
|
||||||
|
let getEnvVar (_ : string) = failwith "do not call"
|
||||||
|
|
||||||
|
let exc =
|
||||||
|
Assert.Throws<exn> (fun () -> WithFlagDu.parse' getEnvVar [ "--help" ] |> ignore<WithFlagDu>)
|
||||||
|
|
||||||
|
exc.Message
|
||||||
|
|> shouldEqual
|
||||||
|
"""Help text requested.
|
||||||
|
--dry-run bool"""
|
||||||
|
|
||||||
|
let longFormCases =
|
||||||
|
let doTheThing =
|
||||||
|
[
|
||||||
|
[ "--do-something-else=foo" ]
|
||||||
|
[ "--anotherarg=foo" ]
|
||||||
|
[ "--do-something-else" ; "foo" ]
|
||||||
|
[ "--anotherarg" ; "foo" ]
|
||||||
|
]
|
||||||
|
|
||||||
|
let someFlag =
|
||||||
|
[
|
||||||
|
[ "--turn-it-on" ], true
|
||||||
|
[ "--dont-turn-it-off" ], true
|
||||||
|
[ "--turn-it-on=true" ], true
|
||||||
|
[ "--dont-turn-it-off=true" ], true
|
||||||
|
[ "--turn-it-on=false" ], false
|
||||||
|
[ "--dont-turn-it-off=false" ], false
|
||||||
|
[ "--turn-it-on" ; "true" ], true
|
||||||
|
[ "--dont-turn-it-off" ; "true" ], true
|
||||||
|
[ "--turn-it-on" ; "false" ], false
|
||||||
|
[ "--dont-turn-it-off" ; "false" ], false
|
||||||
|
]
|
||||||
|
|
||||||
|
List.allPairs doTheThing someFlag
|
||||||
|
|> List.map (fun (doTheThing, (someFlag, someFlagResult)) ->
|
||||||
|
let args = doTheThing @ someFlag
|
||||||
|
|
||||||
|
let expected =
|
||||||
|
{
|
||||||
|
DoTheThing = "foo"
|
||||||
|
SomeFlag = someFlagResult
|
||||||
|
}
|
||||||
|
|
||||||
|
args, expected
|
||||||
|
)
|
||||||
|
|> List.map TestCaseData
|
||||||
|
|
||||||
|
[<TestCaseSource(nameof longFormCases)>]
|
||||||
|
let ``Long-form args`` (args : string list, expected : ManyLongForms) =
|
||||||
|
let getEnvVar (_ : string) = failwith "do not call"
|
||||||
|
|
||||||
|
ManyLongForms.parse' getEnvVar args |> shouldEqual expected
|
||||||
|
|
||||||
|
[<Test>]
|
||||||
|
let ``Long-form args can't be referred to by their original name`` () =
|
||||||
|
let getEnvVar (_ : string) = failwith "do not call"
|
||||||
|
|
||||||
|
let exc =
|
||||||
|
Assert.Throws<exn> (fun () ->
|
||||||
|
ManyLongForms.parse' getEnvVar [ "--do-the-thing=foo" ] |> ignore<ManyLongForms>
|
||||||
|
)
|
||||||
|
|
||||||
|
exc.Message
|
||||||
|
|> shouldEqual """Unable to process argument --do-the-thing=foo as key --do-the-thing and value foo"""
|
||||||
|
|
||||||
|
[<Test>]
|
||||||
|
let ``Long-form args help text`` () =
|
||||||
|
let getEnvVar (_ : string) = failwith "do not call"
|
||||||
|
|
||||||
|
let exc =
|
||||||
|
Assert.Throws<exn> (fun () -> ManyLongForms.parse' getEnvVar [ "--help" ] |> ignore<ManyLongForms>)
|
||||||
|
|
||||||
|
exc.Message
|
||||||
|
|> shouldEqual
|
||||||
|
"""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"""
|
||||||
|
@@ -42,7 +42,7 @@
|
|||||||
<PackageReference Include="ApiSurface" Version="4.1.5"/>
|
<PackageReference Include="ApiSurface" Version="4.1.5"/>
|
||||||
<PackageReference Include="FsCheck" Version="2.16.6"/>
|
<PackageReference Include="FsCheck" Version="2.16.6"/>
|
||||||
<PackageReference Include="FsUnit" Version="6.0.0"/>
|
<PackageReference Include="FsUnit" Version="6.0.0"/>
|
||||||
<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="NUnit" Version="4.2.2"/>
|
||||||
<PackageReference Include="NUnit3TestAdapter" Version="4.6.0"/>
|
<PackageReference Include="NUnit3TestAdapter" Version="4.6.0"/>
|
||||||
</ItemGroup>
|
</ItemGroup>
|
||||||
|
@@ -12,6 +12,23 @@ type internal ArgParserOutputSpec =
|
|||||||
ExtensionMethods : bool
|
ExtensionMethods : bool
|
||||||
}
|
}
|
||||||
|
|
||||||
|
type internal FlagDu =
|
||||||
|
{
|
||||||
|
Name : Ident
|
||||||
|
Case1Name : Ident
|
||||||
|
Case2Name : Ident
|
||||||
|
/// Hopefully this is simply the const bool True or False, but it might e.g. be a literal
|
||||||
|
Case1Arg : SynExpr
|
||||||
|
/// Hopefully this is simply the const bool True or False, but it might e.g. be a literal
|
||||||
|
Case2Arg : SynExpr
|
||||||
|
}
|
||||||
|
|
||||||
|
static member FromBoolean (flagDu : FlagDu) (value : SynExpr) =
|
||||||
|
SynExpr.ifThenElse
|
||||||
|
(SynExpr.equals value flagDu.Case1Arg)
|
||||||
|
(SynExpr.createLongIdent' [ flagDu.Name ; flagDu.Case2Name ])
|
||||||
|
(SynExpr.createLongIdent' [ flagDu.Name ; flagDu.Case1Name ])
|
||||||
|
|
||||||
/// The default value of an argument which admits default values can be pulled from different sources.
|
/// The default value of an argument which admits default values can be pulled from different sources.
|
||||||
/// This defines which source a particular default value comes from.
|
/// This defines which source a particular default value comes from.
|
||||||
type private ArgumentDefaultSpec =
|
type private ArgumentDefaultSpec =
|
||||||
@@ -20,6 +37,7 @@ type private ArgumentDefaultSpec =
|
|||||||
/// From calling the static member `{typeWeParseInto}.Default{name}()`
|
/// From calling the static member `{typeWeParseInto}.Default{name}()`
|
||||||
/// For example, if `type MyArgs = { Thing : Choice<int, int> }`, then
|
/// For example, if `type MyArgs = { Thing : Choice<int, int> }`, then
|
||||||
/// we would use `MyArgs.DefaultThing () : int`.
|
/// we would use `MyArgs.DefaultThing () : int`.
|
||||||
|
///
|
||||||
| FunctionCall of name : Ident
|
| FunctionCall of name : Ident
|
||||||
|
|
||||||
type private Accumulation<'choice> =
|
type private Accumulation<'choice> =
|
||||||
@@ -32,7 +50,18 @@ type private ParseFunction<'acc> =
|
|||||||
{
|
{
|
||||||
FieldName : Ident
|
FieldName : Ident
|
||||||
TargetVariable : Ident
|
TargetVariable : Ident
|
||||||
ArgForm : string
|
/// Any of the forms in this set are acceptable, but make sure they all start with a dash, or we might
|
||||||
|
/// get confused with positional args or something! I haven't thought that hard about this.
|
||||||
|
/// In the default case, this is `Const("arg-name")` for the `ArgName : blah` field; note that we have
|
||||||
|
/// omitted the initial `--` that will be required at runtime.
|
||||||
|
ArgForm : SynExpr list
|
||||||
|
/// If this is a boolean-like field (e.g. a bool or a flag DU), the help text should look a bit different:
|
||||||
|
/// we should lie to the user about the value of the cases there.
|
||||||
|
/// Similarly, if we're reading from an environment variable with the laxer parsing rules of accepting e.g.
|
||||||
|
/// "0" instead of "false", we need to know if we're reading a bool.
|
||||||
|
/// In that case, `boolCases` is Some, and contains the construction of the flag (or boolean, in which case
|
||||||
|
/// you get no data).
|
||||||
|
BoolCases : Choice<FlagDu, unit> option
|
||||||
Help : SynExpr option
|
Help : SynExpr option
|
||||||
/// A function string -> %TargetType%, where TargetVariable is probably a `%TargetType% option`.
|
/// A function string -> %TargetType%, where TargetVariable is probably a `%TargetType% option`.
|
||||||
/// (Depending on `Accumulation`, we'll remove the `option` at the end of the parse, asserting that the
|
/// (Depending on `Accumulation`, we'll remove the `option` at the end of the parse, asserting that the
|
||||||
@@ -45,10 +74,19 @@ type private ParseFunction<'acc> =
|
|||||||
Accumulation : 'acc
|
Accumulation : 'acc
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/// A SynExpr of type `string` which we can display to the user at generated-program runtime to display all
|
||||||
|
/// the ways they can refer to this arg.
|
||||||
|
member arg.HumanReadableArgForm : SynExpr =
|
||||||
|
let formatString = List.replicate arg.ArgForm.Length "--%s" |> String.concat " / "
|
||||||
|
|
||||||
|
(SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst formatString), arg.ArgForm)
|
||||||
|
||> List.fold SynExpr.applyFunction
|
||||||
|
|> SynExpr.paren
|
||||||
|
|
||||||
[<RequireQualifiedAccess>]
|
[<RequireQualifiedAccess>]
|
||||||
type private ChoicePositional =
|
type private ChoicePositional =
|
||||||
| Normal
|
| Normal of includeFlagLike : SynExpr option
|
||||||
| Choice
|
| Choice of includeFlagLike : SynExpr option
|
||||||
|
|
||||||
type private ParseFunctionPositional = ParseFunction<ChoicePositional>
|
type private ParseFunctionPositional = ParseFunction<ChoicePositional>
|
||||||
type private ParseFunctionNonPositional = ParseFunction<Accumulation<ArgumentDefaultSpec>>
|
type private ParseFunctionNonPositional = ParseFunction<Accumulation<ArgumentDefaultSpec>>
|
||||||
@@ -185,7 +223,15 @@ module private ParseTree =
|
|||||||
|
|
||||||
|> fun (nonPos, pos) ->
|
|> fun (nonPos, pos) ->
|
||||||
let duplicateArgs =
|
let duplicateArgs =
|
||||||
|
// This is best-effort. We can't necessarily detect all SynExprs here, but usually it'll be strings.
|
||||||
Option.toList (pos |> Option.map _.ArgForm) @ (nonPos |> List.map _.ArgForm)
|
Option.toList (pos |> Option.map _.ArgForm) @ (nonPos |> List.map _.ArgForm)
|
||||||
|
|> Seq.concat
|
||||||
|
|> Seq.choose (fun expr ->
|
||||||
|
match expr |> SynExpr.stripOptionalParen with
|
||||||
|
| SynExpr.Const (SynConst.String (s, _, _), _) -> Some s
|
||||||
|
| _ -> None
|
||||||
|
)
|
||||||
|
|> List.ofSeq
|
||||||
|> List.groupBy id
|
|> List.groupBy id
|
||||||
|> List.choose (fun (key, v) -> if v.Length > 1 then Some key else None)
|
|> List.choose (fun (key, v) -> if v.Length > 1 then Some key else None)
|
||||||
|
|
||||||
@@ -226,7 +272,6 @@ module internal ArgParserGenerator =
|
|||||||
/// Convert e.g. "Foo" into "--foo".
|
/// Convert e.g. "Foo" into "--foo".
|
||||||
let argify (ident : Ident) : string =
|
let argify (ident : Ident) : string =
|
||||||
let result = StringBuilder ()
|
let result = StringBuilder ()
|
||||||
result.Append "-" |> ignore<StringBuilder>
|
|
||||||
|
|
||||||
for c in ident.idText do
|
for c in ident.idText do
|
||||||
if Char.IsUpper c then
|
if Char.IsUpper c then
|
||||||
@@ -234,7 +279,18 @@ module internal ArgParserGenerator =
|
|||||||
else
|
else
|
||||||
result.Append c |> ignore<StringBuilder>
|
result.Append c |> ignore<StringBuilder>
|
||||||
|
|
||||||
result.ToString ()
|
result.ToString().TrimStart '-'
|
||||||
|
|
||||||
|
let private identifyAsFlag (flagDus : FlagDu list) (ty : SynType) : FlagDu option =
|
||||||
|
match ty with
|
||||||
|
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) ->
|
||||||
|
flagDus
|
||||||
|
|> List.tryPick (fun du ->
|
||||||
|
let duName = du.Name.idText
|
||||||
|
let ident = List.last(ident).idText
|
||||||
|
if duName = ident then Some du else None
|
||||||
|
)
|
||||||
|
| _ -> None
|
||||||
|
|
||||||
/// Builds a function or lambda of one string argument, which returns a `ty` (as modified by the `Accumulation`;
|
/// Builds a function or lambda of one string argument, which returns a `ty` (as modified by the `Accumulation`;
|
||||||
/// for example, maybe it returns a `ty option` or a `ty list`).
|
/// for example, maybe it returns a `ty option` or a `ty list`).
|
||||||
@@ -242,6 +298,7 @@ module internal ArgParserGenerator =
|
|||||||
/// is the list element.
|
/// is the list element.
|
||||||
let rec private createParseFunction<'choice>
|
let rec private createParseFunction<'choice>
|
||||||
(choice : ArgumentDefaultSpec option -> 'choice)
|
(choice : ArgumentDefaultSpec option -> 'choice)
|
||||||
|
(flagDus : FlagDu list)
|
||||||
(fieldName : Ident)
|
(fieldName : Ident)
|
||||||
(attrs : SynAttribute list)
|
(attrs : SynAttribute list)
|
||||||
(ty : SynType)
|
(ty : SynType)
|
||||||
@@ -257,6 +314,12 @@ module internal ArgParserGenerator =
|
|||||||
(SynExpr.createIdent "x")),
|
(SynExpr.createIdent "x")),
|
||||||
Accumulation.Required,
|
Accumulation.Required,
|
||||||
ty
|
ty
|
||||||
|
| Uri ->
|
||||||
|
SynExpr.createLambda
|
||||||
|
"x"
|
||||||
|
(SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "Uri" ]) (SynExpr.createIdent "x")),
|
||||||
|
Accumulation.Required,
|
||||||
|
ty
|
||||||
| TimeSpan ->
|
| TimeSpan ->
|
||||||
let parseExact =
|
let parseExact =
|
||||||
attrs
|
attrs
|
||||||
@@ -328,7 +391,8 @@ module internal ArgParserGenerator =
|
|||||||
Accumulation.Required,
|
Accumulation.Required,
|
||||||
ty
|
ty
|
||||||
| OptionType eltTy ->
|
| OptionType eltTy ->
|
||||||
let parseElt, acc, childTy = createParseFunction choice fieldName attrs eltTy
|
let parseElt, acc, childTy =
|
||||||
|
createParseFunction choice flagDus fieldName attrs eltTy
|
||||||
|
|
||||||
match acc with
|
match acc with
|
||||||
| Accumulation.Optional ->
|
| Accumulation.Optional ->
|
||||||
@@ -347,7 +411,7 @@ module internal ArgParserGenerator =
|
|||||||
failwith
|
failwith
|
||||||
$"ArgParser was unable to prove types %O{elt1} and %O{elt2} to be equal in a Choice. We require them to be equal."
|
$"ArgParser was unable to prove types %O{elt1} and %O{elt2} to be equal in a Choice. We require them to be equal."
|
||||||
|
|
||||||
let parseElt, acc, childTy = createParseFunction choice fieldName attrs elt1
|
let parseElt, acc, childTy = createParseFunction choice flagDus fieldName attrs elt1
|
||||||
|
|
||||||
match acc with
|
match acc with
|
||||||
| Accumulation.Optional ->
|
| Accumulation.Optional ->
|
||||||
@@ -385,6 +449,7 @@ module internal ArgParserGenerator =
|
|||||||
| [ "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariableAttribute" ]
|
| [ "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariableAttribute" ]
|
||||||
| [ "WoofWare" ; "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariable" ]
|
| [ "WoofWare" ; "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariable" ]
|
||||||
| [ "WoofWare" ; "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariableAttribute" ] ->
|
| [ "WoofWare" ; "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariableAttribute" ] ->
|
||||||
|
|
||||||
ArgumentDefaultSpec.EnvironmentVariable attr.ArgExpr |> Some
|
ArgumentDefaultSpec.EnvironmentVariable attr.ArgExpr |> Some
|
||||||
| _ -> None
|
| _ -> None
|
||||||
)
|
)
|
||||||
@@ -404,13 +469,26 @@ module internal ArgParserGenerator =
|
|||||||
failwith
|
failwith
|
||||||
$"ArgParser requires Choice to be of the form Choice<'a, 'a>; that is, two arguments, both the same. For field %s{fieldName.idText}, got: %s{elts}"
|
$"ArgParser requires Choice to be of the form Choice<'a, 'a>; that is, two arguments, both the same. For field %s{fieldName.idText}, got: %s{elts}"
|
||||||
| ListType eltTy ->
|
| ListType eltTy ->
|
||||||
let parseElt, acc, childTy = createParseFunction choice fieldName attrs eltTy
|
let parseElt, acc, childTy =
|
||||||
|
createParseFunction choice flagDus fieldName attrs eltTy
|
||||||
|
|
||||||
parseElt, Accumulation.List acc, childTy
|
parseElt, Accumulation.List acc, childTy
|
||||||
| _ -> failwith $"Could not decide how to parse arguments for field %s{fieldName.idText} of type %O{ty}"
|
| ty ->
|
||||||
|
match identifyAsFlag flagDus ty with
|
||||||
|
| None -> failwith $"Could not decide how to parse arguments for field %s{fieldName.idText} of type %O{ty}"
|
||||||
|
| Some flagDu ->
|
||||||
|
// Parse as a bool, and then do the `if-then` dance.
|
||||||
|
let parser =
|
||||||
|
SynExpr.createIdent "x"
|
||||||
|
|> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "Boolean" ; "Parse" ])
|
||||||
|
|> FlagDu.FromBoolean flagDu
|
||||||
|
|> SynExpr.createLambda "x"
|
||||||
|
|
||||||
|
parser, Accumulation.Required, ty
|
||||||
|
|
||||||
let rec private toParseSpec
|
let rec private toParseSpec
|
||||||
(counter : int)
|
(counter : int)
|
||||||
|
(flagDus : FlagDu list)
|
||||||
(ambientRecords : RecordType list)
|
(ambientRecords : RecordType list)
|
||||||
(finalRecord : RecordType)
|
(finalRecord : RecordType)
|
||||||
: ParseTreeCrate * int
|
: ParseTreeCrate * int
|
||||||
@@ -428,11 +506,14 @@ module internal ArgParserGenerator =
|
|||||||
|
|
||||||
let positionalArgAttr =
|
let positionalArgAttr =
|
||||||
attrs
|
attrs
|
||||||
|> List.tryFind (fun a ->
|
|> List.tryPick (fun a ->
|
||||||
match (List.last a.TypeName.LongIdent).idText with
|
match (List.last a.TypeName.LongIdent).idText with
|
||||||
| "PositionalArgsAttribute"
|
| "PositionalArgsAttribute"
|
||||||
| "PositionalArgs" -> true
|
| "PositionalArgs" ->
|
||||||
| _ -> false
|
match a.ArgExpr with
|
||||||
|
| SynExpr.Const (SynConst.Unit, _) -> Some None
|
||||||
|
| a -> Some (Some a)
|
||||||
|
| _ -> None
|
||||||
)
|
)
|
||||||
|
|
||||||
let parseExactModifier =
|
let parseExactModifier =
|
||||||
@@ -473,6 +554,20 @@ module internal ArgParserGenerator =
|
|||||||
| None -> failwith "expected args field to have a name, but it did not"
|
| None -> failwith "expected args field to have a name, but it did not"
|
||||||
| Some i -> i
|
| Some i -> i
|
||||||
|
|
||||||
|
let longForms =
|
||||||
|
attrs
|
||||||
|
|> List.choose (fun attr ->
|
||||||
|
match attr.TypeName with
|
||||||
|
| SynLongIdent.SynLongIdent (ident, _, _) ->
|
||||||
|
if (List.last ident).idText = "ArgumentLongForm" then
|
||||||
|
Some attr.ArgExpr
|
||||||
|
else
|
||||||
|
None
|
||||||
|
)
|
||||||
|
|> function
|
||||||
|
| [] -> List.singleton (SynExpr.CreateConst (argify ident))
|
||||||
|
| l -> List.ofSeq l
|
||||||
|
|
||||||
let ambientRecordMatch =
|
let ambientRecordMatch =
|
||||||
match fieldType with
|
match fieldType with
|
||||||
| SynType.LongIdent (SynLongIdent.SynLongIdent (id, _, _)) ->
|
| SynType.LongIdent (SynLongIdent.SynLongIdent (id, _, _)) ->
|
||||||
@@ -483,12 +578,12 @@ module internal ArgParserGenerator =
|
|||||||
match ambientRecordMatch with
|
match ambientRecordMatch with
|
||||||
| Some ambient ->
|
| Some ambient ->
|
||||||
// This field has a type we need to obtain from parsing another record.
|
// This field has a type we need to obtain from parsing another record.
|
||||||
let spec, counter = toParseSpec counter ambientRecords ambient
|
let spec, counter = toParseSpec counter flagDus ambientRecords ambient
|
||||||
counter, (ident, spec) :: acc
|
counter, (ident, spec) :: acc
|
||||||
| None ->
|
| None ->
|
||||||
|
|
||||||
match positionalArgAttr with
|
match positionalArgAttr with
|
||||||
| Some _ ->
|
| Some includeFlagLike ->
|
||||||
let getChoice (spec : ArgumentDefaultSpec option) : unit =
|
let getChoice (spec : ArgumentDefaultSpec option) : unit =
|
||||||
match spec with
|
match spec with
|
||||||
| Some _ ->
|
| Some _ ->
|
||||||
@@ -497,7 +592,13 @@ module internal ArgParserGenerator =
|
|||||||
| None -> ()
|
| None -> ()
|
||||||
|
|
||||||
let parser, accumulation, parseTy =
|
let parser, accumulation, parseTy =
|
||||||
createParseFunction<unit> getChoice ident attrs fieldType
|
createParseFunction<unit> getChoice flagDus ident attrs fieldType
|
||||||
|
|
||||||
|
let isBoolLike =
|
||||||
|
match parseTy with
|
||||||
|
| PrimitiveType ident when ident |> List.map _.idText = [ "System" ; "Boolean" ] ->
|
||||||
|
Some (Choice2Of2 ())
|
||||||
|
| parseTy -> identifyAsFlag flagDus parseTy |> Option.map Choice1Of2
|
||||||
|
|
||||||
match accumulation with
|
match accumulation with
|
||||||
| Accumulation.List (Accumulation.List _) ->
|
| Accumulation.List (Accumulation.List _) ->
|
||||||
@@ -509,10 +610,11 @@ module internal ArgParserGenerator =
|
|||||||
FieldName = ident
|
FieldName = ident
|
||||||
Parser = parser
|
Parser = parser
|
||||||
TargetVariable = Ident.create $"arg_%i{counter}"
|
TargetVariable = Ident.create $"arg_%i{counter}"
|
||||||
Accumulation = ChoicePositional.Choice
|
Accumulation = ChoicePositional.Choice includeFlagLike
|
||||||
TargetType = parseTy
|
TargetType = parseTy
|
||||||
ArgForm = argify ident
|
ArgForm = longForms
|
||||||
Help = helpText
|
Help = helpText
|
||||||
|
BoolCases = isBoolLike
|
||||||
}
|
}
|
||||||
|> fun t -> ParseTree.PositionalLeaf (t, Teq.refl)
|
|> fun t -> ParseTree.PositionalLeaf (t, Teq.refl)
|
||||||
| Accumulation.List Accumulation.Required ->
|
| Accumulation.List Accumulation.Required ->
|
||||||
@@ -520,10 +622,11 @@ module internal ArgParserGenerator =
|
|||||||
FieldName = ident
|
FieldName = ident
|
||||||
Parser = parser
|
Parser = parser
|
||||||
TargetVariable = Ident.create $"arg_%i{counter}"
|
TargetVariable = Ident.create $"arg_%i{counter}"
|
||||||
Accumulation = ChoicePositional.Normal
|
Accumulation = ChoicePositional.Normal includeFlagLike
|
||||||
TargetType = parseTy
|
TargetType = parseTy
|
||||||
ArgForm = argify ident
|
ArgForm = longForms
|
||||||
Help = helpText
|
Help = helpText
|
||||||
|
BoolCases = isBoolLike
|
||||||
}
|
}
|
||||||
|> fun t -> ParseTree.PositionalLeaf (t, Teq.refl)
|
|> fun t -> ParseTree.PositionalLeaf (t, Teq.refl)
|
||||||
| Accumulation.Choice _
|
| Accumulation.Choice _
|
||||||
@@ -540,7 +643,13 @@ module internal ArgParserGenerator =
|
|||||||
| Some spec -> spec
|
| Some spec -> spec
|
||||||
|
|
||||||
let parser, accumulation, parseTy =
|
let parser, accumulation, parseTy =
|
||||||
createParseFunction getChoice ident attrs fieldType
|
createParseFunction getChoice flagDus ident attrs fieldType
|
||||||
|
|
||||||
|
let isBoolLike =
|
||||||
|
match parseTy with
|
||||||
|
| PrimitiveType ident when ident |> List.map _.idText = [ "System" ; "Boolean" ] ->
|
||||||
|
Some (Choice2Of2 ())
|
||||||
|
| parseTy -> identifyAsFlag flagDus parseTy |> Option.map Choice1Of2
|
||||||
|
|
||||||
{
|
{
|
||||||
FieldName = ident
|
FieldName = ident
|
||||||
@@ -548,8 +657,9 @@ module internal ArgParserGenerator =
|
|||||||
TargetVariable = Ident.create $"arg_%i{counter}"
|
TargetVariable = Ident.create $"arg_%i{counter}"
|
||||||
Accumulation = accumulation
|
Accumulation = accumulation
|
||||||
TargetType = parseTy
|
TargetType = parseTy
|
||||||
ArgForm = argify ident
|
ArgForm = longForms
|
||||||
Help = helpText
|
Help = helpText
|
||||||
|
BoolCases = isBoolLike
|
||||||
}
|
}
|
||||||
|> fun t -> ParseTree.NonPositionalLeaf (t, Teq.refl)
|
|> fun t -> ParseTree.NonPositionalLeaf (t, Teq.refl)
|
||||||
|> ParseTreeCrate.make
|
|> ParseTreeCrate.make
|
||||||
@@ -575,7 +685,11 @@ module internal ArgParserGenerator =
|
|||||||
(args : ParseFunctionNonPositional list)
|
(args : ParseFunctionNonPositional list)
|
||||||
: SynBinding
|
: SynBinding
|
||||||
=
|
=
|
||||||
let describeNonPositional (acc : Accumulation<ArgumentDefaultSpec>) : SynExpr =
|
let describeNonPositional
|
||||||
|
(acc : Accumulation<ArgumentDefaultSpec>)
|
||||||
|
(flagCases : Choice<FlagDu, unit> option)
|
||||||
|
: SynExpr
|
||||||
|
=
|
||||||
match acc with
|
match acc with
|
||||||
| Accumulation.Required -> SynExpr.CreateConst ""
|
| Accumulation.Required -> SynExpr.CreateConst ""
|
||||||
| Accumulation.Optional -> SynExpr.CreateConst " (optional)"
|
| Accumulation.Optional -> SynExpr.CreateConst " (optional)"
|
||||||
@@ -590,18 +704,46 @@ module internal ArgParserGenerator =
|
|||||||
)
|
)
|
||||||
|> SynExpr.paren
|
|> SynExpr.paren
|
||||||
| Accumulation.Choice (ArgumentDefaultSpec.FunctionCall var) ->
|
| Accumulation.Choice (ArgumentDefaultSpec.FunctionCall var) ->
|
||||||
SynExpr.callMethod var.idText (SynExpr.createIdent' typeName)
|
match flagCases with
|
||||||
|
| None -> SynExpr.callMethod var.idText (SynExpr.createIdent' typeName)
|
||||||
|
| Some (Choice2Of2 ()) -> SynExpr.callMethod var.idText (SynExpr.createIdent' typeName)
|
||||||
|
| Some (Choice1Of2 flagDu) ->
|
||||||
|
// Care required here. The return value from the Default call is not a bool,
|
||||||
|
// but we should display it as such to the user!
|
||||||
|
[
|
||||||
|
SynMatchClause.create
|
||||||
|
(SynPat.identWithArgs [ flagDu.Name ; flagDu.Case1Name ] (SynArgPats.create []))
|
||||||
|
(SynExpr.ifThenElse
|
||||||
|
(SynExpr.equals flagDu.Case1Arg (SynExpr.CreateConst true))
|
||||||
|
(SynExpr.CreateConst "false")
|
||||||
|
(SynExpr.CreateConst "true"))
|
||||||
|
SynMatchClause.create
|
||||||
|
(SynPat.identWithArgs [ flagDu.Name ; flagDu.Case2Name ] (SynArgPats.create []))
|
||||||
|
(SynExpr.ifThenElse
|
||||||
|
(SynExpr.equals flagDu.Case2Arg (SynExpr.CreateConst true))
|
||||||
|
(SynExpr.CreateConst "false")
|
||||||
|
(SynExpr.CreateConst "true"))
|
||||||
|
]
|
||||||
|
|> SynExpr.createMatch (SynExpr.callMethod var.idText (SynExpr.createIdent' typeName))
|
||||||
|> SynExpr.pipeThroughFunction (
|
|> 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
|
|> SynExpr.paren
|
||||||
| Accumulation.List _ -> SynExpr.CreateConst " (can be repeated)"
|
| Accumulation.List _ -> SynExpr.CreateConst " (can be repeated)"
|
||||||
|
|
||||||
let describePositional _ =
|
let describePositional _ _ =
|
||||||
SynExpr.CreateConst " (positional args) (can be repeated)"
|
SynExpr.CreateConst " (positional args) (can be repeated)"
|
||||||
|
|
||||||
let toPrintable (describe : 'a -> SynExpr) (arg : ParseFunction<'a>) : SynExpr =
|
/// We may sometimes lie about the type name, if e.g. this is a flag DU which we're pretending is a boolean.
|
||||||
let ty = arg.TargetType |> SynType.toHumanReadableString
|
/// So the `renderTypeName` takes the Accumulation which tells us whether we're lying.
|
||||||
|
let toPrintable (describe : 'a -> Choice<FlagDu, unit> option -> SynExpr) (arg : ParseFunction<'a>) : SynExpr =
|
||||||
|
let ty =
|
||||||
|
match arg.BoolCases with
|
||||||
|
| None -> SynType.toHumanReadableString arg.TargetType
|
||||||
|
| Some _ -> "bool"
|
||||||
|
|
||||||
let helpText =
|
let helpText =
|
||||||
match arg.Help with
|
match arg.Help with
|
||||||
@@ -611,11 +753,10 @@ module internal ArgParserGenerator =
|
|||||||
|> SynExpr.applyTo (SynExpr.paren helpText)
|
|> SynExpr.applyTo (SynExpr.paren helpText)
|
||||||
|> SynExpr.paren
|
|> SynExpr.paren
|
||||||
|
|
||||||
let descriptor = describe arg.Accumulation
|
let descriptor = describe arg.Accumulation arg.BoolCases
|
||||||
|
|
||||||
let prefix = $"%s{arg.ArgForm} %s{ty}"
|
SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst $"%%s %s{ty}%%s%%s")
|
||||||
|
|> SynExpr.applyTo arg.HumanReadableArgForm
|
||||||
SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst (prefix + "%s%s"))
|
|
||||||
|> SynExpr.applyTo descriptor
|
|> SynExpr.applyTo descriptor
|
||||||
|> SynExpr.applyTo helpText
|
|> SynExpr.applyTo helpText
|
||||||
|> SynExpr.paren
|
|> SynExpr.paren
|
||||||
@@ -651,10 +792,12 @@ module internal ArgParserGenerator =
|
|||||||
| Accumulation.Optional ->
|
| Accumulation.Optional ->
|
||||||
let multipleErrorMessage =
|
let multipleErrorMessage =
|
||||||
SynExpr.createIdent "sprintf"
|
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 (SynExpr.CreateConst arg.ArgForm)
|
|> SynExpr.applyTo arg.HumanReadableArgForm
|
||||||
|> SynExpr.applyTo (SynExpr.createIdent "x")
|
|> SynExpr.applyTo (SynExpr.createIdent "x" |> SynExpr.callMethod "ToString" |> SynExpr.paren)
|
||||||
|> SynExpr.applyTo (SynExpr.createIdent "value")
|
|> SynExpr.applyTo (
|
||||||
|
SynExpr.createIdent "value" |> SynExpr.callMethod "ToString" |> SynExpr.paren
|
||||||
|
)
|
||||||
|
|
||||||
let performAssignment =
|
let performAssignment =
|
||||||
[
|
[
|
||||||
@@ -715,8 +858,9 @@ module internal ArgParserGenerator =
|
|||||||
|> SynExpr.pipeThroughFunction pos.Parser
|
|> SynExpr.pipeThroughFunction pos.Parser
|
||||||
|> fun p ->
|
|> fun p ->
|
||||||
match pos.Accumulation with
|
match pos.Accumulation with
|
||||||
| ChoicePositional.Choice -> p |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2")
|
| ChoicePositional.Choice _ ->
|
||||||
| ChoicePositional.Normal -> p
|
p |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice1Of2")
|
||||||
|
| ChoicePositional.Normal _ -> p
|
||||||
|> SynExpr.pipeThroughFunction (
|
|> SynExpr.pipeThroughFunction (
|
||||||
SynExpr.createLongIdent' [ pos.TargetVariable ; Ident.create "Add" ]
|
SynExpr.createLongIdent' [ pos.TargetVariable ; Ident.create "Add" ]
|
||||||
)
|
)
|
||||||
@@ -728,17 +872,24 @@ module internal ArgParserGenerator =
|
|||||||
|
|
||||||
(SynExpr.applyFunction (SynExpr.createIdent "Error") (SynExpr.createIdent "None"), posArg @ args)
|
(SynExpr.applyFunction (SynExpr.createIdent "Error") (SynExpr.createIdent "None"), posArg @ args)
|
||||||
||> List.fold (fun finalBranch (argForm, arg) ->
|
||> List.fold (fun finalBranch (argForm, arg) ->
|
||||||
arg
|
(finalBranch, argForm)
|
||||||
|> SynExpr.ifThenElse
|
||> List.fold (fun finalBranch argForm ->
|
||||||
(SynExpr.applyFunction
|
arg
|
||||||
(SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ])
|
|> SynExpr.ifThenElse
|
||||||
(SynExpr.tuple
|
(SynExpr.applyFunction
|
||||||
[
|
(SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ])
|
||||||
SynExpr.createIdent "key"
|
(SynExpr.tuple
|
||||||
SynExpr.CreateConst argForm
|
[
|
||||||
SynExpr.createLongIdent [ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ]
|
SynExpr.createIdent "key"
|
||||||
]))
|
SynExpr.applyFunction
|
||||||
finalBranch
|
(SynExpr.applyFunction
|
||||||
|
(SynExpr.createIdent "sprintf")
|
||||||
|
(SynExpr.CreateConst "--%s"))
|
||||||
|
argForm
|
||||||
|
SynExpr.createLongIdent [ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ]
|
||||||
|
]))
|
||||||
|
finalBranch
|
||||||
|
)
|
||||||
)
|
)
|
||||||
|> SynBinding.basic
|
|> SynBinding.basic
|
||||||
[ Ident.create "processKeyValue" ]
|
[ Ident.create "processKeyValue" ]
|
||||||
@@ -759,46 +910,61 @@ module internal ArgParserGenerator =
|
|||||||
)
|
)
|
||||||
|
|
||||||
/// `let setFlagValue (key : string) : bool = ...`
|
/// `let setFlagValue (key : string) : bool = ...`
|
||||||
let private setFlagValue (argParseErrors : Ident) (flags : ParseFunction<'a> list) : SynBinding =
|
/// The second member of the `flags` list tuple is the constant "true" with which we will interpret the
|
||||||
|
/// arity-0 `--foo`. So in the case of a boolean-typed field, this is `true`; in the case of a Flag-typed field,
|
||||||
|
/// this is `FlagType.WhicheverCaseHadTrue`.
|
||||||
|
let private setFlagValue (argParseErrors : Ident) (flags : (ParseFunction<'a> * SynExpr) list) : SynBinding =
|
||||||
(SynExpr.CreateConst false, flags)
|
(SynExpr.CreateConst false, flags)
|
||||||
||> List.fold (fun finalExpr flag ->
|
||> List.fold (fun finalExpr (flag, trueCase) ->
|
||||||
let multipleErrorMessage =
|
let multipleErrorMessage =
|
||||||
SynExpr.createIdent "sprintf"
|
SynExpr.createIdent "sprintf"
|
||||||
|> SynExpr.applyTo (SynExpr.CreateConst "Flag '%s' was supplied multiple times")
|
|> SynExpr.applyTo (SynExpr.CreateConst "Flag '%s' was supplied multiple times")
|
||||||
|> SynExpr.applyTo (SynExpr.CreateConst flag.ArgForm)
|
|> SynExpr.applyTo flag.HumanReadableArgForm
|
||||||
|
|
||||||
[
|
let matchFlag =
|
||||||
SynMatchClause.create
|
[
|
||||||
(SynPat.nameWithArgs "Some" [ SynPat.named "x" ])
|
SynMatchClause.create
|
||||||
// This is an error, but it's one we can gracefully report at the end.
|
(SynPat.nameWithArgs "Some" [ SynPat.named "x" ])
|
||||||
(SynExpr.sequential
|
// This is an error, but it's one we can gracefully report at the end.
|
||||||
[
|
(SynExpr.sequential
|
||||||
multipleErrorMessage
|
[
|
||||||
|> SynExpr.pipeThroughFunction (SynExpr.dotGet "Add" (SynExpr.createIdent' argParseErrors))
|
multipleErrorMessage
|
||||||
|
|> SynExpr.pipeThroughFunction (
|
||||||
|
SynExpr.dotGet "Add" (SynExpr.createIdent' argParseErrors)
|
||||||
|
)
|
||||||
|
SynExpr.CreateConst true
|
||||||
|
])
|
||||||
|
|
||||||
|
SynMatchClause.create
|
||||||
|
(SynPat.named "None")
|
||||||
|
([
|
||||||
|
SynExpr.assign
|
||||||
|
(SynLongIdent.createI flag.TargetVariable)
|
||||||
|
(SynExpr.pipeThroughFunction (SynExpr.createIdent "Some") trueCase)
|
||||||
SynExpr.CreateConst true
|
SynExpr.CreateConst true
|
||||||
])
|
]
|
||||||
|
|> SynExpr.sequential)
|
||||||
|
]
|
||||||
|
|> SynExpr.createMatch (SynExpr.createIdent' flag.TargetVariable)
|
||||||
|
|
||||||
SynMatchClause.create
|
(finalExpr, flag.ArgForm)
|
||||||
(SynPat.named "None")
|
||> List.fold (fun finalExpr argForm ->
|
||||||
([
|
SynExpr.ifThenElse
|
||||||
SynExpr.assign
|
(SynExpr.applyFunction
|
||||||
(SynLongIdent.createI flag.TargetVariable)
|
(SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ])
|
||||||
(SynExpr.applyFunction (SynExpr.createIdent "Some") (SynExpr.CreateConst true))
|
(SynExpr.tuple
|
||||||
SynExpr.CreateConst true
|
[
|
||||||
]
|
SynExpr.createIdent "key"
|
||||||
|> SynExpr.sequential)
|
SynExpr.applyFunction
|
||||||
]
|
(SynExpr.applyFunction
|
||||||
|> SynExpr.createMatch (SynExpr.createIdent' flag.TargetVariable)
|
(SynExpr.createIdent "sprintf")
|
||||||
|> SynExpr.ifThenElse
|
(SynExpr.CreateConst "--%s"))
|
||||||
(SynExpr.applyFunction
|
argForm
|
||||||
(SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ])
|
SynExpr.createLongIdent [ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ]
|
||||||
(SynExpr.tuple
|
]))
|
||||||
[
|
finalExpr
|
||||||
SynExpr.createIdent "key"
|
matchFlag
|
||||||
SynExpr.CreateConst flag.ArgForm
|
)
|
||||||
SynExpr.createLongIdent [ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ]
|
|
||||||
]))
|
|
||||||
finalExpr
|
|
||||||
)
|
)
|
||||||
|> SynBinding.basic [ Ident.create "setFlagValue" ] [ SynPat.annotateType SynType.string (SynPat.named "key") ]
|
|> SynBinding.basic [ Ident.create "setFlagValue" ] [ SynPat.annotateType SynType.string (SynPat.named "key") ]
|
||||||
|> SynBinding.withReturnAnnotation (SynType.named "bool")
|
|> SynBinding.withReturnAnnotation (SynType.named "bool")
|
||||||
@@ -838,6 +1004,50 @@ module internal ArgParserGenerator =
|
|||||||
|> SynExpr.applyTo (SynExpr.createIdent "key")
|
|> SynExpr.applyTo (SynExpr.createIdent "key")
|
||||||
|> SynExpr.applyTo (SynExpr.createIdent "value")
|
|> 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 =
|
let argStartsWithDashes =
|
||||||
SynExpr.createIdent "arg"
|
SynExpr.createIdent "arg"
|
||||||
|> SynExpr.callMethodArg
|
|> SynExpr.callMethodArg
|
||||||
@@ -851,19 +1061,7 @@ module internal ArgParserGenerator =
|
|||||||
let processKey =
|
let processKey =
|
||||||
SynExpr.ifThenElse
|
SynExpr.ifThenElse
|
||||||
argStartsWithDashes
|
argStartsWithDashes
|
||||||
(SynExpr.sequential
|
processAsPositional
|
||||||
[
|
|
||||||
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
|
|
||||||
])
|
|
||||||
(SynExpr.ifThenElse
|
(SynExpr.ifThenElse
|
||||||
(SynExpr.equals (SynExpr.createIdent "arg") (SynExpr.CreateConst "--help"))
|
(SynExpr.equals (SynExpr.createIdent "arg") (SynExpr.CreateConst "--help"))
|
||||||
(SynExpr.createLet
|
(SynExpr.createLet
|
||||||
@@ -899,23 +1097,9 @@ module internal ArgParserGenerator =
|
|||||||
[
|
[
|
||||||
SynMatchClause.create (SynPat.nameWithArgs "Ok" [ SynPat.unit ]) recurseKey
|
SynMatchClause.create (SynPat.nameWithArgs "Ok" [ SynPat.unit ]) recurseKey
|
||||||
|
|
||||||
SynMatchClause.create (SynPat.nameWithArgs "Error" [ SynPat.named "None" ]) fail
|
|
||||||
SynMatchClause.create
|
SynMatchClause.create
|
||||||
(SynPat.nameWithArgs
|
(SynPat.nameWithArgs "Error" [ SynPat.named "x" ])
|
||||||
"Error"
|
notMatched
|
||||||
[ 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
|
|
||||||
])
|
|
||||||
]))
|
]))
|
||||||
(SynExpr.createIdent "args" |> SynExpr.pipeThroughFunction recurseValue)))
|
(SynExpr.createIdent "args" |> SynExpr.pipeThroughFunction recurseValue)))
|
||||||
(SynExpr.createIdent "helpText"
|
(SynExpr.createIdent "helpText"
|
||||||
@@ -929,6 +1113,8 @@ module internal ArgParserGenerator =
|
|||||||
let processValue =
|
let processValue =
|
||||||
// During failure, we've received an optional exception message that happened when we tried to parse
|
// During failure, we've received an optional exception message that happened when we tried to parse
|
||||||
// the value; it's in the variable `exc`.
|
// 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 =
|
let fail =
|
||||||
[
|
[
|
||||||
SynExpr.createIdent "failwithf"
|
SynExpr.createIdent "failwithf"
|
||||||
@@ -948,6 +1134,27 @@ module internal ArgParserGenerator =
|
|||||||
]
|
]
|
||||||
|> SynExpr.createMatch (SynExpr.createIdent "exc")
|
|> 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
|
SynMatchClause.create
|
||||||
(SynPat.nameWithArgs "Ok" [ SynPat.unit ])
|
(SynPat.nameWithArgs "Ok" [ SynPat.unit ])
|
||||||
@@ -960,7 +1167,7 @@ module internal ArgParserGenerator =
|
|||||||
(SynPat.nameWithArgs "Error" [ SynPat.named "exc" ])
|
(SynPat.nameWithArgs "Error" [ SynPat.named "exc" ])
|
||||||
(SynExpr.ifThenElse
|
(SynExpr.ifThenElse
|
||||||
(SynExpr.applyFunction (SynExpr.createIdent "setFlagValue") (SynExpr.createIdent "key"))
|
(SynExpr.applyFunction (SynExpr.createIdent "setFlagValue") (SynExpr.createIdent "key"))
|
||||||
fail
|
onFailure
|
||||||
(SynExpr.createIdent "go"
|
(SynExpr.createIdent "go"
|
||||||
|> SynExpr.applyTo (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingKey" ])
|
|> SynExpr.applyTo (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingKey" ])
|
||||||
|> SynExpr.applyTo (SynExpr.listCons (SynExpr.createIdent "arg") (SynExpr.createIdent "args"))))
|
|> SynExpr.applyTo (SynExpr.listCons (SynExpr.createIdent "arg") (SynExpr.createIdent "args"))))
|
||||||
@@ -1027,8 +1234,8 @@ module internal ArgParserGenerator =
|
|||||||
)
|
)
|
||||||
|> fun p ->
|
|> fun p ->
|
||||||
match leftoverArgAcc with
|
match leftoverArgAcc with
|
||||||
| ChoicePositional.Normal -> p
|
| ChoicePositional.Normal _ -> p
|
||||||
| ChoicePositional.Choice ->
|
| ChoicePositional.Choice _ ->
|
||||||
p
|
p
|
||||||
|> SynExpr.pipeThroughFunction (
|
|> SynExpr.pipeThroughFunction (
|
||||||
SynExpr.applyFunction
|
SynExpr.applyFunction
|
||||||
@@ -1053,8 +1260,14 @@ module internal ArgParserGenerator =
|
|||||||
|> SynBinding.withRecursion true
|
|> SynBinding.withRecursion true
|
||||||
|
|
||||||
/// Takes a single argument, `args : string list`, and returns something of the type indicated by `recordType`.
|
/// Takes a single argument, `args : string list`, and returns something of the type indicated by `recordType`.
|
||||||
let createRecordParse (parseState : Ident) (ambientRecords : RecordType list) (recordType : RecordType) : SynExpr =
|
let createRecordParse
|
||||||
let spec, _ = toParseSpec 0 ambientRecords recordType
|
(parseState : Ident)
|
||||||
|
(flagDus : FlagDu list)
|
||||||
|
(ambientRecords : RecordType list)
|
||||||
|
(recordType : RecordType)
|
||||||
|
: SynExpr
|
||||||
|
=
|
||||||
|
let spec, _ = toParseSpec 0 flagDus ambientRecords recordType
|
||||||
// For each argument (positional and non-positional), create an accumulator for it.
|
// For each argument (positional and non-positional), create an accumulator for it.
|
||||||
let nonPos, pos =
|
let nonPos, pos =
|
||||||
{ new ParseTreeEval<_> with
|
{ new ParseTreeEval<_> with
|
||||||
@@ -1094,9 +1307,9 @@ module internal ArgParserGenerator =
|
|||||||
SynType.string
|
SynType.string
|
||||||
| Some pf ->
|
| Some pf ->
|
||||||
match pf.Accumulation with
|
match pf.Accumulation with
|
||||||
| ChoicePositional.Choice ->
|
| ChoicePositional.Choice _ ->
|
||||||
pf.TargetVariable, pf.Parser, SynType.app "Choice" [ pf.TargetType ; pf.TargetType ]
|
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 =
|
let bindings =
|
||||||
SynExpr.createIdent "ResizeArray"
|
SynExpr.createIdent "ResizeArray"
|
||||||
@@ -1135,13 +1348,50 @@ module internal ArgParserGenerator =
|
|||||||
name
|
name
|
||||||
|> SynExpr.pipeThroughFunction (SynExpr.createIdent "getEnvironmentVariable")
|
|> SynExpr.pipeThroughFunction (SynExpr.createIdent "getEnvironmentVariable")
|
||||||
|
|
||||||
|
/// Assumes access to a non-null variable `x` containing the string value.
|
||||||
|
let parser =
|
||||||
|
match pf.BoolCases with
|
||||||
|
| Some boolLike ->
|
||||||
|
let trueCase, falseCase =
|
||||||
|
match boolLike with
|
||||||
|
| Choice2Of2 () -> SynExpr.CreateConst true, SynExpr.CreateConst false
|
||||||
|
| Choice1Of2 flag ->
|
||||||
|
FlagDu.FromBoolean flag (SynExpr.CreateConst true),
|
||||||
|
FlagDu.FromBoolean flag (SynExpr.CreateConst false)
|
||||||
|
|
||||||
|
// We permit environment variables to be populated with 0 and 1 as well.
|
||||||
|
SynExpr.ifThenElse
|
||||||
|
(SynExpr.applyFunction
|
||||||
|
(SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ])
|
||||||
|
(SynExpr.tuple
|
||||||
|
[
|
||||||
|
SynExpr.createIdent "x"
|
||||||
|
SynExpr.CreateConst "1"
|
||||||
|
SynExpr.createLongIdent
|
||||||
|
[ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ]
|
||||||
|
]))
|
||||||
|
(SynExpr.ifThenElse
|
||||||
|
(SynExpr.applyFunction
|
||||||
|
(SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ])
|
||||||
|
(SynExpr.tuple
|
||||||
|
[
|
||||||
|
SynExpr.createIdent "x"
|
||||||
|
SynExpr.CreateConst "0"
|
||||||
|
SynExpr.createLongIdent
|
||||||
|
[ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ]
|
||||||
|
]))
|
||||||
|
(SynExpr.createIdent "x" |> SynExpr.pipeThroughFunction pf.Parser)
|
||||||
|
falseCase)
|
||||||
|
trueCase
|
||||||
|
| None -> (SynExpr.createIdent "x" |> SynExpr.pipeThroughFunction pf.Parser)
|
||||||
|
|
||||||
let errorMessage =
|
let errorMessage =
|
||||||
SynExpr.createIdent "sprintf"
|
SynExpr.createIdent "sprintf"
|
||||||
|> SynExpr.applyTo (
|
|> SynExpr.applyTo (
|
||||||
SynExpr.CreateConst
|
SynExpr.CreateConst
|
||||||
"No value was supplied for %s, nor was environment variable %s set"
|
"No value was supplied for %s, nor was environment variable %s set"
|
||||||
)
|
)
|
||||||
|> SynExpr.applyTo (SynExpr.CreateConst pf.ArgForm)
|
|> SynExpr.applyTo pf.HumanReadableArgForm
|
||||||
|> SynExpr.applyTo name
|
|> SynExpr.applyTo name
|
||||||
|
|
||||||
[
|
[
|
||||||
@@ -1156,9 +1406,7 @@ module internal ArgParserGenerator =
|
|||||||
unchecked
|
unchecked
|
||||||
])
|
])
|
||||||
|
|
||||||
SynMatchClause.create
|
SynMatchClause.create (SynPat.named "x") parser
|
||||||
(SynPat.named "x")
|
|
||||||
(SynExpr.createIdent "x" |> SynExpr.pipeThroughFunction pf.Parser)
|
|
||||||
]
|
]
|
||||||
|> SynExpr.createMatch result
|
|> SynExpr.createMatch result
|
||||||
| ArgumentDefaultSpec.FunctionCall name ->
|
| ArgumentDefaultSpec.FunctionCall name ->
|
||||||
@@ -1192,7 +1440,7 @@ module internal ArgParserGenerator =
|
|||||||
let errorMessage =
|
let errorMessage =
|
||||||
SynExpr.createIdent "sprintf"
|
SynExpr.createIdent "sprintf"
|
||||||
|> SynExpr.applyTo (SynExpr.CreateConst "Required argument '%s' received no value")
|
|> SynExpr.applyTo (SynExpr.CreateConst "Required argument '%s' received no value")
|
||||||
|> SynExpr.applyTo (SynExpr.CreateConst pf.ArgForm)
|
|> SynExpr.applyTo pf.HumanReadableArgForm
|
||||||
|
|
||||||
[
|
[
|
||||||
SynMatchClause.create
|
SynMatchClause.create
|
||||||
@@ -1274,15 +1522,22 @@ module internal ArgParserGenerator =
|
|||||||
|
|
||||||
let flags =
|
let flags =
|
||||||
nonPos
|
nonPos
|
||||||
|> List.filter (fun pf ->
|
|> List.choose (fun pf ->
|
||||||
match pf.TargetType with
|
match pf.TargetType with
|
||||||
| PrimitiveType pt -> (pt |> List.map _.idText) = [ "System" ; "Boolean" ]
|
| PrimitiveType pt ->
|
||||||
| _ -> false
|
if (pt |> List.map _.idText) = [ "System" ; "Boolean" ] then
|
||||||
|
Some (pf, SynExpr.CreateConst true)
|
||||||
|
else
|
||||||
|
None
|
||||||
|
| ty ->
|
||||||
|
match identifyAsFlag flagDus ty with
|
||||||
|
| Some flag -> (pf, FlagDu.FromBoolean flag (SynExpr.CreateConst true)) |> Some
|
||||||
|
| _ -> None
|
||||||
)
|
)
|
||||||
|
|
||||||
let leftoverArgAcc =
|
let leftoverArgAcc =
|
||||||
match pos with
|
match pos with
|
||||||
| None -> ChoicePositional.Normal
|
| None -> ChoicePositional.Normal None
|
||||||
| Some pos -> pos.Accumulation
|
| Some pos -> pos.Accumulation
|
||||||
|
|
||||||
[
|
[
|
||||||
@@ -1302,18 +1557,82 @@ module internal ArgParserGenerator =
|
|||||||
]
|
]
|
||||||
)
|
)
|
||||||
|
|
||||||
|
// The type for which we're generating args may refer to any of the supplied records/unions.
|
||||||
let createModule
|
let createModule
|
||||||
(opens : SynOpenDeclTarget list)
|
(opens : SynOpenDeclTarget list)
|
||||||
(ns : LongIdent)
|
(ns : LongIdent)
|
||||||
((taggedType : SynTypeDefn, spec : ArgParserOutputSpec))
|
((taggedType : SynTypeDefn, spec : ArgParserOutputSpec))
|
||||||
(allUnionTypes : SynTypeDefn list)
|
(allUnionTypes : UnionType list)
|
||||||
(allRecordTypes : SynTypeDefn list)
|
(allRecordTypes : RecordType list)
|
||||||
: SynModuleOrNamespace
|
: SynModuleOrNamespace
|
||||||
=
|
=
|
||||||
// The type for which we're generating args may refer to any of these records/unions.
|
let flagDus =
|
||||||
let allRecordTypes = allRecordTypes |> List.map RecordType.OfRecord
|
allUnionTypes
|
||||||
|
|> List.choose (fun ty ->
|
||||||
|
match ty.Cases with
|
||||||
|
| [ c1 ; c2 ] ->
|
||||||
|
let c1Attr =
|
||||||
|
c1.Attributes
|
||||||
|
|> List.tryPick (fun attr ->
|
||||||
|
match attr.TypeName with
|
||||||
|
| SynLongIdent.SynLongIdent (id, _, _) ->
|
||||||
|
match id |> List.last |> _.idText with
|
||||||
|
| "ArgumentFlagAttribute"
|
||||||
|
| "ArgumentFlag" -> Some (SynExpr.stripOptionalParen attr.ArgExpr)
|
||||||
|
| _ -> None
|
||||||
|
)
|
||||||
|
|
||||||
let taggedType = RecordType.OfRecord taggedType
|
let c2Attr =
|
||||||
|
c2.Attributes
|
||||||
|
|> List.tryPick (fun attr ->
|
||||||
|
match attr.TypeName with
|
||||||
|
| SynLongIdent.SynLongIdent (id, _, _) ->
|
||||||
|
match id |> List.last |> _.idText with
|
||||||
|
| "ArgumentFlagAttribute"
|
||||||
|
| "ArgumentFlag" -> Some (SynExpr.stripOptionalParen attr.ArgExpr)
|
||||||
|
| _ -> None
|
||||||
|
)
|
||||||
|
|
||||||
|
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, _) ->
|
||||||
|
if b1 = b2 then
|
||||||
|
failwith
|
||||||
|
"[<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
|
||||||
|
Case1Arg = c1Attr
|
||||||
|
Case2Name = c2.Name
|
||||||
|
Case2Arg = c2Attr
|
||||||
|
}
|
||||||
|
|> Some
|
||||||
|
| _, _ ->
|
||||||
|
failwith "[<ArgumentFlag>] may only be placed on discriminated union members with no data."
|
||||||
|
| _ -> None
|
||||||
|
)
|
||||||
|
|
||||||
|
let taggedType =
|
||||||
|
match taggedType with
|
||||||
|
| SynTypeDefn.SynTypeDefn (sci,
|
||||||
|
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (access, fields, _), _),
|
||||||
|
smd,
|
||||||
|
_,
|
||||||
|
_,
|
||||||
|
_) -> RecordType.OfRecord sci smd access fields
|
||||||
|
| _ -> failwith "[<ArgParser>] currently only supports being placed on records."
|
||||||
|
|
||||||
let modAttrs, modName =
|
let modAttrs, modName =
|
||||||
if spec.ExtensionMethods then
|
if spec.ExtensionMethods then
|
||||||
@@ -1334,13 +1653,15 @@ module internal ArgParserGenerator =
|
|||||||
[
|
[
|
||||||
SynUnionCase.create
|
SynUnionCase.create
|
||||||
{
|
{
|
||||||
Attrs = []
|
Attributes = []
|
||||||
Fields = []
|
Fields = []
|
||||||
Ident = Ident.create "AwaitingKey"
|
Name = Ident.create "AwaitingKey"
|
||||||
|
XmlDoc = Some (PreXmlDoc.create "Ready to consume a key or positional arg")
|
||||||
|
Access = None
|
||||||
}
|
}
|
||||||
SynUnionCase.create
|
SynUnionCase.create
|
||||||
{
|
{
|
||||||
Attrs = []
|
Attributes = []
|
||||||
Fields =
|
Fields =
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
@@ -1349,7 +1670,9 @@ module internal ArgParserGenerator =
|
|||||||
Type = SynType.string
|
Type = SynType.string
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
Ident = Ident.create "AwaitingValue"
|
Name = Ident.create "AwaitingValue"
|
||||||
|
XmlDoc = Some (PreXmlDoc.create "Waiting to receive a value for the key we've already consumed")
|
||||||
|
Access = None
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
|> SynTypeDefnRepr.union
|
|> SynTypeDefnRepr.union
|
||||||
@@ -1366,7 +1689,7 @@ module internal ArgParserGenerator =
|
|||||||
|> SynPat.annotateType (SynType.appPostfix "list" SynType.string)
|
|> SynPat.annotateType (SynType.appPostfix "list" SynType.string)
|
||||||
|
|
||||||
let parsePrime =
|
let parsePrime =
|
||||||
createRecordParse parseStateIdent allRecordTypes taggedType
|
createRecordParse parseStateIdent flagDus allRecordTypes taggedType
|
||||||
|> SynBinding.basic
|
|> SynBinding.basic
|
||||||
[ Ident.create "parse'" ]
|
[ Ident.create "parse'" ]
|
||||||
[
|
[
|
||||||
@@ -1464,12 +1787,12 @@ module internal ArgParserGenerator =
|
|||||||
(([], [], []), types)
|
(([], [], []), types)
|
||||||
||> List.fold (fun
|
||> List.fold (fun
|
||||||
(unions, records, others)
|
(unions, records, others)
|
||||||
(SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _) as ty) ->
|
(SynTypeDefn.SynTypeDefn (sci, repr, smd, _, _, _) as ty) ->
|
||||||
match repr with
|
match repr with
|
||||||
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union _, _) ->
|
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (access, cases, _), _) ->
|
||||||
ty :: unions, records, others
|
UnionType.OfUnion sci smd access cases :: unions, records, others
|
||||||
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record _, _) ->
|
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (access, fields, _), _) ->
|
||||||
unions, ty :: records, others
|
unions, RecordType.OfRecord sci smd access fields :: records, others
|
||||||
| _ -> unions, records, ty :: others
|
| _ -> unions, records, ty :: others
|
||||||
)
|
)
|
||||||
|
|
||||||
|
@@ -67,41 +67,109 @@ type internal RecordType =
|
|||||||
Members : SynMemberDefns option
|
Members : SynMemberDefns option
|
||||||
XmlDoc : PreXmlDoc option
|
XmlDoc : PreXmlDoc option
|
||||||
Generics : SynTyparDecls option
|
Generics : SynTyparDecls option
|
||||||
Accessibility : SynAccess option
|
TypeAccessibility : SynAccess option
|
||||||
|
ImplAccessibility : SynAccess option
|
||||||
Attributes : SynAttribute list
|
Attributes : SynAttribute list
|
||||||
}
|
}
|
||||||
|
|
||||||
/// Parse from the AST.
|
/// Parse from the AST.
|
||||||
static member OfRecord (record : SynTypeDefn) : RecordType =
|
static member OfRecord
|
||||||
let sci, sdr, smd, smdo =
|
(sci : SynComponentInfo)
|
||||||
match record with
|
(smd : SynMemberDefns)
|
||||||
| SynTypeDefn.SynTypeDefn (sci, sdr, smd, smdo, _, _) -> sci, sdr, smd, smdo
|
(access : SynAccess option)
|
||||||
|
(recordFields : SynField list)
|
||||||
let synAccessOption, recordFields =
|
: RecordType
|
||||||
match sdr with
|
=
|
||||||
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (sa, fields, _), _) -> sa, fields
|
|
||||||
| _ -> failwith $"expected a record; got: %+A{record}"
|
|
||||||
|
|
||||||
match sci with
|
match sci with
|
||||||
| SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, access, _) ->
|
| SynComponentInfo.SynComponentInfo (attrs, typars, _, longId, doc, _, implAccess, _) ->
|
||||||
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
|
Name = List.last longId
|
||||||
Fields = recordFields
|
Fields = recordFields
|
||||||
Members = if smd.IsEmpty then None else Some smd
|
Members = if smd.IsEmpty then None else Some smd
|
||||||
XmlDoc = if doc.IsEmpty then None else Some doc
|
XmlDoc = if doc.IsEmpty then None else Some doc
|
||||||
Generics = typars
|
Generics = typars
|
||||||
Accessibility = synAccessOption
|
ImplAccessibility = implAccess
|
||||||
|
TypeAccessibility = access
|
||||||
Attributes = attrs |> List.collect (fun l -> l.Attributes)
|
Attributes = attrs |> List.collect (fun l -> l.Attributes)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/// Methods for manipulating UnionCase.
|
||||||
|
[<RequireQualifiedAccess>]
|
||||||
|
module UnionCase =
|
||||||
|
/// Construct our structured `UnionCase` from an FCS `SynUnionCase`: extract everything
|
||||||
|
/// we care about from the AST representation.
|
||||||
|
let ofSynUnionCase (case : SynUnionCase) : UnionCase<Ident option> =
|
||||||
|
match case with
|
||||||
|
| SynUnionCase.SynUnionCase (attributes, ident, caseType, xmlDoc, access, _, _) ->
|
||||||
|
|
||||||
|
let ident =
|
||||||
|
match ident with
|
||||||
|
| SynIdent.SynIdent (ident, _) -> ident
|
||||||
|
|
||||||
|
let fields =
|
||||||
|
match caseType with
|
||||||
|
| SynUnionCaseKind.Fields cases -> cases
|
||||||
|
| SynUnionCaseKind.FullType _ -> failwith "unexpected FullType union"
|
||||||
|
|
||||||
|
{
|
||||||
|
Name = ident
|
||||||
|
XmlDoc = if xmlDoc.IsEmpty then None else Some xmlDoc
|
||||||
|
Access = access
|
||||||
|
Attributes = attributes |> List.collect (fun t -> t.Attributes)
|
||||||
|
Fields = fields |> List.map SynField.extract
|
||||||
|
}
|
||||||
|
|
||||||
|
/// Functorial `map`.
|
||||||
|
let mapIdentFields<'a, 'b> (f : 'a -> 'b) (unionCase : UnionCase<'a>) : UnionCase<'b> =
|
||||||
|
{
|
||||||
|
Attributes = unionCase.Attributes
|
||||||
|
Name = unionCase.Name
|
||||||
|
Access = unionCase.Access
|
||||||
|
XmlDoc = unionCase.XmlDoc
|
||||||
|
Fields = unionCase.Fields |> List.map (SynField.mapIdent f)
|
||||||
|
}
|
||||||
|
|
||||||
|
/// Everything you need to know about a discriminated union definition.
|
||||||
|
type internal UnionType =
|
||||||
|
{
|
||||||
|
/// The name of the DU: for example, `type Foo = | Blah` has this being `Foo`.
|
||||||
|
Name : Ident
|
||||||
|
/// Any additional members which are not union cases.
|
||||||
|
Members : SynMemberDefns option
|
||||||
|
/// Any docstring associated with the DU itself (not its cases).
|
||||||
|
XmlDoc : PreXmlDoc option
|
||||||
|
/// Generic type parameters this DU takes: `type Foo<'a> = | ...`.
|
||||||
|
Generics : SynTyparDecls option
|
||||||
|
/// Attributes of the DU (not its cases): `[<Attr>] type Foo = | ...`
|
||||||
|
Attributes : SynAttribute list
|
||||||
|
/// Accessibility modifier of the DU: `type private Foo = ...`
|
||||||
|
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
|
||||||
|
}
|
||||||
|
|
||||||
|
static member OfUnion
|
||||||
|
(sci : SynComponentInfo)
|
||||||
|
(smd : SynMemberDefns)
|
||||||
|
(access : SynAccess option)
|
||||||
|
(cases : SynUnionCase list)
|
||||||
|
: UnionType
|
||||||
|
=
|
||||||
|
match sci with
|
||||||
|
| 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)
|
||||||
|
TypeAccessibility = access
|
||||||
|
ImplAccessibility = implAccess
|
||||||
|
Cases = cases |> List.map UnionCase.ofSynUnionCase
|
||||||
|
}
|
||||||
|
|
||||||
/// Anything that is part of an ADT.
|
/// Anything that is part of an ADT.
|
||||||
/// A record is a product of stuff; this type represents one of those stuffs.
|
/// A record is a product of stuff; this type represents one of those stuffs.
|
||||||
type internal AdtNode =
|
type internal AdtNode =
|
||||||
@@ -144,13 +212,13 @@ module internal AstHelper =
|
|||||||
let defineRecordType (record : RecordType) : SynTypeDefn =
|
let defineRecordType (record : RecordType) : SynTypeDefn =
|
||||||
let name =
|
let name =
|
||||||
SynComponentInfo.create record.Name
|
SynComponentInfo.create record.Name
|
||||||
|> SynComponentInfo.setAccessibility record.Accessibility
|
|> SynComponentInfo.setAccessibility record.TypeAccessibility
|
||||||
|> match record.XmlDoc with
|
|> match record.XmlDoc with
|
||||||
| None -> id
|
| None -> id
|
||||||
| Some doc -> SynComponentInfo.withDocString doc
|
| Some doc -> SynComponentInfo.withDocString doc
|
||||||
|> SynComponentInfo.setGenerics record.Generics
|
|> SynComponentInfo.setGenerics record.Generics
|
||||||
|
|
||||||
SynTypeDefnRepr.record (Seq.toList record.Fields)
|
SynTypeDefnRepr.recordWithAccess record.ImplAccessibility (Seq.toList record.Fields)
|
||||||
|> SynTypeDefn.create name
|
|> SynTypeDefn.create name
|
||||||
|> SynTypeDefn.withMemberDefns (defaultArg record.Members SynMemberDefns.Empty)
|
|> SynTypeDefn.withMemberDefns (defaultArg record.Members SynMemberDefns.Empty)
|
||||||
|
|
||||||
|
@@ -212,7 +212,8 @@ module internal InterfaceMockGenerator =
|
|||||||
Members = Some ([ constructor ; interfaceMembers ] @ extraInterfaces)
|
Members = Some ([ constructor ; interfaceMembers ] @ extraInterfaces)
|
||||||
XmlDoc = Some xmlDoc
|
XmlDoc = Some xmlDoc
|
||||||
Generics = interfaceType.Generics
|
Generics = interfaceType.Generics
|
||||||
Accessibility = Some access
|
TypeAccessibility = Some access
|
||||||
|
ImplAccessibility = None
|
||||||
Attributes = []
|
Attributes = []
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@@ -416,11 +416,11 @@ module internal JsonParseGenerator =
|
|||||||
let createUnionMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : UnionCase<Ident> list) =
|
let createUnionMaker (spec : JsonParseOutputSpec) (typeName : LongIdent) (fields : UnionCase<Ident> list) =
|
||||||
fields
|
fields
|
||||||
|> List.map (fun case ->
|
|> List.map (fun case ->
|
||||||
let propertyName = JsonSerializeGenerator.getPropertyName case.Ident case.Attrs
|
let propertyName = JsonSerializeGenerator.getPropertyName case.Name case.Attributes
|
||||||
|
|
||||||
let body =
|
let body =
|
||||||
if case.Fields.IsEmpty then
|
if case.Fields.IsEmpty then
|
||||||
SynExpr.createLongIdent' (typeName @ [ case.Ident ])
|
SynExpr.createLongIdent' (typeName @ [ case.Name ])
|
||||||
else
|
else
|
||||||
case.Fields
|
case.Fields
|
||||||
|> List.map (fun field ->
|
|> List.map (fun field ->
|
||||||
@@ -429,7 +429,7 @@ module internal JsonParseGenerator =
|
|||||||
createParseRhs options propertyName field.Type
|
createParseRhs options propertyName field.Type
|
||||||
)
|
)
|
||||||
|> SynExpr.tuple
|
|> SynExpr.tuple
|
||||||
|> SynExpr.applyFunction (SynExpr.createLongIdent' (typeName @ [ case.Ident ]))
|
|> SynExpr.applyFunction (SynExpr.createLongIdent' (typeName @ [ case.Name ]))
|
||||||
|> SynExpr.createLet
|
|> SynExpr.createLet
|
||||||
[
|
[
|
||||||
SynExpr.index (SynExpr.CreateConst "data") (SynExpr.createIdent "node")
|
SynExpr.index (SynExpr.CreateConst "data") (SynExpr.createIdent "node")
|
||||||
@@ -600,7 +600,7 @@ module internal JsonParseGenerator =
|
|||||||
| Some i -> i
|
| Some i -> i
|
||||||
|
|
||||||
cases
|
cases
|
||||||
|> List.map SynUnionCase.extract
|
|> List.map UnionCase.ofSynUnionCase
|
||||||
|> List.map (UnionCase.mapIdentFields optionGet)
|
|> List.map (UnionCase.mapIdentFields optionGet)
|
||||||
|> createUnionMaker spec ident
|
|> createUnionMaker spec ident
|
||||||
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Enum (cases, _range), _) ->
|
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Enum (cases, _range), _) ->
|
||||||
|
@@ -263,11 +263,11 @@ module internal JsonSerializeGenerator =
|
|||||||
|
|
||||||
let unionModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (cases : SynUnionCase list) =
|
let unionModule (spec : JsonSerializeOutputSpec) (typeName : LongIdent) (cases : SynUnionCase list) =
|
||||||
let inputArg = Ident.create "input"
|
let inputArg = Ident.create "input"
|
||||||
let fields = cases |> List.map SynUnionCase.extract
|
let fields = cases |> List.map UnionCase.ofSynUnionCase
|
||||||
|
|
||||||
fields
|
fields
|
||||||
|> List.map (fun unionCase ->
|
|> List.map (fun unionCase ->
|
||||||
let propertyName = getPropertyName unionCase.Ident unionCase.Attrs
|
let propertyName = getPropertyName unionCase.Name unionCase.Attributes
|
||||||
|
|
||||||
let caseNames = unionCase.Fields |> List.mapi (fun i _ -> $"arg%i{i}")
|
let caseNames = unionCase.Fields |> List.mapi (fun i _ -> $"arg%i{i}")
|
||||||
|
|
||||||
@@ -275,7 +275,7 @@ module internal JsonSerializeGenerator =
|
|||||||
|
|
||||||
let pattern =
|
let pattern =
|
||||||
SynPat.LongIdent (
|
SynPat.LongIdent (
|
||||||
SynLongIdent.create (typeName @ [ unionCase.Ident ]),
|
SynLongIdent.create (typeName @ [ unionCase.Name ]),
|
||||||
None,
|
None,
|
||||||
None,
|
None,
|
||||||
argPats,
|
argPats,
|
||||||
|
@@ -36,7 +36,6 @@ module internal RemoveOptionsGenerator =
|
|||||||
trivia
|
trivia
|
||||||
)
|
)
|
||||||
|
|
||||||
// TODO: this option seems a bit odd
|
|
||||||
let createType
|
let createType
|
||||||
(xmlDoc : PreXmlDoc option)
|
(xmlDoc : PreXmlDoc option)
|
||||||
(accessibility : SynAccess option)
|
(accessibility : SynAccess option)
|
||||||
@@ -54,7 +53,8 @@ module internal RemoveOptionsGenerator =
|
|||||||
Members = None
|
Members = None
|
||||||
XmlDoc = xmlDoc
|
XmlDoc = xmlDoc
|
||||||
Generics = generics
|
Generics = generics
|
||||||
Accessibility = accessibility
|
TypeAccessibility = accessibility
|
||||||
|
ImplAccessibility = None
|
||||||
Attributes = []
|
Attributes = []
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -62,7 +62,7 @@ module internal RemoveOptionsGenerator =
|
|||||||
|
|
||||||
SynModuleDecl.Types ([ typeDecl ], range0)
|
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 xmlDoc = PreXmlDoc.create "Remove the optional members of the input."
|
||||||
|
|
||||||
let inputArg = Ident.create "input"
|
let inputArg = Ident.create "input"
|
||||||
@@ -87,7 +87,7 @@ module internal RemoveOptionsGenerator =
|
|||||||
SynExpr.applyFunction
|
SynExpr.applyFunction
|
||||||
(SynExpr.createLongIdent [ "Option" ; "defaultWith" ])
|
(SynExpr.createLongIdent [ "Option" ; "defaultWith" ])
|
||||||
(SynExpr.createLongIdent' (
|
(SynExpr.createLongIdent' (
|
||||||
withoutOptionsType
|
[ withoutOptionsType ]
|
||||||
@ [ Ident.create (sprintf "Default%s" fieldData.Ident.idText) ]
|
@ [ Ident.create (sprintf "Default%s" fieldData.Ident.idText) ]
|
||||||
))
|
))
|
||||||
)
|
)
|
||||||
@@ -101,47 +101,35 @@ module internal RemoveOptionsGenerator =
|
|||||||
[ functionName ]
|
[ functionName ]
|
||||||
[
|
[
|
||||||
SynPat.named inputArg.idText
|
SynPat.named inputArg.idText
|
||||||
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.create withoutOptionsType))
|
|> SynPat.annotateType (SynType.LongIdent (SynLongIdent.createI withoutOptionsType))
|
||||||
]
|
]
|
||||||
body
|
body
|
||||||
|> SynBinding.withXmlDoc xmlDoc
|
|> SynBinding.withXmlDoc xmlDoc
|
||||||
|> SynBinding.withReturnAnnotation (SynType.LongIdent (SynLongIdent.create withOptionsType))
|
|> SynBinding.withReturnAnnotation (SynType.LongIdent (SynLongIdent.create withOptionsType))
|
||||||
|> SynModuleDecl.createLet
|
|> SynModuleDecl.createLet
|
||||||
|
|
||||||
let createRecordModule (namespaceId : LongIdent) (typeDefn : SynTypeDefn) =
|
let createRecordModule (namespaceId : LongIdent) (typeDefn : RecordType) =
|
||||||
let (SynTypeDefn (synComponentInfo, synTypeDefnRepr, _members, _implicitCtor, _, _)) =
|
let fieldData = typeDefn.Fields |> List.map SynField.extractWithIdent
|
||||||
typeDefn
|
|
||||||
|
|
||||||
let (SynComponentInfo (_attributes, typeParams, _constraints, recordId, doc, _preferPostfix, _access, _)) =
|
let decls =
|
||||||
synComponentInfo
|
[
|
||||||
|
createType typeDefn.XmlDoc typeDefn.TypeAccessibility typeDefn.Generics typeDefn.Fields
|
||||||
|
createMaker [ Ident.create "Short" ] typeDefn.Name fieldData
|
||||||
|
]
|
||||||
|
|
||||||
match synTypeDefnRepr with
|
let xmlDoc =
|
||||||
| SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (accessibility, fields, _range), _) ->
|
sprintf "Module containing an option-truncated version of the %s type" typeDefn.Name.idText
|
||||||
let fieldData = fields |> List.map SynField.extractWithIdent
|
|> PreXmlDoc.create
|
||||||
|
|
||||||
let decls =
|
let info =
|
||||||
[
|
SynComponentInfo.create typeDefn.Name
|
||||||
createType (Some doc) accessibility typeParams fields
|
|> SynComponentInfo.withDocString xmlDoc
|
||||||
createMaker [ Ident.create "Short" ] recordId fieldData
|
|> SynComponentInfo.addAttributes [ SynAttribute.compilationRepresentation ]
|
||||||
]
|
|> SynComponentInfo.addAttributes [ SynAttribute.requireQualifiedAccess ]
|
||||||
|
|
||||||
let xmlDoc =
|
SynModuleDecl.nestedModule info decls
|
||||||
recordId
|
|> List.singleton
|
||||||
|> Seq.map (fun i -> i.idText)
|
|> SynModuleOrNamespace.createNamespace namespaceId
|
||||||
|> String.concat "."
|
|
||||||
|> sprintf "Module containing an option-truncated version of the %s type"
|
|
||||||
|> PreXmlDoc.create
|
|
||||||
|
|
||||||
let info =
|
|
||||||
SynComponentInfo.createLong recordId
|
|
||||||
|> SynComponentInfo.withDocString xmlDoc
|
|
||||||
|> SynComponentInfo.addAttributes [ SynAttribute.compilationRepresentation ]
|
|
||||||
|> SynComponentInfo.addAttributes [ SynAttribute.requireQualifiedAccess ]
|
|
||||||
|
|
||||||
SynModuleDecl.nestedModule info decls
|
|
||||||
|> List.singleton
|
|
||||||
|> SynModuleOrNamespace.createNamespace namespaceId
|
|
||||||
| _ -> failwithf "Not a record type"
|
|
||||||
|
|
||||||
open Myriad.Core
|
open Myriad.Core
|
||||||
|
|
||||||
@@ -164,7 +152,24 @@ type RemoveOptionsGenerator () =
|
|||||||
|> List.choose (fun (ns, types) ->
|
|> List.choose (fun (ns, types) ->
|
||||||
match types |> List.filter Ast.hasAttribute<RemoveOptionsAttribute> with
|
match types |> List.filter Ast.hasAttribute<RemoveOptionsAttribute> with
|
||||||
| [] -> None
|
| [] -> 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 =
|
let modules =
|
||||||
|
@@ -11,4 +11,27 @@ WoofWare.Myriad.Plugins.JsonParseGenerator..ctor [constructor]: unit
|
|||||||
WoofWare.Myriad.Plugins.JsonSerializeGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
|
WoofWare.Myriad.Plugins.JsonSerializeGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
|
||||||
WoofWare.Myriad.Plugins.JsonSerializeGenerator..ctor [constructor]: unit
|
WoofWare.Myriad.Plugins.JsonSerializeGenerator..ctor [constructor]: unit
|
||||||
WoofWare.Myriad.Plugins.RemoveOptionsGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
|
WoofWare.Myriad.Plugins.RemoveOptionsGenerator inherit obj, implements Myriad.Core.IMyriadGenerator
|
||||||
WoofWare.Myriad.Plugins.RemoveOptionsGenerator..ctor [constructor]: unit
|
WoofWare.Myriad.Plugins.RemoveOptionsGenerator..ctor [constructor]: unit
|
||||||
|
WoofWare.Myriad.Plugins.SynFieldData`1 inherit obj
|
||||||
|
WoofWare.Myriad.Plugins.SynFieldData`1..ctor [constructor]: (Fantomas.FCS.Syntax.SynAttribute list, 'Ident, Fantomas.FCS.Syntax.SynType)
|
||||||
|
WoofWare.Myriad.Plugins.SynFieldData`1.Attrs [property]: [read-only] Fantomas.FCS.Syntax.SynAttribute list
|
||||||
|
WoofWare.Myriad.Plugins.SynFieldData`1.get_Attrs [method]: unit -> Fantomas.FCS.Syntax.SynAttribute list
|
||||||
|
WoofWare.Myriad.Plugins.SynFieldData`1.get_Ident [method]: unit -> 'Ident
|
||||||
|
WoofWare.Myriad.Plugins.SynFieldData`1.get_Type [method]: unit -> Fantomas.FCS.Syntax.SynType
|
||||||
|
WoofWare.Myriad.Plugins.SynFieldData`1.Ident [property]: [read-only] 'Ident
|
||||||
|
WoofWare.Myriad.Plugins.SynFieldData`1.Type [property]: [read-only] Fantomas.FCS.Syntax.SynType
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase inherit obj
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase.mapIdentFields [static method]: ('a -> 'b) -> 'a WoofWare.Myriad.Plugins.UnionCase -> 'b WoofWare.Myriad.Plugins.UnionCase
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase.ofSynUnionCase [static method]: Fantomas.FCS.Syntax.SynUnionCase -> Fantomas.FCS.Syntax.Ident option WoofWare.Myriad.Plugins.UnionCase
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase`1 inherit obj
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase`1..ctor [constructor]: (Fantomas.FCS.Syntax.Ident, Fantomas.FCS.Xml.PreXmlDoc option, Fantomas.FCS.Syntax.SynAccess option, Fantomas.FCS.Syntax.SynAttribute list, 'ident WoofWare.Myriad.Plugins.SynFieldData list)
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase`1.Access [property]: [read-only] Fantomas.FCS.Syntax.SynAccess option
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase`1.Attributes [property]: [read-only] Fantomas.FCS.Syntax.SynAttribute list
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase`1.Fields [property]: [read-only] 'ident WoofWare.Myriad.Plugins.SynFieldData list
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase`1.get_Access [method]: unit -> Fantomas.FCS.Syntax.SynAccess option
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase`1.get_Attributes [method]: unit -> Fantomas.FCS.Syntax.SynAttribute list
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase`1.get_Fields [method]: unit -> 'ident WoofWare.Myriad.Plugins.SynFieldData list
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase`1.get_Name [method]: unit -> Fantomas.FCS.Syntax.Ident
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase`1.get_XmlDoc [method]: unit -> Fantomas.FCS.Xml.PreXmlDoc option
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase`1.Name [property]: [read-only] Fantomas.FCS.Syntax.Ident
|
||||||
|
WoofWare.Myriad.Plugins.UnionCase`1.XmlDoc [property]: [read-only] Fantomas.FCS.Xml.PreXmlDoc option
|
@@ -80,6 +80,11 @@ module internal SynExpr =
|
|||||||
let equals (a : SynExpr) (b : SynExpr) =
|
let equals (a : SynExpr) (b : SynExpr) =
|
||||||
SynExpr.CreateAppInfix (SynExpr.CreateLongIdent SynLongIdent.eq, a) |> applyTo b
|
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}
|
/// {a} + {b}
|
||||||
let plus (a : SynExpr) (b : SynExpr) =
|
let plus (a : SynExpr) (b : SynExpr) =
|
||||||
SynExpr.CreateAppInfix (
|
SynExpr.CreateAppInfix (
|
||||||
|
@@ -5,10 +5,17 @@ open Fantomas.FCS.Syntax
|
|||||||
open Fantomas.FCS.SyntaxTrivia
|
open Fantomas.FCS.SyntaxTrivia
|
||||||
open Fantomas.FCS.Xml
|
open Fantomas.FCS.Xml
|
||||||
|
|
||||||
type internal SynFieldData<'Ident> =
|
/// The data needed to reconstitute a single piece of data within a union field, or a single record field.
|
||||||
|
/// This is generic on whether the field is identified. For example, in `type Foo = Blah of int`, the `int`
|
||||||
|
/// field is not identified; whereas in `type Foo = Blah of baz : int`, it is identified.
|
||||||
|
type SynFieldData<'Ident> =
|
||||||
{
|
{
|
||||||
|
/// Attributes on this field. I think you can only get these if this is a *record* field.
|
||||||
Attrs : SynAttribute list
|
Attrs : SynAttribute list
|
||||||
|
/// The identifier of this field (see docstring for SynFieldData).
|
||||||
Ident : 'Ident
|
Ident : 'Ident
|
||||||
|
/// The type of the data contained in this field. For example, `type Foo = { Blah : int }`
|
||||||
|
/// has this being `int`.
|
||||||
Type : SynType
|
Type : SynType
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@@ -33,6 +33,9 @@ module internal SynLongIdent =
|
|||||||
let eq =
|
let eq =
|
||||||
SynLongIdent.SynLongIdent ([ Ident.create "op_Equality" ], [], [ Some (IdentTrivia.OriginalNotation "=") ])
|
SynLongIdent.SynLongIdent ([ Ident.create "op_Equality" ], [], [ Some (IdentTrivia.OriginalNotation "=") ])
|
||||||
|
|
||||||
|
let booleanAnd =
|
||||||
|
SynLongIdent.SynLongIdent ([ Ident.create "op_BooleanAnd" ], [], [ Some (IdentTrivia.OriginalNotation "&&") ])
|
||||||
|
|
||||||
let pipe =
|
let pipe =
|
||||||
SynLongIdent.SynLongIdent ([ Ident.create "op_PipeRight" ], [], [ Some (IdentTrivia.OriginalNotation "|>") ])
|
SynLongIdent.SynLongIdent ([ Ident.create "op_PipeRight" ], [], [ Some (IdentTrivia.OriginalNotation "|>") ])
|
||||||
|
|
||||||
|
@@ -363,6 +363,7 @@ module internal SynType =
|
|||||||
| DateTimeOffset -> "DateTimeOffset"
|
| DateTimeOffset -> "DateTimeOffset"
|
||||||
| DateOnly -> "DateOnly"
|
| DateOnly -> "DateOnly"
|
||||||
| TimeSpan -> "TimeSpan"
|
| TimeSpan -> "TimeSpan"
|
||||||
|
| SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) -> ident |> List.map _.idText |> String.concat "."
|
||||||
| ty -> failwithf "could not compute human-readable string for type: %O" ty
|
| 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".
|
/// Guess whether the types are equal. We err on the side of saying "no, they're different".
|
||||||
@@ -454,4 +455,11 @@ module internal SynType =
|
|||||||
match ty2 with
|
match ty2 with
|
||||||
| DateOnly -> true
|
| DateOnly -> true
|
||||||
| _ -> false
|
| _ -> false
|
||||||
| _ -> false
|
| _ ->
|
||||||
|
|
||||||
|
match ty1, ty2 with
|
||||||
|
| SynType.LongIdent (SynLongIdent (ident1, _, _)), SynType.LongIdent (SynLongIdent (ident2, _, _)) ->
|
||||||
|
let ident1 = ident1 |> List.map _.idText
|
||||||
|
let ident2 = ident2 |> List.map _.idText
|
||||||
|
ident1 = ident2
|
||||||
|
| _, _ -> false
|
||||||
|
@@ -13,8 +13,12 @@ module internal SynTypeDefnRepr =
|
|||||||
let inline augmentation () : SynTypeDefnRepr =
|
let inline augmentation () : SynTypeDefnRepr =
|
||||||
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0)
|
SynTypeDefnRepr.ObjectModel (SynTypeDefnKind.Augmentation range0, [], range0)
|
||||||
|
|
||||||
let inline union (cases : SynUnionCase list) : SynTypeDefnRepr =
|
let inline unionWithAccess (implAccess : SynAccess option) (cases : SynUnionCase list) : SynTypeDefnRepr =
|
||||||
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (None, cases, range0), range0)
|
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union (implAccess, cases, range0), range0)
|
||||||
|
|
||||||
let inline record (fields : SynField list) : SynTypeDefnRepr =
|
let inline union (cases : SynUnionCase list) : SynTypeDefnRepr = unionWithAccess None cases
|
||||||
SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record (None, fields, range0), range0)
|
|
||||||
|
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
|
||||||
|
@@ -5,44 +5,24 @@ open Fantomas.FCS.Text.Range
|
|||||||
open Fantomas.FCS.Xml
|
open Fantomas.FCS.Xml
|
||||||
open Fantomas.FCS.SyntaxTrivia
|
open Fantomas.FCS.SyntaxTrivia
|
||||||
|
|
||||||
type internal UnionCase<'Ident> =
|
/// Represents everything you need to know about a union case.
|
||||||
|
/// This is generic on whether each field of this case must be named.
|
||||||
|
type UnionCase<'ident> =
|
||||||
{
|
{
|
||||||
Fields : SynFieldData<'Ident> list
|
/// The name of the case: e.g. `| Foo of blah` has this being `Foo`.
|
||||||
Attrs : SynAttribute list
|
Name : Ident
|
||||||
Ident : Ident
|
/// Any docstring associated with this case.
|
||||||
|
XmlDoc : PreXmlDoc option
|
||||||
|
/// Any accessibility modifier: e.g. `type Foo = private | Blah`.
|
||||||
|
Access : SynAccess option
|
||||||
|
/// Attributes on the case: for example, `| [<Attr>] Foo of blah`.
|
||||||
|
Attributes : SynAttribute list
|
||||||
|
/// The data contained within the case: for example, `[blah]` in `| Foo of blah`.
|
||||||
|
Fields : SynFieldData<'ident> list
|
||||||
}
|
}
|
||||||
|
|
||||||
[<RequireQualifiedAccess>]
|
|
||||||
module internal UnionCase =
|
|
||||||
let mapIdentFields<'a, 'b> (f : 'a -> 'b) (unionCase : UnionCase<'a>) : UnionCase<'b> =
|
|
||||||
{
|
|
||||||
Fields = unionCase.Fields |> List.map (SynField.mapIdent f)
|
|
||||||
Attrs = unionCase.Attrs
|
|
||||||
Ident = unionCase.Ident
|
|
||||||
}
|
|
||||||
|
|
||||||
[<RequireQualifiedAccess>]
|
[<RequireQualifiedAccess>]
|
||||||
module internal SynUnionCase =
|
module internal SynUnionCase =
|
||||||
let extract (SynUnionCase (attrs, id, caseType, _, _, _, _)) : UnionCase<Ident option> =
|
|
||||||
match caseType with
|
|
||||||
| SynUnionCaseKind.FullType _ -> failwith "WoofWare.Myriad does not support FullType union cases."
|
|
||||||
| SynUnionCaseKind.Fields fields ->
|
|
||||||
|
|
||||||
let fields = fields |> List.map SynField.extract
|
|
||||||
|
|
||||||
let id =
|
|
||||||
match id with
|
|
||||||
| SynIdent.SynIdent (ident, _) -> ident
|
|
||||||
|
|
||||||
// As far as I can tell, there's no way to get any attributes here? :shrug:
|
|
||||||
let attrs = attrs |> List.collect (fun l -> l.Attributes)
|
|
||||||
|
|
||||||
{
|
|
||||||
Fields = fields
|
|
||||||
Attrs = attrs
|
|
||||||
Ident = id
|
|
||||||
}
|
|
||||||
|
|
||||||
let create (case : UnionCase<Ident>) : SynUnionCase =
|
let create (case : UnionCase<Ident>) : SynUnionCase =
|
||||||
let fields =
|
let fields =
|
||||||
case.Fields
|
case.Fields
|
||||||
@@ -63,11 +43,11 @@ module internal SynUnionCase =
|
|||||||
)
|
)
|
||||||
|
|
||||||
SynUnionCase.SynUnionCase (
|
SynUnionCase.SynUnionCase (
|
||||||
SynAttributes.ofAttrs case.Attrs,
|
SynAttributes.ofAttrs case.Attributes,
|
||||||
SynIdent.SynIdent (case.Ident, None),
|
SynIdent.SynIdent (case.Name, None),
|
||||||
SynUnionCaseKind.Fields fields,
|
SynUnionCaseKind.Fields fields,
|
||||||
PreXmlDoc.Empty,
|
case.XmlDoc |> Option.defaultValue PreXmlDoc.Empty,
|
||||||
None,
|
case.Access,
|
||||||
range0,
|
range0,
|
||||||
{
|
{
|
||||||
BarRange = Some range0
|
BarRange = Some range0
|
||||||
|
@@ -1,5 +1,5 @@
|
|||||||
{
|
{
|
||||||
"version": "2.2",
|
"version": "2.3",
|
||||||
"publicReleaseRefSpec": [
|
"publicReleaseRefSpec": [
|
||||||
"^refs/heads/main$"
|
"^refs/heads/main$"
|
||||||
],
|
],
|
||||||
|
6
flake.lock
generated
6
flake.lock
generated
@@ -20,11 +20,11 @@
|
|||||||
},
|
},
|
||||||
"nixpkgs": {
|
"nixpkgs": {
|
||||||
"locked": {
|
"locked": {
|
||||||
"lastModified": 1725099143,
|
"lastModified": 1725534445,
|
||||||
"narHash": "sha256-CHgumPZaC7z+WYx72WgaLt2XF0yUVzJS60rO4GZ7ytY=",
|
"narHash": "sha256-Yd0FK9SkWy+ZPuNqUgmVPXokxDgMJoGuNpMEtkfcf84=",
|
||||||
"owner": "NixOS",
|
"owner": "NixOS",
|
||||||
"repo": "nixpkgs",
|
"repo": "nixpkgs",
|
||||||
"rev": "5629520edecb69630a3f4d17d3d33fc96c13f6fe",
|
"rev": "9bb1e7571aadf31ddb4af77fc64b2d59580f9a39",
|
||||||
"type": "github"
|
"type": "github"
|
||||||
},
|
},
|
||||||
"original": {
|
"original": {
|
||||||
|
20
nix/deps.nix
20
nix/deps.nix
@@ -8,8 +8,8 @@
|
|||||||
})
|
})
|
||||||
(fetchNuGet {
|
(fetchNuGet {
|
||||||
pname = "fantomas";
|
pname = "fantomas";
|
||||||
version = "6.3.11";
|
version = "6.3.12";
|
||||||
hash = "sha256-11bHGEAZTNtdp2pTg5zqLrQiyI/j/AT7GGL/2CR4+dw=";
|
hash = "sha256-LFZn2cO72FlsmLI0vTLz52Bn4XBeGILTOr8rz/EuXeg=";
|
||||||
})
|
})
|
||||||
(fetchNuGet {
|
(fetchNuGet {
|
||||||
pname = "Fantomas.Core";
|
pname = "Fantomas.Core";
|
||||||
@@ -78,13 +78,13 @@
|
|||||||
})
|
})
|
||||||
(fetchNuGet {
|
(fetchNuGet {
|
||||||
pname = "Microsoft.CodeCoverage";
|
pname = "Microsoft.CodeCoverage";
|
||||||
version = "17.11.0";
|
version = "17.11.1";
|
||||||
hash = "sha256-XglInnx5GePUYHG7n2NLX+WfK7kJnornsWOW/5FnOXE=";
|
hash = "sha256-1dLlK3NGh88PuFYZiYpT+izA96etxhU3BSgixDgdtGA=";
|
||||||
})
|
})
|
||||||
(fetchNuGet {
|
(fetchNuGet {
|
||||||
pname = "Microsoft.NET.Test.Sdk";
|
pname = "Microsoft.NET.Test.Sdk";
|
||||||
version = "17.11.0";
|
version = "17.11.1";
|
||||||
hash = "sha256-WjyA78+PG9ZloWTt9Hf1ek3VVj2FfJ9fAjqklnN+fWw=";
|
hash = "sha256-0JUEucQ2lzaPgkrjm/NFLBTbqU1dfhvhN3Tl3moE6mI=";
|
||||||
})
|
})
|
||||||
(fetchNuGet {
|
(fetchNuGet {
|
||||||
pname = "Microsoft.NETCore.App.Host.linux-arm64";
|
pname = "Microsoft.NETCore.App.Host.linux-arm64";
|
||||||
@@ -153,13 +153,13 @@
|
|||||||
})
|
})
|
||||||
(fetchNuGet {
|
(fetchNuGet {
|
||||||
pname = "Microsoft.TestPlatform.ObjectModel";
|
pname = "Microsoft.TestPlatform.ObjectModel";
|
||||||
version = "17.11.0";
|
version = "17.11.1";
|
||||||
hash = "sha256-mCI3MCV6nyrGLrBat5VvK5LrXTEKlsdp9NkpZyJYwVg=";
|
hash = "sha256-5vX+vCzFY3S7xfMVIv8OlMMFtdedW9UIJzc0WEc+vm4=";
|
||||||
})
|
})
|
||||||
(fetchNuGet {
|
(fetchNuGet {
|
||||||
pname = "Microsoft.TestPlatform.TestHost";
|
pname = "Microsoft.TestPlatform.TestHost";
|
||||||
version = "17.11.0";
|
version = "17.11.1";
|
||||||
hash = "sha256-gViDLobza22kuLvB4JdlGtbANqwBHRwf1wLmIHMw9Eo=";
|
hash = "sha256-wSkY0H1fQAq0H3LcKT4u7Y5RzhAAPa6yueVN84g8HxU=";
|
||||||
})
|
})
|
||||||
(fetchNuGet {
|
(fetchNuGet {
|
||||||
pname = "Myriad.Core";
|
pname = "Myriad.Core";
|
||||||
|
Reference in New Issue
Block a user