Skip to content

Commit f609305

Browse files
Smaug123Smaug123
committed
Merge branch 'argparser-union-case-help' into argparser-nested-type-help
2 parents 4651c90 + 39e388e commit f609305

7 files changed

Lines changed: 258 additions & 39 deletions

File tree

‎CHANGELOG.md‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,11 @@
11
Notable changes are recorded here.
22

3+
# WoofWare.Myriad.Plugins 10.7.3
4+
5+
`ArgParserGenerator` now reads `[<ArgumentHelpText>]` from a discriminated union's case, and from that case's payload record, and heads the case's group in help text with it.
6+
Previously a case's payload record's own `[<ArgumentHelpText>]` was silently dropped: only the case name appeared, with no way to describe the case itself (a case is not reached through a field, so the field-level mechanism which reads a nested record's own help text does not apply to it).
7+
An `[<ArgumentHelpText>]` on the case itself overrides the one on its payload record, for the same reason a field's overrides a nested record's: the case is the more specific placement.
8+
39
# WoofWare.Myriad.Plugins 10.7.2
410

511
`ArgParserGenerator` now reads `[<ArgumentHelpText>]` from a nested argument record or union of alternative argument sets, and not only from the `[<ArgParser>]`-tagged root.

‎ConsumePlugin/DuArgs.fs‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -104,6 +104,27 @@ type WithTransportArgs =
104104
Fallback : Transport
105105
}
106106

107+
[<ArgumentHelpText "Fetch a URL">]
108+
type FetchWithHelpArgs =
109+
{
110+
Url : string
111+
}
112+
113+
[<ArgumentHelpText "Push args, not that you'd know it from the case header">]
114+
type PushWithHelpArgs =
115+
{
116+
Remote : string
117+
}
118+
119+
/// A case's payload record may describe itself, for the benefit of that case; a case is not
120+
/// reached through a field, so there is no field-level attribute to check first, but the case
121+
/// itself is a more specific placement than its payload record and so overrides it, exactly as
122+
/// a field overrides a nested record's own description.
123+
[<ArgParser>]
124+
type CommandWithHelp =
125+
| FetchCase of FetchWithHelpArgs
126+
| [<ArgumentHelpText "Push to a remote">] PushCase of PushWithHelpArgs
127+
107128
/// A union beside a positional sink (default, i.e. Reject-mode): named arguments select the
108129
/// union case, and every bare token is routed to the sink whichever case wins. An unrecognised
109130
/// `--key`-shaped token remains fatal. The sink converts, so selection must not depend on the

‎ConsumePlugin/GeneratedDuArgs.fs‎

Lines changed: 182 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -1423,9 +1423,9 @@ module DuArgs =
14231423
let helpText () =
14241424
[
14251425
"exactly one of the following sets of arguments:"
1426-
"FooCase:"
1426+
(sprintf "%s:" "FooCase")
14271427
(sprintf " %s %s%s%s" (sprintf "--%s" "foo") "int32" "" (sprintf " : %s" ("The foo argument")))
1428-
"BarCase:"
1428+
(sprintf "%s:" "BarCase")
14291429
(sprintf " %s %s%s%s" (sprintf "--%s" "bar") "int32" "" "")
14301430
(sprintf " %s %s%s%s" (sprintf "--%s" "baz") "int32" "" "")
14311431
]
@@ -1627,9 +1627,9 @@ module WithModeArgs =
16271627
(sprintf "%s %s%s%s" (sprintf "--%s" "verbose") "bool" "" "")
16281628
(sprintf "%s:" "Mode")
16291629
" exactly one of the following sets of arguments:"
1630-
" Auto:"
1630+
(sprintf "%s:" " Auto")
16311631
(sprintf " %s %s%s%s" (sprintf "--%s" "quiet") "bool" " (optional)" "")
1632-
" Manual:"
1632+
(sprintf "%s:" " Manual")
16331633
(sprintf " %s %s%s%s" (sprintf "--%s" "level") "int32" "" "")
16341634
]
16351635
|> String.concat "\n"
@@ -1834,7 +1834,7 @@ module DuWithDefaultArgs =
18341834
let helpText () =
18351835
[
18361836
"exactly one of the following sets of arguments:"
1837-
"Defaulted:"
1837+
(sprintf "%s:" "Defaulted")
18381838

18391839
(sprintf
18401840
" %s %s%s%s"
@@ -1843,7 +1843,7 @@ module DuWithDefaultArgs =
18431843
(DefaultedArgs.DefaultRetries().ToString () |> sprintf " (default value: %s)")
18441844
"")
18451845

1846-
"Plain:"
1846+
(sprintf "%s:" "Plain")
18471847
(sprintf " %s %s%s%s" (sprintf "--%s" "value") "int32" "" "")
18481848
]
18491849
|> String.concat "\n"
@@ -2007,9 +2007,9 @@ module WithModeHelpArgs =
20072007
(sprintf "%s %s%s%s" (sprintf "--%s" "verbose") "bool" "" "")
20082008
(sprintf "%s: %s" "Mode" ("How loud to be"))
20092009
" exactly one of the following sets of arguments:"
2010-
" Auto:"
2010+
(sprintf "%s:" " Auto")
20112011
(sprintf " %s %s%s%s" (sprintf "--%s" "quiet") "bool" " (optional)" "")
2012-
" Manual:"
2012+
(sprintf "%s:" " Manual")
20132013
(sprintf " %s %s%s%s" (sprintf "--%s" "level") "int32" "" "")
20142014
]
20152015
|> String.concat "\n"
@@ -2215,15 +2215,15 @@ module WithTransportArgs =
22152215
[
22162216
(sprintf "%s: %s" "Preferred" ("Try this one first"))
22172217
" exactly one of the following sets of arguments:"
2218-
" Tcp:"
2218+
(sprintf "%s:" " Tcp")
22192219
(sprintf " %s %s%s%s" (sprintf "--%s" "preferred-tcp-port") "int32" "" "")
2220-
" Unix:"
2220+
(sprintf "%s:" " Unix")
22212221
(sprintf " %s %s%s%s" (sprintf "--%s" "preferred-socket-path") "string" "" "")
22222222
(sprintf "%s: %s" "Fallback" ("Which transport to use"))
22232223
" exactly one of the following sets of arguments:"
2224-
" Tcp:"
2224+
(sprintf "%s:" " Tcp")
22252225
(sprintf " %s %s%s%s" (sprintf "--%s" "fallback-tcp-port") "int32" "" "")
2226-
" Unix:"
2226+
(sprintf "%s:" " Unix")
22272227
(sprintf " %s %s%s%s" (sprintf "--%s" "fallback-socket-path") "string" "" "")
22282228
]
22292229
|> String.concat "\n"
@@ -2485,6 +2485,166 @@ namespace ConsumePlugin
24852485

24862486
open WoofWare.Myriad.Plugins
24872487

2488+
/// Methods to parse arguments for the type CommandWithHelp
2489+
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
2490+
module CommandWithHelp =
2491+
let parse' (getEnvironmentVariable : string -> string option) (args : string list) : CommandWithHelp =
2492+
let helpText () =
2493+
[
2494+
"exactly one of the following sets of arguments:"
2495+
(sprintf "%s: %s" "FetchCase" ("Fetch a URL"))
2496+
(sprintf " %s %s%s%s" (sprintf "--%s" "url") "string" "" "")
2497+
(sprintf "%s: %s" "PushCase" ("Push to a remote"))
2498+
(sprintf " %s %s%s%s" (sprintf "--%s" "remote") "string" "" "")
2499+
]
2500+
|> String.concat "\n"
2501+
2502+
let parser_LeftoverArgs : string ResizeArray = ResizeArray ()
2503+
let mutable arg_1 : string option = None
2504+
let mutable arg_2 : string option = None
2505+
2506+
let parser_schema : ArgParserRuntime_DuArgs.ErasedSchema =
2507+
{
2508+
Leaves =
2509+
[
2510+
{
2511+
Id = 0
2512+
Forms = [ "url" ]
2513+
AcceptsNegation = false
2514+
Arity = ArgParserRuntime_DuArgs.ErasedArity.One
2515+
Repeatable = false
2516+
Requirement = ArgParserRuntime_DuArgs.ErasedRequirement.Required
2517+
TypeDescription = ""
2518+
Help = None
2519+
}
2520+
{
2521+
Id = 1
2522+
Forms = [ "remote" ]
2523+
AcceptsNegation = false
2524+
Arity = ArgParserRuntime_DuArgs.ErasedArity.One
2525+
Repeatable = false
2526+
Requirement = ArgParserRuntime_DuArgs.ErasedRequirement.Required
2527+
TypeDescription = ""
2528+
Help = None
2529+
}
2530+
]
2531+
Tree =
2532+
(ArgParserRuntime_DuArgs.ErasedTree.Sum (
2533+
(0,
2534+
[
2535+
("FetchCase",
2536+
ArgParserRuntime_DuArgs.ErasedTree.Product ([ ArgParserRuntime_DuArgs.ErasedTree.Leaf 0 ]))
2537+
("PushCase",
2538+
ArgParserRuntime_DuArgs.ErasedTree.Product ([ ArgParserRuntime_DuArgs.ErasedTree.Leaf 1 ]))
2539+
])
2540+
))
2541+
Positionals = List.empty
2542+
}
2543+
2544+
let parser_storeOccurrence (occurrence : ArgParserRuntime_DuArgs.ErasedOccurrence) : string option =
2545+
match occurrence.LeafId with
2546+
| 0 ->
2547+
match arg_1 with
2548+
| Some _ -> None
2549+
| None ->
2550+
match occurrence.Value with
2551+
| Some value ->
2552+
try
2553+
arg_1 <- Some (value |> (fun x -> x))
2554+
None
2555+
with _ as exc ->
2556+
(sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some
2557+
| None ->
2558+
failwith
2559+
"WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value"
2560+
| 1 ->
2561+
match arg_2 with
2562+
| Some _ -> None
2563+
| None ->
2564+
match occurrence.Value with
2565+
| Some value ->
2566+
try
2567+
arg_2 <- Some (value |> (fun x -> x))
2568+
None
2569+
with _ as exc ->
2570+
(sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some
2571+
| None ->
2572+
failwith
2573+
"WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value"
2574+
| _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown argument id"
2575+
2576+
let parser_storePositional (positionalId : int) (value : string) (afterSeparator : bool) : string option =
2577+
failwith "WoofWare.Myriad internal error in generated parser: no positional sink exists"
2578+
2579+
let parser_renderStored (leafId : int) : string =
2580+
match leafId with
2581+
| 0 ->
2582+
match arg_1 with
2583+
| Some x -> x.ToString ()
2584+
| None -> "<no value>"
2585+
| 1 ->
2586+
match arg_2 with
2587+
| Some x -> x.ToString ()
2588+
| None -> "<no value>"
2589+
| _ -> "<no value>"
2590+
2591+
let parser_applyDefault (leafId : int) : string option =
2592+
match leafId with
2593+
| _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown defaulted argument id"
2594+
2595+
let parser_callbacks : ArgParserRuntime_DuArgs.TypedCallbacks =
2596+
{
2597+
StoreOccurrence = parser_storeOccurrence
2598+
StorePositional = parser_storePositional
2599+
HelpText = helpText
2600+
RenderStored = parser_renderStored
2601+
ApplyDefault = parser_applyDefault
2602+
}
2603+
2604+
match
2605+
ArgParserRuntime_DuArgs.runParse
2606+
(ArgParserRuntime_DuArgs.WellFormedSchema.checkOrFail parser_schema)
2607+
parser_callbacks
2608+
args
2609+
with
2610+
| ArgParserRuntime_DuArgs.ParseOutcome.Success parser_selection ->
2611+
match Map.tryFind 0 parser_selection.Choices with
2612+
| Some 0 ->
2613+
CommandWithHelp.FetchCase (
2614+
{
2615+
Url =
2616+
(match arg_1 with
2617+
| Some x -> x
2618+
| None ->
2619+
failwith
2620+
"WoofWare.Myriad internal error in generated parser: required argument missing after successful parse")
2621+
}
2622+
)
2623+
| Some 1 ->
2624+
CommandWithHelp.PushCase (
2625+
{
2626+
Remote =
2627+
(match arg_2 with
2628+
| Some x -> x
2629+
| None ->
2630+
failwith
2631+
"WoofWare.Myriad internal error in generated parser: required argument missing after successful parse")
2632+
}
2633+
)
2634+
| _ ->
2635+
failwith
2636+
"WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse"
2637+
| ArgParserRuntime_DuArgs.ParseOutcome.HelpRequested -> helpText () |> failwithf "Help text requested.\n%s"
2638+
| ArgParserRuntime_DuArgs.ParseOutcome.Fatal message -> failwith message
2639+
| ArgParserRuntime_DuArgs.ParseOutcome.Errors errors ->
2640+
errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s"
2641+
2642+
let parse (args : string list) : CommandWithHelp =
2643+
parse' (System.Environment.GetEnvironmentVariable >> Option.ofObj) args
2644+
namespace ConsumePlugin
2645+
2646+
open WoofWare.Myriad.Plugins
2647+
24882648
/// Methods to parse arguments for the type ModeAndPositionals
24892649
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
24902650
module ModeAndPositionals =
@@ -2493,9 +2653,9 @@ module ModeAndPositionals =
24932653
[
24942654
(sprintf "%s:" "Mode")
24952655
" exactly one of the following sets of arguments:"
2496-
" Auto:"
2656+
(sprintf "%s:" " Auto")
24972657
(sprintf " %s %s%s%s" (sprintf "--%s" "quiet") "bool" " (optional)" "")
2498-
" Manual:"
2658+
(sprintf "%s:" " Manual")
24992659
(sprintf " %s %s%s%s" (sprintf "--%s" "level") "int32" "" "")
25002660
(sprintf "%s %s%s%s" (sprintf "--%s" "rest") "int32" " (positional args) (can be repeated)" "")
25012661
]
@@ -2681,9 +2841,9 @@ module CommandAndPositionals =
26812841
[
26822842
(sprintf "%s:" "Command")
26832843
" exactly one of the following sets of arguments:"
2684-
" Fetch:"
2844+
(sprintf "%s:" " Fetch")
26852845
(sprintf " %s %s%s%s" (sprintf "--%s" "url") "string" "" "")
2686-
" Push:"
2846+
(sprintf "%s:" " Push")
26872847
(sprintf " %s %s%s%s" (sprintf "--%s" "remote") "string" "" "")
26882848
(sprintf " %s %s%s%s" (sprintf "--%s" "force") "bool" "" "")
26892849
(sprintf "%s %s%s%s" (sprintf "--%s" "paths") "string" " (positional args) (can be repeated)" "")
@@ -2917,10 +3077,10 @@ module FooBarMode =
29173077
let helpText () =
29183078
[
29193079
"exactly one of the following sets of arguments:"
2920-
"FooMode:"
3080+
(sprintf "%s:" "FooMode")
29213081
(sprintf " %s %s%s%s" (sprintf "--%s" "foo") "int32" "" "")
29223082
(sprintf " %s %s%s%s" (sprintf "--%s" "rest") "int32" " (positional args) (can be repeated)" "")
2923-
"BarMode:"
3083+
(sprintf "%s:" "BarMode")
29243084
(sprintf " %s %s%s%s" (sprintf "--%s" "bar") "int32" "" "")
29253085
(sprintf " %s %s%s%s" (sprintf "--%s" "rest") "string" " (positional args) (can be repeated)" "")
29263086
]
@@ -3121,10 +3281,10 @@ module GitLike =
31213281
let helpText () =
31223282
[
31233283
"exactly one of the following sets of arguments:"
3124-
"Pull:"
3284+
(sprintf "%s:" "Pull")
31253285
(sprintf " %s %s%s%s" (sprintf "--%s" "source") "string" "" "")
31263286
(sprintf " %s %s%s%s" (sprintf "--%s" "refs") "string" " (positional args) (can be repeated)" "")
3127-
"Status:"
3287+
(sprintf "%s:" "Status")
31283288
(sprintf " %s %s%s%s" (sprintf "--%s" "verbose") "bool" " (optional)" "")
31293289
]
31303290
|> String.concat "\n"
@@ -3946,7 +4106,7 @@ module EnumInUnion =
39464106
let helpText () =
39474107
[
39484108
"exactly one of the following sets of arguments:"
3949-
"Build:"
4109+
(sprintf "%s:" "Build")
39504110

39514111
(sprintf
39524112
" %s %s%s%s"
@@ -3955,7 +4115,7 @@ module EnumInUnion =
39554115
""
39564116
"")
39574117

3958-
"Clean:"
4118+
(sprintf "%s:" "Clean")
39594119
(sprintf " %s %s%s%s" (sprintf "--%s" "force") "bool" " (optional)" "")
39604120
]
39614121
|> String.concat "\n"

‎ConsumePlugin/GeneratedMapArgs.fs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2054,9 +2054,9 @@ module MapInUnion =
20542054
let helpText () =
20552055
[
20562056
"exactly one of the following sets of arguments:"
2057-
"Deploy:"
2057+
(sprintf "%s:" "Deploy")
20582058
(sprintf " %s %s%s%s" (sprintf "--%s" "tags") "map<string, string>" " (KEY:VALUE; can be repeated)" "")
2059-
"Rollback:"
2059+
(sprintf "%s:" "Rollback")
20602060
(sprintf " %s %s%s%s" (sprintf "--%s" "to") "string" "" "")
20612061
]
20622062
|> String.concat "\n"

‎ConsumePlugin/GeneratedPrefixArgs.fs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3079,9 +3079,9 @@ module PrefixedUnionArgParse =
30793079
[
30803080
(sprintf "%s:" "Mode")
30813081
" exactly one of the following sets of arguments:"
3082-
" Auto:"
3082+
(sprintf "%s:" " Auto")
30833083
(sprintf " %s %s%s%s" (sprintf "--%s" "mode-quiet") "bool" " (optional)" "")
3084-
" Manual:"
3084+
(sprintf "%s:" " Manual")
30853085
(sprintf " %s %s%s%s" (sprintf "--%s" "mode-level") "int32" "" "")
30863086
]
30873087
|> String.concat "\n"

‎WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParserDu.fs‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -202,6 +202,22 @@ Mode: How loud to be
202202
Manual:
203203
--level int32"""
204204

205+
/// A case's payload record has no field of its own to be embedded through, so it can only
206+
/// describe itself and be overridden by the case: there is no third, more specific layer.
207+
[<Test>]
208+
let ``A case's payload record describes itself, and the case's own help text overrides it`` () =
209+
let exc =
210+
Assert.Throws<exn> (fun () -> CommandWithHelp.parse' noEnv [ "--help" ] |> ignore<CommandWithHelp>)
211+
212+
exc.Message
213+
|> shouldEqual
214+
"""Help text requested.
215+
exactly one of the following sets of arguments:
216+
FetchCase: Fetch a URL
217+
--url string
218+
PushCase: Push to a remote
219+
--remote string"""
220+
205221
/// As for a nested record: the union describes itself for every site which embeds it, and a
206222
/// field with something more specific to say overrides that.
207223
[<Test>]

0 commit comments

Comments
 (0)