Compare commits

...

12 Commits

Author SHA1 Message Date
Patrick Stevens
693b95106a Also pipe through parser in PositionalArgs true (#259) 2024-09-13 16:11:53 +00:00
Patrick Stevens
49ecfbf5e5 Fix includeFlagLike when arg doesn't have an equals (#257) 2024-09-12 22:10:08 +00:00
Patrick Stevens
5748ac3d5b Allow consuming *all* args as positionals, not just ones which look like --foo (#255) 2024-09-11 19:00:04 +00:00
Patrick Stevens
913959a740 Make arg parser more AOT-friendly (#253) 2024-09-10 22:16:43 +01:00
dependabot[bot]
93ffc065cd Bump Microsoft.NET.Test.Sdk from 17.11.0 to 17.11.1 (#248)
* Bump Microsoft.NET.Test.Sdk from 17.11.0 to 17.11.1

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

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

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

* Bump fantomas from 6.3.11 to 6.3.12

Bumps [fantomas](https://github.com/fsprojects/fantomas) from 6.3.11 to 6.3.12.
- [Release notes](https://github.com/fsprojects/fantomas/releases)
- [Changelog](https://github.com/fsprojects/fantomas/blob/main/CHANGELOG.md)
- [Commits](https://github.com/fsprojects/fantomas/compare/v6.3.11...v6.3.12)

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

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

* Deps

---------

Signed-off-by: dependabot[bot] <support@github.com>
Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com>
Co-authored-by: Smaug123 <3138005+Smaug123@users.noreply.github.com>
2024-09-09 19:33:39 +00:00
dependabot[bot]
d14efba7e7 Bump actions/attest-build-provenance from 1.4.2 to 1.4.3 (#247) 2024-09-09 12:42:12 +01:00
patrick-conscriptus[bot]
f5cf0b79dd Automated commit (#246)
Co-authored-by: patrick-conscriptus[bot] <175414948+patrick-conscriptus[bot]@users.noreply.github.com>
2024-09-08 01:20:34 +00:00
Patrick Stevens
029e3746bb Fix record/union impl accessibility (#245) 2024-09-07 08:49:28 +00:00
Patrick Stevens
8ae749c529 Add ArgumentLongForm (#244) 2024-09-05 21:26:52 +01:00
Patrick Stevens
e4cbab3209 Implement [<ArgumentFlag>] for two-case DUs (#242) 2024-09-04 21:48:36 +00:00
Patrick Stevens
bdce82fb7a Handle env vars with value 0 and 1 for bools (#241) 2024-09-04 21:06:22 +01:00
Patrick Stevens
8f9f933971 Handle URI in arg parser (#240) 2024-09-04 20:20:51 +01:00
26 changed files with 3501 additions and 547 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@@ -1,5 +1,5 @@
{ {
"version": "3.2", "version": "3.5",
"publicReleaseRefSpec": [ "publicReleaseRefSpec": [
"^refs/heads/main$" "^refs/heads/main$"
], ],
@@ -12,4 +12,4 @@
"./", "./",
":^Test" ":^Test"
] ]
} }

View File

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

View File

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

View File

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

View File

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

View File

@@ -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 = []
} }

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

6
flake.lock generated
View File

@@ -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": {

View File

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