Skip to content

Commit 39e388e

Browse files
Smaug123Smaug123
committed
ArgParser: read ArgumentHelpText from union cases and their payload records
A discriminated-union case's payload record has no field of its own for a GroupHeader to attach to (unlike a nested record reached through a field), so its own ArgumentHelpText, and any on the case itself, were both silently ignored: only the bare case name appeared in help text. ParseTree.Sum's cases now carry an optional help SynExpr, read from the case's attributes falling back to the payload record's, and sumHelp renders it through the same groupLine machinery as a field's header.
1 parent 0153210 commit 39e388e

8 files changed

Lines changed: 264 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.Attributes/ArgParserAttributes.fs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -101,6 +101,12 @@ type ArgumentDefaultValueAttribute (defaultValue : obj) =
101101
/// embedded, and so heads the group in each place. If the field which embeds it carries an
102102
/// [<ArgumentHelpText>] of its own, the field's wins: it is the more specific placement, and one type
103103
/// may be embedded at several sites for different purposes.
104+
///
105+
/// When applied to a case of a discriminated union of alternative argument sets, the help text
106+
/// describes that case's set of arguments, and appears on the header line naming the case. A case
107+
/// is not reached through a field, so its payload record's own [<ArgumentHelpText>] (if the payload
108+
/// is used in only that one case) is the fallback instead; the case, being the more specific
109+
/// placement, overrides it.
104110
type ArgumentHelpTextAttribute (helpText : string) =
105111
inherit Attribute ()
106112

0 commit comments

Comments
 (0)