diff --git a/CHANGELOG.md b/CHANGELOG.md index d6b8d34..e17975c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,27 @@ Notable changes are recorded here. +# Unreleased + +`ArgParserGenerator` now supports a field of type `SomeArgs option`, where `SomeArgs` is another argument record or a union of alternative argument sets: a whole group of arguments which need not be supplied. + +The group is present exactly when at least one argument beneath it was supplied — the same rule by which a union's case is selected — and its own required arguments are then enforced as usual, so supplying part of a group demands the rest of it rather than quietly treating the group as absent. +Help text introduces the group under a `Child (optional):` header rather than presenting it as an alternation: the two alternatives it is implemented with are the generator's, not the author's. + +`Choice` works the same way, and says that omitting the group means a particular value rather than no value: `Choice2Of2` carries the default and `Choice1Of2` what was supplied, exactly as for a defaulted leaf. +The default must come from `[]`, since neither a literal nor an environment variable can construct a record; and it is all-or-nothing, so supplying part of a group still demands the rest rather than filling the gaps from the default. + +A group which is itself satisfiable by supplying nothing cannot be wrapped, and is rejected at generation time. +No command line could distinguish "this group was supplied, and everything in it took its default" from "this group was never mentioned", so there is a real modelling question here, and the generated parser should not answer it by silently preferring one. + +Bugfix: `ArgParserGenerator` now backticks the `Default`-prefixed member name a defaulted field calls. +A field named `` `` `` ``space in name`` `` `` `` takes its default from `` `` `` ``Defaultspace in name`` `` `` ``, which was emitted bare, so the generated file did not parse. +This affected defaulted leaves (and their help text) as well as the newly-supported defaulted groups. + +`ArgParserGenerator` now reports a proper error for a field of type `'a list list` or `'a option list`. + +Both shapes were already unsupported, but only the `[]` path said so: on the ordinary path they passed classification and failed much later against an assertion phrased as an internal error ("WoofWare.Myriad invariant violated"), despite being reachable from ordinary source. +Both paths now give the same message, which says why the shape has no spelling: each occurrence supplies one element, so nothing marks where one inner list ends and the next begins, and an absent element would be an occurrence which is not there. + # WoofWare.Myriad.Plugins 11.0.1 Breaking change: `ArgParserGenerator` now rejects, at generation time, several attribute placements which it previously accepted and then silently ignored. diff --git a/ConsumePlugin/Args.fs b/ConsumePlugin/Args.fs index 53c1354..553abf9 100644 --- a/ConsumePlugin/Args.fs +++ b/ConsumePlugin/Args.fs @@ -188,6 +188,64 @@ type ParentRecordWithEscapedHelp = Child : ChildRecord } +/// A whole group of arguments may be omitted. Supplying none of `ChildRecord`'s arguments makes +/// the field `None`; supplying any of them makes it `Some`, and `ChildRecord`'s own required +/// arguments are then enforced as usual. +[] +type ParentRecordOptionalChild = + { + Child : ChildRecord option + AndAnother : bool + } + +/// An optional group whose header carries help text, and which contains a positional sink. The +/// sink accepts zero tokens, but `Thing1` is required, so the group as a whole is not satisfiable +/// by an empty command line and can therefore be told apart from its own absence. +[] +type ParentRecordOptionalChildPos = + { + [] + Child : ChildRecordWithPositional option + } + +/// A group of arguments which need not be supplied, but which stands for a value rather than for +/// nothing when it is omitted. As for a defaulted leaf, the Choice reports which happened. +[] +type ParentRecordDefaultedChild = + { + [] + Child : Choice + AndAnother : bool + } + + /// The default-function convention resolves against the record which declares the field, + /// exactly as it does for a leaf. + static member DefaultChild () : ChildRecord = + { + Thing1 = 42 + Thing2 = "from the default" + } + +type GrandchildRecord = + { + Deep : int + } + +/// An optional group may contain one, and may be namespaced like any other structural field. +/// The inner group's absence does not make the outer group absent: `Thing1` is what decides that. +type ChildWithOptionalGrandchild = + { + Thing1 : int + Grandchild : GrandchildRecord option + } + +[] +type ParentRecordNestedOptional = + { + [] + Child : ChildWithOptionalGrandchild option + } + [] type ChoicePositionals = { @@ -413,3 +471,33 @@ type AwkwardFieldName = ``__LINE__`` : int ``break`` : int } + +/// A defaulted field's default comes from a static member named `Default` + the field name, so an +/// awkward field name makes an awkward *member* name, which needs backticks at the call site +/// exactly as its declaration did. `Default` + `mod` is the perfectly ordinary `Defaultmod`, so +/// the names here are ones which stay awkward after the prefix is glued on. +/// +/// Three separate emission sites call that member: a defaulted leaf's `parser_applyDefault`, a +/// defaulted group's instantiation, and the help text, which renders a leaf's default by calling +/// the function at generated-program runtime. +[] +type AwkwardDefaultName = + { + [] + ``space in name`` : Choice + + [] + [] + ``group name`` : Choice + + [] + ``optional group`` : ChildRecord option + } + + static member ``Defaultspace in name`` () = 5 + + static member ``Defaultgroup name`` () : ChildRecord = + { + Thing1 = 1 + Thing2 = "defaulted group" + } diff --git a/ConsumePlugin/DuArgs.fs b/ConsumePlugin/DuArgs.fs index d10f34d..215d68a 100644 --- a/ConsumePlugin/DuArgs.fs +++ b/ConsumePlugin/DuArgs.fs @@ -44,6 +44,45 @@ type WithModeArgs = Mode : Mode } +type CompressArgs = + { + Level : int + } + +type EncryptArgs = + { + Recipient : string + } + +/// Every case demands an argument, so no command line satisfies this union by saying nothing -- +/// which is what lets an absent group be told apart from a present one. +type Transform = + | Compress of CompressArgs + | Encrypt of EncryptArgs + +/// A union of alternative argument sets which need not be chosen among at all. +[] +type WithOptionalTransformArgs = + { + Verbose : bool + Transform : Transform option + } + +/// Not choosing among the alternatives means taking a particular one, rather than taking none. +[] +type WithDefaultedTransformArgs = + { + Verbose : bool + [] + Transform : Choice + } + + static member DefaultTransform () = + Transform.Compress + { + Level = 6 + } + type DefaultedArgs = { [] diff --git a/ConsumePlugin/GeneratedArgs.fs b/ConsumePlugin/GeneratedArgs.fs index aebb0e7..b76aba5 100644 --- a/ConsumePlugin/GeneratedArgs.fs +++ b/ConsumePlugin/GeneratedArgs.fs @@ -4649,6 +4649,807 @@ open System open System.IO open WoofWare.Myriad.Plugins +/// Methods to parse arguments for the type ParentRecordOptionalChild +[] +module ParentRecordOptionalChildArgParse = + /// Extension methods for argument parsing + type ParentRecordOptionalChild with + + static member parse' + (getEnvironmentVariable : string -> string option) + (args : string list) + : ParentRecordOptionalChild + = + let helpText () = + [ + (sprintf "%s:" "Child (optional)") + (sprintf " %s %s%s%s" (sprintf "--%s" "thing1") "int32" "" "") + (sprintf " %s %s%s%s" (sprintf "--%s" "thing2") "string" "" "") + (sprintf "%s %s%s%s" (sprintf "--%s" "and-another") "bool" "" "") + ] + |> String.concat "\n" + + let parser_LeftoverArgs : string ResizeArray = ResizeArray () + let mutable arg_1 : int option = None + let mutable arg_2 : string option = None + let mutable arg_3 : bool option = None + + let parser_schema : ArgParserRuntime_BasicNoPositionals.ErasedSchema = + { + Leaves = + [ + { + Id = 0 + Forms = [ "thing1" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + + { + Id = 1 + Forms = [ "thing2" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + { + Id = 2 + Forms = [ "and-another" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.BoolLike + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + ] + Tree = + (ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + [ + ArgParserRuntime_BasicNoPositionals.ErasedTree.Sum ( + (0, + [ + ("supplied", + ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + [ + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 0 + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 1 + ] + )) + ("absent", ArgParserRuntime_BasicNoPositionals.ErasedTree.Product (List.empty)) + ]) + ) + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 2 + ] + )) + Positionals = List.empty + } + + let parser_storeOccurrence + (occurrence : ArgParserRuntime_BasicNoPositionals.ErasedOccurrence) + : string option + = + match occurrence.LeafId with + | 0 -> + match arg_1 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_1 <- Some (value |> (fun x -> System.Int32.Parse x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | 1 -> + match arg_2 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_2 <- Some (value |> (fun x -> x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | 2 -> + match arg_3 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + let parsedBool = System.Boolean.Parse value + let parsedBool = if occurrence.Negated then not parsedBool else parsedBool + arg_3 <- Some (parsedBool) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + arg_3 <- Some ((if occurrence.Negated then false else true)) + None + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown argument id" + + let parser_storePositional (positionalId : int) (value : string) (afterSeparator : bool) : string option = + failwith "WoofWare.Myriad internal error in generated parser: no positional sink exists" + + let parser_renderStored (leafId : int) : string = + match leafId with + | 0 -> + match arg_1 with + | Some x -> x.ToString () + | None -> "" + | 1 -> + match arg_2 with + | Some x -> x.ToString () + | None -> "" + | 2 -> + match arg_3 with + | Some x -> x.ToString () + | None -> "" + | _ -> "" + + let parser_applyDefault (leafId : int) : string option = + match leafId with + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown defaulted argument id" + + let parser_callbacks : ArgParserRuntime_BasicNoPositionals.TypedCallbacks = + { + StoreOccurrence = parser_storeOccurrence + StorePositional = parser_storePositional + HelpText = helpText + RenderStored = parser_renderStored + ApplyDefault = parser_applyDefault + } + + match + ArgParserRuntime_BasicNoPositionals.runParse + (ArgParserRuntime_BasicNoPositionals.WellFormedSchema.checkOrFail parser_schema) + parser_callbacks + args + with + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Success parser_selection -> + { + AndAnother = + (match arg_3 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + Child = + match Map.tryFind 0 parser_selection.Choices with + | Some 0 -> + Some ( + { + Thing1 = + (match arg_1 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + Thing2 = + (match arg_2 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + ) + | Some 1 -> None + | _ -> + failwith + "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse" + } + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.HelpRequested -> + helpText () |> failwithf "Help text requested.\n%s" + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Fatal message -> failwith message + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Errors errors -> + errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + static member parse (args : string list) : ParentRecordOptionalChild = + ParentRecordOptionalChild.parse' (System.Environment.GetEnvironmentVariable >> Option.ofObj) args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type ParentRecordOptionalChildPos +[] +module ParentRecordOptionalChildPosArgParse = + /// Extension methods for argument parsing + type ParentRecordOptionalChildPos with + + static member parse' + (getEnvironmentVariable : string -> string option) + (args : string list) + : ParentRecordOptionalChildPos + = + let helpText () = + [ + (sprintf "%s: %s" "Child (optional)" ("Settings for the child thing")) + (sprintf " %s %s%s%s" (sprintf "--%s" "thing1") "int32" "" "") + (sprintf " %s %s%s%s" (sprintf "--%s" "thing2") "URI" " (positional args) (can be repeated)" "") + ] + |> String.concat "\n" + + let arg_2 : Uri ResizeArray = ResizeArray () + let mutable arg_1 : int option = None + + let parser_schema : ArgParserRuntime_BasicNoPositionals.ErasedSchema = + { + Leaves = + [ + { + Id = 0 + Forms = [ "thing1" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + ] + Tree = + (ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + [ + ArgParserRuntime_BasicNoPositionals.ErasedTree.Sum ( + (0, + [ + ("supplied", + ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + [ + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 0 + ArgParserRuntime_BasicNoPositionals.ErasedTree.PositionalLeaf 0 + ] + )) + ("absent", ArgParserRuntime_BasicNoPositionals.ErasedTree.Product (List.empty)) + ]) + ) + ] + )) + Positionals = + [ + { + Id = 0 + Forms = [ "thing2" ] + FlagLike = ArgParserRuntime_BasicNoPositionals.ErasedFlagLikeBehaviour.Reject + TypeDescription = "" + Help = None + } + ] + } + + let parser_storeOccurrence + (occurrence : ArgParserRuntime_BasicNoPositionals.ErasedOccurrence) + : string option + = + match occurrence.LeafId with + | 0 -> + match arg_1 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_1 <- Some (value |> (fun x -> System.Int32.Parse x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown argument id" + + let parser_storePositional (positionalId : int) (value : string) (afterSeparator : bool) : string option = + match positionalId with + | 0 -> + try + arg_2.Add (value |> (fun x -> System.Uri x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message value) |> Some + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown positional sink id" + + let parser_renderStored (leafId : int) : string = + match leafId with + | 0 -> + match arg_1 with + | Some x -> x.ToString () + | None -> "" + | _ -> "" + + let parser_applyDefault (leafId : int) : string option = + match leafId with + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown defaulted argument id" + + let parser_callbacks : ArgParserRuntime_BasicNoPositionals.TypedCallbacks = + { + StoreOccurrence = parser_storeOccurrence + StorePositional = parser_storePositional + HelpText = helpText + RenderStored = parser_renderStored + ApplyDefault = parser_applyDefault + } + + match + ArgParserRuntime_BasicNoPositionals.runParse + (ArgParserRuntime_BasicNoPositionals.WellFormedSchema.checkOrFail parser_schema) + parser_callbacks + args + with + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Success parser_selection -> + { + Child = + match Map.tryFind 0 parser_selection.Choices with + | Some 0 -> + Some ( + { + Thing1 = + (match arg_1 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + Thing2 = (arg_2 |> Seq.toList) + } + ) + | Some 1 -> None + | _ -> + failwith + "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse" + } + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.HelpRequested -> + helpText () |> failwithf "Help text requested.\n%s" + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Fatal message -> failwith message + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Errors errors -> + errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + static member parse (args : string list) : ParentRecordOptionalChildPos = + ParentRecordOptionalChildPos.parse' (System.Environment.GetEnvironmentVariable >> Option.ofObj) args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type ParentRecordDefaultedChild +[] +module ParentRecordDefaultedChildArgParse = + /// Extension methods for argument parsing + type ParentRecordDefaultedChild with + + static member parse' + (getEnvironmentVariable : string -> string option) + (args : string list) + : ParentRecordDefaultedChild + = + let helpText () = + [ + (sprintf "%s:" "Child (optional; a default is used if omitted)") + (sprintf " %s %s%s%s" (sprintf "--%s" "thing1") "int32" "" "") + (sprintf " %s %s%s%s" (sprintf "--%s" "thing2") "string" "" "") + (sprintf "%s %s%s%s" (sprintf "--%s" "and-another") "bool" "" "") + ] + |> String.concat "\n" + + let parser_LeftoverArgs : string ResizeArray = ResizeArray () + let mutable arg_1 : int option = None + let mutable arg_2 : string option = None + let mutable arg_3 : bool option = None + + let parser_schema : ArgParserRuntime_BasicNoPositionals.ErasedSchema = + { + Leaves = + [ + { + Id = 0 + Forms = [ "thing1" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + + { + Id = 1 + Forms = [ "thing2" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + { + Id = 2 + Forms = [ "and-another" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.BoolLike + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + ] + Tree = + (ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + [ + ArgParserRuntime_BasicNoPositionals.ErasedTree.Sum ( + (0, + [ + ("supplied", + ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + [ + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 0 + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 1 + ] + )) + ("absent", ArgParserRuntime_BasicNoPositionals.ErasedTree.Product (List.empty)) + ]) + ) + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 2 + ] + )) + Positionals = List.empty + } + + let parser_storeOccurrence + (occurrence : ArgParserRuntime_BasicNoPositionals.ErasedOccurrence) + : string option + = + match occurrence.LeafId with + | 0 -> + match arg_1 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_1 <- Some (value |> (fun x -> System.Int32.Parse x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | 1 -> + match arg_2 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_2 <- Some (value |> (fun x -> x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | 2 -> + match arg_3 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + let parsedBool = System.Boolean.Parse value + let parsedBool = if occurrence.Negated then not parsedBool else parsedBool + arg_3 <- Some (parsedBool) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + arg_3 <- Some ((if occurrence.Negated then false else true)) + None + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown argument id" + + let parser_storePositional (positionalId : int) (value : string) (afterSeparator : bool) : string option = + failwith "WoofWare.Myriad internal error in generated parser: no positional sink exists" + + let parser_renderStored (leafId : int) : string = + match leafId with + | 0 -> + match arg_1 with + | Some x -> x.ToString () + | None -> "" + | 1 -> + match arg_2 with + | Some x -> x.ToString () + | None -> "" + | 2 -> + match arg_3 with + | Some x -> x.ToString () + | None -> "" + | _ -> "" + + let parser_applyDefault (leafId : int) : string option = + match leafId with + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown defaulted argument id" + + let parser_callbacks : ArgParserRuntime_BasicNoPositionals.TypedCallbacks = + { + StoreOccurrence = parser_storeOccurrence + StorePositional = parser_storePositional + HelpText = helpText + RenderStored = parser_renderStored + ApplyDefault = parser_applyDefault + } + + match + ArgParserRuntime_BasicNoPositionals.runParse + (ArgParserRuntime_BasicNoPositionals.WellFormedSchema.checkOrFail parser_schema) + parser_callbacks + args + with + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Success parser_selection -> + { + AndAnother = + (match arg_3 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + Child = + match Map.tryFind 0 parser_selection.Choices with + | Some 0 -> + Choice1Of2 ( + { + Thing1 = + (match arg_1 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + Thing2 = + (match arg_2 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + ) + | Some 1 -> Choice2Of2 (ParentRecordDefaultedChild.DefaultChild ()) + | _ -> + failwith + "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse" + } + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.HelpRequested -> + helpText () |> failwithf "Help text requested.\n%s" + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Fatal message -> failwith message + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Errors errors -> + errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + static member parse (args : string list) : ParentRecordDefaultedChild = + ParentRecordDefaultedChild.parse' (System.Environment.GetEnvironmentVariable >> Option.ofObj) args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type ParentRecordNestedOptional +[] +module ParentRecordNestedOptionalArgParse = + /// Extension methods for argument parsing + type ParentRecordNestedOptional with + + static member parse' + (getEnvironmentVariable : string -> string option) + (args : string list) + : ParentRecordNestedOptional + = + let helpText () = + [ + (sprintf "%s:" "Child (optional)") + (sprintf " %s %s%s%s" (sprintf "--%s" "db-thing1") "int32" "" "") + (sprintf "%s:" " Grandchild (optional)") + (sprintf " %s %s%s%s" (sprintf "--%s" "db-deep") "int32" "" "") + ] + |> String.concat "\n" + + let parser_LeftoverArgs : string ResizeArray = ResizeArray () + let mutable arg_1 : int option = None + let mutable arg_3 : int option = None + + let parser_schema : ArgParserRuntime_BasicNoPositionals.ErasedSchema = + { + Leaves = + [ + { + Id = 0 + Forms = [ "db-thing1" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + { + Id = 1 + Forms = [ "db-deep" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + ] + Tree = + (ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + [ + ArgParserRuntime_BasicNoPositionals.ErasedTree.Sum ( + (0, + [ + ("supplied", + ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + [ + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 0 + ArgParserRuntime_BasicNoPositionals.ErasedTree.Sum ( + (2, + [ + ("supplied", + ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + [ + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf + 1 + ] + )) + ("absent", + ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + List.empty + )) + ]) + ) + ] + )) + ("absent", ArgParserRuntime_BasicNoPositionals.ErasedTree.Product (List.empty)) + ]) + ) + ] + )) + Positionals = List.empty + } + + let parser_storeOccurrence + (occurrence : ArgParserRuntime_BasicNoPositionals.ErasedOccurrence) + : string option + = + match occurrence.LeafId with + | 0 -> + match arg_1 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_1 <- Some (value |> (fun x -> System.Int32.Parse x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | 1 -> + match arg_3 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_3 <- Some (value |> (fun x -> System.Int32.Parse x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown argument id" + + let parser_storePositional (positionalId : int) (value : string) (afterSeparator : bool) : string option = + failwith "WoofWare.Myriad internal error in generated parser: no positional sink exists" + + let parser_renderStored (leafId : int) : string = + match leafId with + | 0 -> + match arg_1 with + | Some x -> x.ToString () + | None -> "" + | 1 -> + match arg_3 with + | Some x -> x.ToString () + | None -> "" + | _ -> "" + + let parser_applyDefault (leafId : int) : string option = + match leafId with + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown defaulted argument id" + + let parser_callbacks : ArgParserRuntime_BasicNoPositionals.TypedCallbacks = + { + StoreOccurrence = parser_storeOccurrence + StorePositional = parser_storePositional + HelpText = helpText + RenderStored = parser_renderStored + ApplyDefault = parser_applyDefault + } + + match + ArgParserRuntime_BasicNoPositionals.runParse + (ArgParserRuntime_BasicNoPositionals.WellFormedSchema.checkOrFail parser_schema) + parser_callbacks + args + with + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Success parser_selection -> + { + Child = + match Map.tryFind 0 parser_selection.Choices with + | Some 0 -> + Some ( + { + Grandchild = + match Map.tryFind 2 parser_selection.Choices with + | Some 0 -> + Some ( + { + Deep = + (match arg_3 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + ) + | Some 1 -> None + | _ -> + failwith + "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse" + Thing1 = + (match arg_1 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + ) + | Some 1 -> None + | _ -> + failwith + "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse" + } + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.HelpRequested -> + helpText () |> failwithf "Help text requested.\n%s" + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Fatal message -> failwith message + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Errors errors -> + errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + static member parse (args : string list) : ParentRecordNestedOptional = + ParentRecordNestedOptional.parse' (System.Environment.GetEnvironmentVariable >> Option.ofObj) args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + /// Methods to parse arguments for the type ChoicePositionals [] module ChoicePositionalsArgParse = @@ -8035,3 +8836,330 @@ module AwkwardFieldNameArgParse = static member parse (args : string list) : AwkwardFieldName = AwkwardFieldName.parse' (System.Environment.GetEnvironmentVariable >> Option.ofObj) args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type AwkwardDefaultName +[] +module AwkwardDefaultNameArgParse = + /// Extension methods for argument parsing + type AwkwardDefaultName with + + static member parse' + (getEnvironmentVariable : string -> string option) + (args : string list) + : AwkwardDefaultName + = + let helpText () = + [ + (sprintf + "%s %s%s%s" + (sprintf "--%s" "space in name") + "int32" + (AwkwardDefaultName.``Defaultspace in name``().ToString () + |> sprintf " (default value: %s)") + "") + + (sprintf "%s:" "group name (optional; a default is used if omitted)") + (sprintf " %s %s%s%s" (sprintf "--%s" "grp-thing1") "int32" "" "") + (sprintf " %s %s%s%s" (sprintf "--%s" "grp-thing2") "string" "" "") + (sprintf "%s:" "optional group (optional)") + (sprintf " %s %s%s%s" (sprintf "--%s" "opt-thing1") "int32" "" "") + (sprintf " %s %s%s%s" (sprintf "--%s" "opt-thing2") "string" "" "") + ] + |> String.concat "\n" + + let parser_LeftoverArgs : string ResizeArray = ResizeArray () + let mutable arg_0 : Choice option = None + let mutable arg_2 : int option = None + let mutable arg_3 : string option = None + let mutable arg_5 : int option = None + let mutable arg_6 : string option = None + + let parser_schema : ArgParserRuntime_BasicNoPositionals.ErasedSchema = + { + Leaves = + [ + { + Id = 0 + Forms = [ "space in name" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.HasDefault + TypeDescription = "" + Help = None + } + + { + Id = 1 + Forms = [ "grp-thing1" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + + { + Id = 2 + Forms = [ "grp-thing2" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + + { + Id = 3 + Forms = [ "opt-thing1" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + { + Id = 4 + Forms = [ "opt-thing2" ] + AcceptsNegation = false + Arity = ArgParserRuntime_BasicNoPositionals.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_BasicNoPositionals.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + ] + Tree = + (ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + [ + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 0 + + ArgParserRuntime_BasicNoPositionals.ErasedTree.Sum ( + (1, + [ + ("supplied", + ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + [ + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 1 + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 2 + ] + )) + ("absent", ArgParserRuntime_BasicNoPositionals.ErasedTree.Product (List.empty)) + ]) + ) + ArgParserRuntime_BasicNoPositionals.ErasedTree.Sum ( + (4, + [ + ("supplied", + ArgParserRuntime_BasicNoPositionals.ErasedTree.Product ( + [ + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 3 + ArgParserRuntime_BasicNoPositionals.ErasedTree.Leaf 4 + ] + )) + ("absent", ArgParserRuntime_BasicNoPositionals.ErasedTree.Product (List.empty)) + ]) + ) + ] + )) + Positionals = List.empty + } + + let parser_storeOccurrence + (occurrence : ArgParserRuntime_BasicNoPositionals.ErasedOccurrence) + : string option + = + match occurrence.LeafId with + | 0 -> + match arg_0 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_0 <- Some (Choice1Of2 (value |> (fun x -> System.Int32.Parse x))) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | 1 -> + match arg_2 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_2 <- Some (value |> (fun x -> System.Int32.Parse x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | 2 -> + match arg_3 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_3 <- Some (value |> (fun x -> x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | 3 -> + match arg_5 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_5 <- Some (value |> (fun x -> System.Int32.Parse x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | 4 -> + match arg_6 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_6 <- Some (value |> (fun x -> x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown argument id" + + let parser_storePositional (positionalId : int) (value : string) (afterSeparator : bool) : string option = + failwith "WoofWare.Myriad internal error in generated parser: no positional sink exists" + + let parser_renderStored (leafId : int) : string = + match leafId with + | 0 -> + match arg_0 with + | Some (Choice1Of2 x) -> x.ToString () + | Some (Choice2Of2 x) -> x.ToString () + | None -> "" + | 1 -> + match arg_2 with + | Some x -> x.ToString () + | None -> "" + | 2 -> + match arg_3 with + | Some x -> x.ToString () + | None -> "" + | 3 -> + match arg_5 with + | Some x -> x.ToString () + | None -> "" + | 4 -> + match arg_6 with + | Some x -> x.ToString () + | None -> "" + | _ -> "" + + let parser_applyDefault (leafId : int) : string option = + match leafId with + | 0 -> + arg_0 <- Some (Choice2Of2 (AwkwardDefaultName.``Defaultspace in name`` ())) + None + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown defaulted argument id" + + let parser_callbacks : ArgParserRuntime_BasicNoPositionals.TypedCallbacks = + { + StoreOccurrence = parser_storeOccurrence + StorePositional = parser_storePositional + HelpText = helpText + RenderStored = parser_renderStored + ApplyDefault = parser_applyDefault + } + + match + ArgParserRuntime_BasicNoPositionals.runParse + (ArgParserRuntime_BasicNoPositionals.WellFormedSchema.checkOrFail parser_schema) + parser_callbacks + args + with + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Success parser_selection -> + { + ``group name`` = + match Map.tryFind 1 parser_selection.Choices with + | Some 0 -> + Choice1Of2 ( + { + Thing1 = + (match arg_2 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + Thing2 = + (match arg_3 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + ) + | Some 1 -> Choice2Of2 (AwkwardDefaultName.``Defaultgroup name`` ()) + | _ -> + failwith + "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse" + ``optional group`` = + match Map.tryFind 4 parser_selection.Choices with + | Some 0 -> + Some ( + { + Thing1 = + (match arg_5 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + Thing2 = + (match arg_6 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + ) + | Some 1 -> None + | _ -> + failwith + "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse" + ``space in name`` = + (match arg_0 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.HelpRequested -> + helpText () |> failwithf "Help text requested.\n%s" + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Fatal message -> failwith message + | ArgParserRuntime_BasicNoPositionals.ParseOutcome.Errors errors -> + errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + static member parse (args : string list) : AwkwardDefaultName = + AwkwardDefaultName.parse' (System.Environment.GetEnvironmentVariable >> Option.ofObj) args diff --git a/ConsumePlugin/GeneratedDuArgs.fs b/ConsumePlugin/GeneratedDuArgs.fs index 1813009..5b7d23d 100644 --- a/ConsumePlugin/GeneratedDuArgs.fs +++ b/ConsumePlugin/GeneratedDuArgs.fs @@ -1827,6 +1827,460 @@ namespace ConsumePlugin open WoofWare.Myriad.Plugins +/// Methods to parse arguments for the type WithOptionalTransformArgs +[] +module WithOptionalTransformArgs = + let parse' (getEnvironmentVariable : string -> string option) (args : string list) : WithOptionalTransformArgs = + let helpText () = + [ + (sprintf "%s %s%s%s" (sprintf "--%s" "verbose") "bool" "" "") + (sprintf "%s:" "Transform (optional)") + " exactly one of the following sets of arguments:" + (sprintf "%s:" " Compress") + (sprintf " %s %s%s%s" (sprintf "--%s" "level") "int32" "" "") + (sprintf "%s:" " Encrypt") + (sprintf " %s %s%s%s" (sprintf "--%s" "recipient") "string" "" "") + ] + |> String.concat "\n" + + let parser_LeftoverArgs : string ResizeArray = ResizeArray () + let mutable arg_0 : bool option = None + let mutable arg_3 : int option = None + let mutable arg_4 : string option = None + + let parser_schema : ArgParserRuntime_DuArgs.ErasedSchema = + { + Leaves = + [ + { + Id = 0 + Forms = [ "verbose" ] + AcceptsNegation = false + Arity = ArgParserRuntime_DuArgs.ErasedArity.BoolLike + Repeatable = false + Requirement = ArgParserRuntime_DuArgs.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + + { + Id = 1 + Forms = [ "level" ] + AcceptsNegation = false + Arity = ArgParserRuntime_DuArgs.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_DuArgs.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + { + Id = 2 + Forms = [ "recipient" ] + AcceptsNegation = false + Arity = ArgParserRuntime_DuArgs.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_DuArgs.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + ] + Tree = + (ArgParserRuntime_DuArgs.ErasedTree.Product ( + [ + ArgParserRuntime_DuArgs.ErasedTree.Leaf 0 + ArgParserRuntime_DuArgs.ErasedTree.Sum ( + (1, + [ + ("supplied", + ArgParserRuntime_DuArgs.ErasedTree.Sum ( + (2, + [ + ("Compress", + ArgParserRuntime_DuArgs.ErasedTree.Product ( + [ ArgParserRuntime_DuArgs.ErasedTree.Leaf 1 ] + )) + ("Encrypt", + ArgParserRuntime_DuArgs.ErasedTree.Product ( + [ ArgParserRuntime_DuArgs.ErasedTree.Leaf 2 ] + )) + ]) + )) + ("absent", ArgParserRuntime_DuArgs.ErasedTree.Product (List.empty)) + ]) + ) + ] + )) + Positionals = List.empty + } + + let parser_storeOccurrence (occurrence : ArgParserRuntime_DuArgs.ErasedOccurrence) : string option = + match occurrence.LeafId with + | 0 -> + match arg_0 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + let parsedBool = System.Boolean.Parse value + let parsedBool = if occurrence.Negated then not parsedBool else parsedBool + arg_0 <- Some (parsedBool) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + arg_0 <- Some ((if occurrence.Negated then false else true)) + None + | 1 -> + match arg_3 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_3 <- Some (value |> (fun x -> System.Int32.Parse x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | 2 -> + match arg_4 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_4 <- Some (value |> (fun x -> x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown argument id" + + let parser_storePositional (positionalId : int) (value : string) (afterSeparator : bool) : string option = + failwith "WoofWare.Myriad internal error in generated parser: no positional sink exists" + + let parser_renderStored (leafId : int) : string = + match leafId with + | 0 -> + match arg_0 with + | Some x -> x.ToString () + | None -> "" + | 1 -> + match arg_3 with + | Some x -> x.ToString () + | None -> "" + | 2 -> + match arg_4 with + | Some x -> x.ToString () + | None -> "" + | _ -> "" + + let parser_applyDefault (leafId : int) : string option = + match leafId with + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown defaulted argument id" + + let parser_callbacks : ArgParserRuntime_DuArgs.TypedCallbacks = + { + StoreOccurrence = parser_storeOccurrence + StorePositional = parser_storePositional + HelpText = helpText + RenderStored = parser_renderStored + ApplyDefault = parser_applyDefault + } + + match + ArgParserRuntime_DuArgs.runParse + (ArgParserRuntime_DuArgs.WellFormedSchema.checkOrFail parser_schema) + parser_callbacks + args + with + | ArgParserRuntime_DuArgs.ParseOutcome.Success parser_selection -> + { + Transform = + match Map.tryFind 1 parser_selection.Choices with + | Some 0 -> + Some ( + match Map.tryFind 2 parser_selection.Choices with + | Some 0 -> + Transform.Compress ( + { + Level = + (match arg_3 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + ) + | Some 1 -> + Transform.Encrypt ( + { + Recipient = + (match arg_4 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + ) + | _ -> + failwith + "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse" + ) + | Some 1 -> None + | _ -> + failwith + "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse" + Verbose = + (match arg_0 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + | ArgParserRuntime_DuArgs.ParseOutcome.HelpRequested -> helpText () |> failwithf "Help text requested.\n%s" + | ArgParserRuntime_DuArgs.ParseOutcome.Fatal message -> failwith message + | ArgParserRuntime_DuArgs.ParseOutcome.Errors errors -> + errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + let parse (args : string list) : WithOptionalTransformArgs = + parse' (System.Environment.GetEnvironmentVariable >> Option.ofObj) args +namespace ConsumePlugin + +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type WithDefaultedTransformArgs +[] +module WithDefaultedTransformArgs = + let parse' (getEnvironmentVariable : string -> string option) (args : string list) : WithDefaultedTransformArgs = + let helpText () = + [ + (sprintf "%s %s%s%s" (sprintf "--%s" "verbose") "bool" "" "") + (sprintf "%s:" "Transform (optional; a default is used if omitted)") + " exactly one of the following sets of arguments:" + (sprintf "%s:" " Compress") + (sprintf " %s %s%s%s" (sprintf "--%s" "level") "int32" "" "") + (sprintf "%s:" " Encrypt") + (sprintf " %s %s%s%s" (sprintf "--%s" "recipient") "string" "" "") + ] + |> String.concat "\n" + + let parser_LeftoverArgs : string ResizeArray = ResizeArray () + let mutable arg_0 : bool option = None + let mutable arg_3 : int option = None + let mutable arg_4 : string option = None + + let parser_schema : ArgParserRuntime_DuArgs.ErasedSchema = + { + Leaves = + [ + { + Id = 0 + Forms = [ "verbose" ] + AcceptsNegation = false + Arity = ArgParserRuntime_DuArgs.ErasedArity.BoolLike + Repeatable = false + Requirement = ArgParserRuntime_DuArgs.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + + { + Id = 1 + Forms = [ "level" ] + AcceptsNegation = false + Arity = ArgParserRuntime_DuArgs.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_DuArgs.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + { + Id = 2 + Forms = [ "recipient" ] + AcceptsNegation = false + Arity = ArgParserRuntime_DuArgs.ErasedArity.One + Repeatable = false + Requirement = ArgParserRuntime_DuArgs.ErasedRequirement.Required + TypeDescription = "" + Help = None + } + ] + Tree = + (ArgParserRuntime_DuArgs.ErasedTree.Product ( + [ + ArgParserRuntime_DuArgs.ErasedTree.Leaf 0 + ArgParserRuntime_DuArgs.ErasedTree.Sum ( + (1, + [ + ("supplied", + ArgParserRuntime_DuArgs.ErasedTree.Sum ( + (2, + [ + ("Compress", + ArgParserRuntime_DuArgs.ErasedTree.Product ( + [ ArgParserRuntime_DuArgs.ErasedTree.Leaf 1 ] + )) + ("Encrypt", + ArgParserRuntime_DuArgs.ErasedTree.Product ( + [ ArgParserRuntime_DuArgs.ErasedTree.Leaf 2 ] + )) + ]) + )) + ("absent", ArgParserRuntime_DuArgs.ErasedTree.Product (List.empty)) + ]) + ) + ] + )) + Positionals = List.empty + } + + let parser_storeOccurrence (occurrence : ArgParserRuntime_DuArgs.ErasedOccurrence) : string option = + match occurrence.LeafId with + | 0 -> + match arg_0 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + let parsedBool = System.Boolean.Parse value + let parsedBool = if occurrence.Negated then not parsedBool else parsedBool + arg_0 <- Some (parsedBool) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + arg_0 <- Some ((if occurrence.Negated then false else true)) + None + | 1 -> + match arg_3 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_3 <- Some (value |> (fun x -> System.Int32.Parse x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | 2 -> + match arg_4 with + | Some _ -> None + | None -> + match occurrence.Value with + | Some value -> + try + arg_4 <- Some (value |> (fun x -> x)) + None + with _ as exc -> + (sprintf "%s (at arg %s)" exc.Message occurrence.Source) |> Some + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: arity-one occurrence with no value" + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown argument id" + + let parser_storePositional (positionalId : int) (value : string) (afterSeparator : bool) : string option = + failwith "WoofWare.Myriad internal error in generated parser: no positional sink exists" + + let parser_renderStored (leafId : int) : string = + match leafId with + | 0 -> + match arg_0 with + | Some x -> x.ToString () + | None -> "" + | 1 -> + match arg_3 with + | Some x -> x.ToString () + | None -> "" + | 2 -> + match arg_4 with + | Some x -> x.ToString () + | None -> "" + | _ -> "" + + let parser_applyDefault (leafId : int) : string option = + match leafId with + | _ -> failwith "WoofWare.Myriad internal error in generated parser: unknown defaulted argument id" + + let parser_callbacks : ArgParserRuntime_DuArgs.TypedCallbacks = + { + StoreOccurrence = parser_storeOccurrence + StorePositional = parser_storePositional + HelpText = helpText + RenderStored = parser_renderStored + ApplyDefault = parser_applyDefault + } + + match + ArgParserRuntime_DuArgs.runParse + (ArgParserRuntime_DuArgs.WellFormedSchema.checkOrFail parser_schema) + parser_callbacks + args + with + | ArgParserRuntime_DuArgs.ParseOutcome.Success parser_selection -> + { + Transform = + match Map.tryFind 1 parser_selection.Choices with + | Some 0 -> + Choice1Of2 ( + match Map.tryFind 2 parser_selection.Choices with + | Some 0 -> + Transform.Compress ( + { + Level = + (match arg_3 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + ) + | Some 1 -> + Transform.Encrypt ( + { + Recipient = + (match arg_4 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + ) + | _ -> + failwith + "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse" + ) + | Some 1 -> Choice2Of2 (WithDefaultedTransformArgs.DefaultTransform ()) + | _ -> + failwith + "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse" + Verbose = + (match arg_0 with + | Some x -> x + | None -> + failwith + "WoofWare.Myriad internal error in generated parser: required argument missing after successful parse") + } + | ArgParserRuntime_DuArgs.ParseOutcome.HelpRequested -> helpText () |> failwithf "Help text requested.\n%s" + | ArgParserRuntime_DuArgs.ParseOutcome.Fatal message -> failwith message + | ArgParserRuntime_DuArgs.ParseOutcome.Errors errors -> + errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + let parse (args : string list) : WithDefaultedTransformArgs = + parse' (System.Environment.GetEnvironmentVariable >> Option.ofObj) args +namespace ConsumePlugin + +open WoofWare.Myriad.Plugins + /// Methods to parse arguments for the type DuWithDefaultArgs [] module DuWithDefaultArgs = diff --git a/README.md b/README.md index b1e9900..c86a8f1 100644 --- a/README.md +++ b/README.md @@ -282,6 +282,54 @@ field which negates with `[]` negates outside the pref `--no-src-host`. The prefix is used exactly as you write it: omit the leading `--` and the trailing `-`, and note that it is not case-normalised. +### Optional and defaulted argument groups + +A field whose type is another argument record, or a union of alternative argument sets, may be +wrapped in `option` or in `Choice<'a, 'a>`. The whole group of arguments then need not be supplied. + +```fsharp +type Notify = + { + Email : string + Subject : string option + } + +[] +type Args = + { + Verbose : bool + Notify : Notify option + } +``` + +``` +./my-app --verbose=true // Notify = None +./my-app --verbose=true --email=a@example.com // Notify = Some { Email = ...; Subject = None } +``` + +The group is present exactly when at least one argument beneath it was supplied — the same rule +which chooses a union's case. Once it is present, its own required arguments are enforced as usual, +so `--subject=hi` alone is an error demanding `--email`, rather than a quietly absent group. + +`Choice` behaves the same way, but says that omitting the group means a particular +value rather than no value: you get `Choice1Of2` of what the user supplied, or `Choice2Of2` of your +default. The default must come from `[]` — an attribute argument is a +compile-time constant and there is no constant which is a record, and an environment variable is one +string with no spelling that turns it into a group. It is also all-or-nothing: supplying part of the +group demands the rest of it rather than filling the gaps from the default. + +These compose as you would expect: an optional group may contain another, and `[]` +namespaces the whole subtree through the wrapper. + +**One restriction.** The group must not itself be satisfiable by supplying nothing — every field +optional or defaulted, or a union with a case which an empty command line already selects. Nothing +the user could type would distinguish "the group was supplied, and everything in it took its +default" from "the group was never mentioned", so generation fails rather than silently preferring +one reading. Make one of the group's arguments mandatory, or drop the wrapper. + +`SomeArgs list` — a *repeated* group — is not supported. A flat command line gives no way to say +where one repetition ends and the next begins. + ### Positional arguments You can collect leftover args as positional args, with `[]`; this respects a trailing `--` so that you can specify positional args which look like flags. diff --git a/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParserOptionalGroup.fs b/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParserOptionalGroup.fs new file mode 100644 index 0000000..8b26586 --- /dev/null +++ b/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParserOptionalGroup.fs @@ -0,0 +1,403 @@ +namespace WoofWare.Myriad.Plugins.Test + +open System +open NUnit.Framework +open FsUnitTyped +open ConsumePlugin + +/// A field whose type is `SomeArgs option` contributes a whole group of arguments which need not +/// be supplied. The group is present exactly when at least one argument beneath it was supplied, +/// which is the same rule by which a union's case is selected; when it is present, its own +/// required arguments are enforced as usual. +[] +module TestArgParserOptionalGroup = + + let noEnv (_ : string) : string option = None + + [] + let ``An unmentioned group is absent`` () = + ParentRecordOptionalChild.parse' noEnv [ "--and-another=true" ] + |> shouldEqual + { + Child = None + AndAnother = true + } + + [] + let ``Supplying the group's arguments makes it present`` () = + ParentRecordOptionalChild.parse' noEnv [ "--and-another=false" ; "--thing1=3" ; "--thing2=hi" ] + |> shouldEqual + { + Child = + Some + { + Thing1 = 3 + Thing2 = "hi" + } + AndAnother = false + } + + /// The point of the whole design: touching the group at all commits to it, so the arguments + /// it did not receive are reported in the ordinary vocabulary rather than being quietly + /// treated as an absent group. + [] + let ``Supplying part of the group demands the rest of it`` () = + let exc = + Assert.Throws (fun () -> + ParentRecordOptionalChild.parse' noEnv [ "--and-another=true" ; "--thing1=3" ] + |> ignore + ) + + exc.Message + |> shouldEqual + """Errors during parse! +Required argument '--thing2' received no value""" + + /// Absence of the group does not excuse the arguments outside it. + [] + let ``An absent group does not make its siblings optional`` () = + let exc = + Assert.Throws (fun () -> + ParentRecordOptionalChild.parse' noEnv [] |> ignore + ) + + exc.Message + |> shouldEqual + """Errors during parse! +Required argument '--and-another' received no value""" + + [] + let ``An optional group reads as a group in help text, not as an alternation`` () = + let exc = + Assert.Throws (fun () -> + ParentRecordOptionalChild.parse' noEnv [ "--help" ] + |> ignore + ) + + exc.Message + |> shouldEqual + """Help text requested. +Child (optional): + --thing1 int32 + --thing2 string +--and-another bool""" + + // A group containing a positional sink. The sink accepts zero tokens, but `Thing1` is + // required, so the group is still distinguishable from its own absence. + + [] + let ``A group containing a positional sink can be absent`` () = + ParentRecordOptionalChildPos.parse' noEnv [] + |> shouldEqual + { + Child = None + } + + [] + let ``A group containing a positional sink can be present`` () = + ParentRecordOptionalChildPos.parse' noEnv [ "--thing1=3" ; "http://example.com/" ] + |> shouldEqual + { + Child = + Some + { + Thing1 = 3 + Thing2 = [ Uri "http://example.com/" ] + } + } + + /// A bare positional token is enough to touch the group, exactly as a named argument is: the + /// sink is reachable only through the group, so consuming a token means the group is present. + [] + let ``A positional token alone selects the group, and its required arguments are then demanded`` () = + let exc = + Assert.Throws (fun () -> + ParentRecordOptionalChildPos.parse' noEnv [ "http://example.com/" ] + |> ignore + ) + + exc.Message + |> shouldEqual + """Errors during parse! +Required argument '--thing1' received no value""" + + [] + let ``A group's help text annotates the header the field's [] provides`` () = + let exc = + Assert.Throws (fun () -> + ParentRecordOptionalChildPos.parse' noEnv [ "--help" ] + |> ignore + ) + + exc.Message + |> shouldEqual + """Help text requested. +Child (optional): Settings for the child thing + --thing1 int32 + --thing2 URI (positional args) (can be repeated)""" + + // A union of alternative argument sets is a group like any other, so it too may be optional: + // the choice among its cases need not be made at all. + + [] + let ``An unmentioned union group is absent`` () = + WithOptionalTransformArgs.parse' noEnv [ "--verbose=true" ] + |> shouldEqual + { + Verbose = true + Transform = None + } + + [] + let ``Selecting a case of an optional union group makes it present`` () = + WithOptionalTransformArgs.parse' noEnv [ "--verbose=false" ; "--level=9" ] + |> shouldEqual + { + Verbose = false + Transform = + Some ( + Transform.Compress + { + Level = 9 + } + ) + } + + [] + let ``The cases of an optional union group remain exclusive`` () = + let exc = + Assert.Throws (fun () -> + WithOptionalTransformArgs.parse' noEnv [ "--verbose=true" ; "--level=9" ; "--recipient=me" ] + |> ignore + ) + + exc.Message + |> shouldEqual + """Errors during parse! +Arguments select more than one alternative: Compress (via --level=9), Encrypt (via --recipient=me)""" + + /// The optional group's own two alternatives are ours rather than the author's, so the help + /// text must not present them: only the union the author actually wrote is an alternation. + [] + let ``An optional union group nests its own alternation under the group header`` () = + let exc = + Assert.Throws (fun () -> + WithOptionalTransformArgs.parse' noEnv [ "--help" ] + |> ignore + ) + + exc.Message + |> shouldEqual + """Help text requested. +--verbose bool +Transform (optional): + exactly one of the following sets of arguments: + Compress: + --level int32 + Encrypt: + --recipient string""" + + // A defaulted group. Omitting it means a particular value rather than no value, and the + // Choice reports which happened -- exactly as it does for a defaulted leaf. + + [] + let ``An unmentioned defaulted group takes its default`` () = + ParentRecordDefaultedChild.parse' noEnv [ "--and-another=true" ] + |> shouldEqual + { + Child = + Choice2Of2 + { + Thing1 = 42 + Thing2 = "from the default" + } + AndAnother = true + } + + [] + let ``Supplying a defaulted group's arguments overrides the default wholesale`` () = + ParentRecordDefaultedChild.parse' noEnv [ "--and-another=true" ; "--thing1=3" ; "--thing2=hi" ] + |> shouldEqual + { + Child = + Choice1Of2 + { + Thing1 = 3 + Thing2 = "hi" + } + AndAnother = true + } + + /// The default is all-or-nothing: it is not merged field-by-field with what was supplied, so + /// touching the group still demands the whole of it. + [] + let ``Supplying part of a defaulted group demands the rest rather than defaulting it`` () = + let exc = + Assert.Throws (fun () -> + ParentRecordDefaultedChild.parse' noEnv [ "--and-another=true" ; "--thing1=3" ] + |> ignore + ) + + exc.Message + |> shouldEqual + """Errors during parse! +Required argument '--thing2' received no value""" + + /// There is no single token which supplies a whole group, so there is nothing to render the + /// default as; the help says only that one exists. + [] + let ``A defaulted group says a default exists without spelling it`` () = + let exc = + Assert.Throws (fun () -> + ParentRecordDefaultedChild.parse' noEnv [ "--help" ] + |> ignore + ) + + exc.Message + |> shouldEqual + """Help text requested. +Child (optional; a default is used if omitted): + --thing1 int32 + --thing2 string +--and-another bool""" + + [] + let ``An unmentioned defaulted union group takes its default`` () = + WithDefaultedTransformArgs.parse' noEnv [ "--verbose=false" ] + |> shouldEqual + { + Verbose = false + Transform = + Choice2Of2 ( + Transform.Compress + { + Level = 6 + } + ) + } + + [] + let ``Selecting a case of a defaulted union group overrides the default`` () = + WithDefaultedTransformArgs.parse' noEnv [ "--verbose=false" ; "--recipient=me" ] + |> shouldEqual + { + Verbose = false + Transform = + Choice1Of2 ( + Transform.Encrypt + { + Recipient = "me" + } + ) + } + + // Optional groups compose: one may contain another, and [] namespaces the + // whole subtree through the container exactly as it does for a bare structural field. + + [] + let ``A nested optional group can be absent while its parent is present`` () = + ParentRecordNestedOptional.parse' noEnv [ "--db-thing1=1" ] + |> shouldEqual + { + Child = + Some + { + Thing1 = 1 + Grandchild = None + } + } + + [] + let ``A nested optional group can be present`` () = + ParentRecordNestedOptional.parse' noEnv [ "--db-thing1=1" ; "--db-deep=2" ] + |> shouldEqual + { + Child = + Some + { + Thing1 = 1 + Grandchild = + Some + { + Deep = 2 + } + } + } + + [] + let ``Both nested groups can be absent at once`` () = + ParentRecordNestedOptional.parse' noEnv [] + |> shouldEqual + { + Child = None + } + + /// Touching only the inner group still commits to the outer one, whose own required argument + /// is then demanded: the inner group is reachable only through the outer. + [] + let ``Touching only the inner group commits to the outer one`` () = + let exc = + Assert.Throws (fun () -> + ParentRecordNestedOptional.parse' noEnv [ "--db-deep=2" ] + |> ignore + ) + + exc.Message + |> shouldEqual + """Errors during parse! +Required argument '--db-thing1' received no value""" + + [] + let ``A prefix namespaces the whole subtree through the container`` () = + let exc = + Assert.Throws (fun () -> + ParentRecordNestedOptional.parse' noEnv [ "--help" ] + |> ignore + ) + + exc.Message + |> shouldEqual + """Help text requested. +Child (optional): + --db-thing1 int32 + Grandchild (optional): + --db-deep int32""" + + /// A defaulted field's default comes from `Default` + the field name, so an awkward field name + /// makes an awkward member name, which needs backticks where it is called. Three sites emit + /// that call -- a leaf's applied default, a group's instantiation, and the help text -- and the + /// generated file does not parse if any of them gets it wrong. + [] + let ``An awkward field name survives into the default-function call`` () = + AwkwardDefaultName.parse' noEnv [] + |> shouldEqual + { + ``space in name`` = Choice2Of2 5 + ``group name`` = + Choice2Of2 + { + Thing1 = 1 + Thing2 = "defaulted group" + } + ``optional group`` = None + } + + [] + let ``An awkwardly named group can still be supplied`` () = + AwkwardDefaultName.parse' noEnv [ "--grp-thing1=8" ; "--grp-thing2=hi" ; "--opt-thing1=9" ; "--opt-thing2=yo" ] + |> shouldEqual + { + ``space in name`` = Choice2Of2 5 + ``group name`` = + Choice1Of2 + { + Thing1 = 8 + Thing2 = "hi" + } + ``optional group`` = + Some + { + Thing1 = 9 + Thing2 = "yo" + } + } diff --git a/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParserPositionalReference.fs b/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParserPositionalReference.fs index 0518b05..9d2a6e2 100644 --- a/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParserPositionalReference.fs +++ b/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParserPositionalReference.fs @@ -948,3 +948,141 @@ module TestArgParserPositionalReference = exc.Message |> shouldEqual "linearity violated: this tree admits an interpretation with 2 positional leaves" + + // ---------------------------------------------------------------------------------------- + // Optional argument groups. + // + // A field of type `ChildArgs option` erases to a two-case Sum whose second case is the + // *empty* product: "the group's arguments, or nothing at all". That shape is unreachable by + // `genTree` -- `chooseCuts` draws distinct cuts strictly inside [1, n-1], so every case it + // builds receives at least one named leaf, and the one branch which could yield `Product []` + // collapses it away -- so the model has never seen it, even though `RefTree` can express it. + // These close that gap. + + /// All named-leaf ids under a tree. + let rec private namedIds (tree : RefTree) : Set = + match tree with + | RefTree.Named leaf -> Set.singleton leaf.Id + | RefTree.Positional _ -> Set.empty + | RefTree.Product children -> children |> List.map namedIds |> Set.unionMany + | RefTree.Sum (_, cases) -> cases |> List.map (snd >> namedIds) |> Set.unionMany + + /// The erasure of `Child : ChildArgs option`, with the outer sum numbered 0. + let private container (payload : RefTree) : RefTree = + RefTree.Sum (0, [ "supplied", payload ; "absent", RefTree.Product [] ]) + |> renumberSumsOnly + + /// Payloads which the generator's gate would accept: not satisfiable with no arguments, and + /// internally unambiguous. + let private genContainerPayload : Gen = + gen { + let! sumBias = Gen.elements [ 0 ; 40 ; 80 ] + let! namedCount = Gen.choose (1, 6) + let! budget = Gen.frequency [ (1, Gen.constant true) ; (1, Gen.constant false) ] + let! tree = genTreeOver sumBias budget (List.init namedCount id) + return renumber tree + } + |> Gen.filter (fun tree -> not (emptySatisfiable tree) && sumsAreUnambiguous tree) + + [] + let ``A gated optional group is never ambiguous, and absence is available on any input`` () = + // The claim the whole design rests on. The "absent" case holds no leaf and no sink, so + // nothing can ever witness it; the gate makes the payload never satisfiable by silence. + // Together those mean exactly one of the two is selectable, whatever arrives -- so none + // of the runtime's three selection errors can arise from a container, and the case names + // it invents are unreachable in any message. + let mutable absentChosen = 0 + let mutable suppliedChosen = 0 + + let cases = + gen { + let! payload = genContainerPayload + let tree = container payload + let! dropPct = Gen.elements [ 0 ; 0 ; 20 ] + let! optionalPct = Gen.elements [ 0 ; 50 ; 100 ] + let! noisePct = Gen.elements [ 0 ; 10 ; 40 ] + let! input = genInput dropPct optionalPct noisePct tree + return payload, tree, input + } + + let property (payload : RefTree, tree : RefTree, input : RefInput) : unit = + let payloadNamed = namedIds payload + + match exhaustiveSelect tree input with + | RefOutcome.Ambiguous interps -> + failwithf "a gated container was ambiguous over %i interpretations" (List.length interps) + | RefOutcome.NoInterpretation -> + // Absence is always structurally available, so the only way to fail is for the + // input to demand the payload and the payload to reject it: either a named leaf + // beneath it was observed, or a positional event needs a sink to route to. + let touched = Set.intersect payloadNamed input.ObservedNamed + + if Set.isEmpty touched && List.isEmpty input.PositionalEvents then + failwith "an untouched container failed to fall back to absence" + | RefOutcome.Unique interp -> + match Map.tryFind 0 interp.Choices with + | Some 1 -> + absentChosen <- absentChosen + 1 + // Absence was chosen, so nothing beneath the group can have been supplied. + Set.intersect payloadNamed input.ObservedNamed |> shouldEqual Set.empty + interp.Named |> shouldEqual Set.empty + | Some 0 -> + suppliedChosen <- suppliedChosen + 1 + // The payload was chosen, so its own requirements were met in full. + Set.isSubset interp.RequiredNamed input.ObservedNamed |> shouldEqual true + | other -> failwithf "a container selected something other than its two cases: %A" other + + let config = Config.QuickThrowOnFailure.WithMaxTest 3000 + Check.One (config, Prop.forAll (Arb.fromGen cases) property) + + // The law is only interesting if both alternatives actually occur. + absentChosen |> shouldBeGreaterThan 100 + suppliedChosen |> shouldBeGreaterThan 100 + + [] + let ``An empty command line always chooses absence`` () = + let property (payload : RefTree) : unit = + let tree = container payload + + match + exhaustiveSelect + tree + { + ObservedNamed = Set.empty + PositionalEvents = [] + } + with + | RefOutcome.Unique interp -> Map.tryFind 0 interp.Choices |> shouldEqual (Some 1) + | other -> failwithf "an empty command line did not select absence: %A" other + + let config = Config.QuickThrowOnFailure.WithMaxTest 1000 + Check.One (config, Prop.forAll (Arb.fromGen genContainerPayload) property) + + [] + let ``Without the gate, an empty command line cannot choose`` () = + // Why the gate exists, stated as a property rather than as prose: the moment the payload + // is satisfiable by silence, both alternatives accept the empty command line and the + // model reports the ambiguity the generator refuses to emit. + let genEmptySatisfiablePayload = + gen { + let! sumBias = Gen.elements [ 0 ; 40 ] + let! namedCount = Gen.choose (1, 5) + let! tree = genTreeOver sumBias false (List.init namedCount id) + return renumber tree + } + |> Gen.filter emptySatisfiable + + let property (payload : RefTree) : unit = + match + exhaustiveSelect + (container payload) + { + ObservedNamed = Set.empty + PositionalEvents = [] + } + with + | RefOutcome.Ambiguous interps -> List.length interps |> shouldBeGreaterThan 1 + | other -> failwithf "an ungated container was not ambiguous on the empty command line: %A" other + + let config = Config.QuickThrowOnFailure.WithMaxTest 500 + Check.One (config, Prop.forAll (Arb.fromGen genEmptySatisfiablePayload) property) diff --git a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj index cecf195..205b4b9 100644 --- a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj +++ b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj @@ -48,6 +48,7 @@ + diff --git a/WoofWare.Myriad.Plugins/ArgParserGenerator.fs b/WoofWare.Myriad.Plugins/ArgParserGenerator.fs index 9c51913..fae8fc5 100644 --- a/WoofWare.Myriad.Plugins/ArgParserGenerator.fs +++ b/WoofWare.Myriad.Plugins/ArgParserGenerator.fs @@ -233,6 +233,16 @@ type private GroupHeader = Help : SynExpr option } +/// What a `Container` does when none of the arguments beneath it were supplied. +[] +type private ContainerKind = + /// `Child : ChildArgs option`. The field is `None`. + | Optional + /// `Child : Choice`. The field is `Choice2Of2` of the default, as for a + /// defaulted leaf, so a successful parse still reports whether the group was supplied. + /// The spec is always a `FunctionCall`: nothing else can construct a record. + | Defaulted of ArgumentDefaultSpec + /// The parse tree mirroring the schema's shape: named-argument leaves, positional-stream /// leaves, products (records) and exclusive sums (unions of alternative argument sets). /// Build Branch nodes only through ParseTree.branch, which enforces the positional-capacity @@ -268,6 +278,23 @@ type private ParseTree = header : GroupHeader option * cases : (Ident * SynExpr option * ParseTree) list * assemble : (Ident -> SynExpr -> SynExpr) + /// A whole argument group which need not be supplied: `Child : ChildArgs option`, and in + /// time the defaulted forms. `payload` is the tree the bare type would have produced. + /// + /// This erases to a two-case `Sum` whose second case is the empty product, so the runtime + /// needs to know nothing about it: a case is selected by whether any leaf beneath it was + /// supplied, which is exactly "was this group mentioned at all". It is a node of its own + /// rather than a `Sum` because it is not an alternation the user wrote, and help text must + /// not present it as one. + /// + /// `assemble` receives the instantiated payload when the group was supplied, and `None` + /// when it was not. + | Container of + sumId : int * + header : GroupHeader option * + kind : ContainerKind * + payload : ParseTree * + assemble : (SynExpr option -> SynExpr) [] module private ParseTree = @@ -279,6 +306,7 @@ module private ParseTree = | ParseTree.PositionalLeaf _ -> true | ParseTree.Branch (_, fields, _) -> fields |> List.exists (fun (_, child) -> containsPositional child) | ParseTree.Sum (_, _, cases, _) -> cases |> List.exists (fun (_, _, case) -> containsPositional case) + | ParseTree.Container (_, _, _, payload, _) -> containsPositional payload /// The `Ident` here is the field name. Moves the positional-claiming field (at most one /// is permitted) after its siblings. @@ -317,6 +345,9 @@ module private ParseTree = let caseNonPos, casePos = go case nonPos @ caseNonPos, pos @ casePos ) + // A container introduces no argument of its own: it only says whether the group + // beneath it had to be supplied. + | ParseTree.Container (_, _, _, payload, _) -> go payload let nonPos, pos = go tree @@ -468,6 +499,11 @@ module private ParseTree = | ParseTree.NonPositionalLeaf _ | ParseTree.PositionalLeaf _ -> false | ParseTree.Sum _ -> true + // A container is a two-way runtime branch which erases to a Sum, so every rule which + // exists because case selection can be perturbed applies to it too -- in particular the + // one forbidding a positional sink which collects unrecognised flag-like tokens, since a + // typo'd argument swallowed by such a sink would silently make the group absent. + | ParseTree.Container _ -> true | ParseTree.Branch (_, fields, _) -> fields |> List.exists (fun (_, child) -> containsSum child) /// Can this tree be satisfied by supplying no arguments at all? (Defaulted and optional @@ -486,6 +522,8 @@ module private ParseTree = | ParseTree.PositionalLeaf _ -> true | ParseTree.Branch (_, fields, _) -> fields |> List.forall (fun (_, child) -> emptySatisfiable child) | ParseTree.Sum (_, _, cases, _) -> cases |> List.exists (fun (_, _, case) -> emptySatisfiable case) + // Absence is always available: that is the whole point of the node. + | ParseTree.Container _ -> true /// For every union node in the tree, at most one case may be satisfiable with no arguments: /// were two cases so satisfiable, an empty command line could not choose between them. @@ -494,6 +532,11 @@ module private ParseTree = | ParseTree.NonPositionalLeaf _ | ParseTree.PositionalLeaf _ -> () | ParseTree.Branch (_, fields, _) -> fields |> List.iter (fun (_, child) -> checkSumAmbiguity child) + // The container's own two cases cannot be ambiguous: `toParseSpec` refuses to build one + // whose payload is satisfiable with no arguments, which is what would make the empty + // command line fit both. That check lives there because it can name the field and the + // types involved, which is what makes its message intelligible. + | ParseTree.Container (_, _, _, payload, _) -> checkSumAmbiguity payload | ParseTree.Sum (_, _, cases, _) -> cases |> List.iter (fun (_, _, case) -> checkSumAmbiguity case) @@ -550,6 +593,28 @@ module private ParseTree = SynExpr.applyFunction (rt [ "ErasedTree" ; "Sum" ]) (SynExpr.paren (SynExpr.tuple [ SynExpr.CreateConst sumId ; listOf caseExprs ])) + | ParseTree.Container (sumId, _, _, payload, _) -> + // A two-case Sum: the group's own arguments, or nothing at all. The payload is + // erased first so that its leaf ids stay in the same walk order `accumulators` uses, + // and it is case 0 so that `instantiate` can read the selection the same way. + // + // The empty product can never be "touched" (it has no leaf and no sink to receive an + // occurrence) and is always satisfiable by an empty command line, while the payload + // is never so satisfiable -- `toParseSpec` refuses to build a container otherwise. + // So exactly one case is always selectable, and none of the runtime's three + // selection errors can arise here; the case names below are for its diagnostics + // only, and are unreachable. + let payloadExpr = toErasedTreeExpr rt listOf counter posCounter payload + + let caseExprs = + [ + SynExpr.tuple [ SynExpr.CreateConst "supplied" ; payloadExpr ] + SynExpr.tuple [ SynExpr.CreateConst "absent" ; product [] ] + ] + + SynExpr.applyFunction + (rt [ "ErasedTree" ; "Sum" ]) + (SynExpr.paren (SynExpr.tuple [ SynExpr.CreateConst sumId ; listOf caseExprs ])) /// Build the return value. (References the `parser_selection` binding which the generated /// code brings into scope on the success path, to choose among Sum cases.) @@ -614,6 +679,32 @@ module private ParseTree = "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse")) SynExpr.createMatch scrutinee (clauses @ [ fallthrough ]) + | ParseTree.Container (sumId, _, _, payload, assemble) -> + // Case 0 is the payload and case 1 the empty product, as `toErasedTreeExpr` laid + // them out. The payload is instantiated only on the branch which selected it: the + // slots beneath an unselected case are legitimately unpopulated. + let scrutinee = + SynExpr.createLongIdent [ "Map" ; "tryFind" ] + |> SynExpr.applyTo (SynExpr.CreateConst sumId) + |> SynExpr.applyTo (SynExpr.dotGet "Choices" (SynExpr.createIdent "parser_selection")) + + let clauses = + [ + SynMatchClause.create + (SynPat.nameWithArgs "Some" [ SynPat.createConst (SynConst.Int32 0) ]) + (assemble (Some (SynExpr.paren (instantiate payload)))) + SynMatchClause.create + (SynPat.nameWithArgs "Some" [ SynPat.createConst (SynConst.Int32 1) ]) + (assemble None) + SynMatchClause.create + SynPat.anon + (SynExpr.applyFunction + (SynExpr.createIdent "failwith") + (SynExpr.CreateConst + "WoofWare.Myriad internal error in generated parser: no case selected despite a successful parse")) + ] + + SynExpr.createMatch scrutinee clauses | ParseTree.Branch (_, fields, assemble) -> fields |> List.map (fun (fieldName, contents) -> @@ -1247,11 +1338,25 @@ module internal ArgParserGenerator = let parseElt, acc, childTy = createParseFunction choice ambient owner fieldName attrs eltTy + // Every sibling arm rejects the nestings it cannot express, against the accumulation + // the recursive call came back with; this one must too. Without these, the illegal + // shapes classified successfully here and died much later against an assertion + // phrased as an internal error -- which they are not, being reachable from ordinary + // source. `Choice` is deliberately absent: the positional path spells its + // before/after-`--` tag as `Choice<'a, 'a> list`, and on the non-positional path the + // field-level default-attribute checks have already rejected the shape. match acc with | Accumulation.Map _ -> failwith $"ArgParser does not support lists of maps at field %s{fieldName.idText}: a map already accumulates across occurrences." - | _ -> () + | Accumulation.List _ -> + failwith + $"ArgParser does not support nested lists at field %s{fieldName.idText}: %s{describeType ty}. Each occurrence supplies one element, so there is no way to spell where one inner list ends and the next begins." + | Accumulation.Optional -> + failwith + $"ArgParser does not support lists of optionals at field %s{fieldName.idText}: %s{describeType ty}. An element is supplied by an occurrence, so an absent element would be an occurrence which is not there." + | Accumulation.Required + | Accumulation.Choice _ -> () parseElt, Accumulation.List acc, childTy | MapType (keyTy, valueTy) -> @@ -1564,11 +1669,16 @@ module internal ArgParserGenerator = with _ -> false - /// Re-backtick a field name, if it needs backticks to be usable as a bare record-construction - /// label -- exactly as its declaration needed them, if it had any (backticking is always a - /// legal alternative spelling of any identifier, so this is safe to apply unconditionally to + /// Re-backtick an identifier, if it needs backticks to be spliced into the generated file -- + /// exactly as its declaration needed them, if it had any (backticking is always a legal + /// alternative spelling of any identifier, so this is safe to apply unconditionally to /// whatever `isValidBareRecordLabel` rejects). - let private backtickRecordLabel (ident : string) : string = + /// + /// Used for record-construction labels, and for the `Default`-prefixed member name a defaulted + /// field calls: a field named ``space in name`` wants `Owner.``Defaultspace in name`` ()`, and + /// emitting that bare produces a file which does not parse. The record-label probe is the + /// right question to ask for both, being the stricter position of the two. + let private backtickIdent (ident : string) : string = if isValidBareRecordLabel ident then ident else @@ -1735,13 +1845,80 @@ module internal ArgParserGenerator = $"[] was applied to field '%s{ident.idText}', which carries []. A positional-args field has no subtree of nested arguments to namespace. If you want positional args nested under a prefix, move the [] field into a sub-record and put the [] on the record-typed field which holds it." | _ -> () + // A structural type may be wrapped in a container which says the whole group of + // arguments need not be supplied. Peel that layer off before asking whether what + // remains is a record or a union of alternative argument sets, so that the + // question is asked of the type which actually carries the arguments. + // + // Exactly one layer is peeled. Two of them (`ChildArgs option option`) would + // describe a distinction no command line can draw, and a type whose core is not + // structural is left entirely alone: it goes to the leaf machinery with its + // wrapper intact, exactly as before, and is accepted or refused there. + // + // The kind is deferred, because deciding it can fail: a `Choice` must say where + // its default comes from, and that is a complaint to make only once we know the + // core really is a group of arguments. `Choice` peels here too, and + // must reach the leaf machinery with its own diagnostics intact. + let containerLayer, coreType = + /// The default for a whole group of arguments can only come from a function: + /// neither a literal nor an environment variable can construct a record. + let structuralDefault () : ContainerKind = + let occurrences (names : string list) : int = + attrs + |> List.filter (fun attr -> + names |> List.contains (List.last attr.TypeName.LongIdent).idText + ) + |> List.length + + let carries (names : string list) : bool = occurrences names > 0 + + let reject (names : string list) (display : string) (why : string) : unit = + if carries names then + failwith + $"Field '%s{ident.idText}' has a [<%s{display}>], but its type %s{describeType fieldType} wraps an argument record or a union of alternative argument sets, so what it defaults to is a whole group of arguments. %s{why} Use [] instead, and write a static member which returns the group." + + reject + [ "ArgumentDefaultValue" ; "ArgumentDefaultValueAttribute" ] + "ArgumentDefaultValue" + "An attribute argument is a compile-time constant, and there is no constant which is a record." + + reject + [ + "ArgumentDefaultEnvironmentVariable" + "ArgumentDefaultEnvironmentVariableAttribute" + ] + "ArgumentDefaultEnvironmentVariable" + "An environment variable is one string, and there is no spelling by which one string becomes a whole group of arguments." + + // As for a defaulted leaf, at most one attribute may say where the + // default comes from. The other two kinds are rejected outright above, so + // the only way to have several here is to repeat this one. + match occurrences [ "ArgumentDefaultFunction" ; "ArgumentDefaultFunctionAttribute" ] with + | 1 -> + ArgumentDefaultSpec.FunctionCall ( + finalRecord.Name, + Ident.create ("Default" + ident.idText) + ) + |> ContainerKind.Defaulted + | 0 -> + failwith + $"Field '%s{ident.idText}' has type %s{describeType fieldType}, so it must say where its default comes from when none of the group's arguments are supplied. Add [] and a static member `Default%s{ident.idText} ()` returning the group, or give the field the plain type without the Choice." + | _ -> + failwith + $"Expected Choice to be annotated with at most one ArgumentDefaultFunction or similar, but it was annotated with multiple. Field: %s{ident.idText}" + + match fieldType with + | OptionType inner -> Some (fun () -> ContainerKind.Optional), inner + | ChoiceType [ elt1 ; elt2 ] when SynType.provablyEqual elt1 elt2 -> Some structuralDefault, elt1 + | _ -> None, fieldType + let ambientRecordMatch = - match localTypeName fieldType with + match localTypeName coreType with | Some target -> ambient.Records |> List.tryFind (fun r -> r.Name.idText = target) | None -> None let ambientUnionMatch = - match localTypeName fieldType with + match localTypeName coreType with | Some target -> ambient.StructuralUnions |> List.tryFind (fun u -> u.Name.idText = target) | None -> None @@ -1761,6 +1938,66 @@ module internal ArgParserGenerator = |> Option.orElseWith (fun () -> helpTextAttribute $"type %s{typeName}" typeAttrs) } + /// Build the tree for the field's structural core, and wrap it in a `Container` + /// if the field's declared type wrapped that core in one. `build` is given the + /// counter to start from and the header the group should be introduced by; when + /// there is a container the header moves onto it, so that the group is announced + /// once, by the node which knows it is optional. + let withContainer + (coreName : string) + (coreAttrs : SynAttribute list) + (describeWhyEmpty : unit -> string) + (build : GroupHeader option -> int -> ParseTree * int) + : ParseTree * int + = + let header = Some (groupHeader coreName coreAttrs) + + match containerLayer with + | None -> build header counter + | Some kind -> + + // Now that the core is known to be a group of arguments, it is safe to + // insist on knowing what its absence means. + let kind = kind () + + // The sum id is drawn before the payload's own ids, as a union's is. + let sumId = counter + let payload, counter = build None (counter + 1) + + // The container erases to "the group's arguments, or nothing at all", and + // the runtime picks between those by whether anything beneath was supplied. + // If the group can also be satisfied by supplying nothing, the two are + // indistinguishable and no command line could ever mean the first. Refuse + // here, where the field and the types can be named: left to the generic + // ambiguity check, this would surface as a complaint about two case names + // the author never wrote. + if ParseTree.emptySatisfiable payload then + let wrapper = + match kind with + | ContainerKind.Optional -> "an option" + | ContainerKind.Defaulted _ -> "a Choice" + + failwith + $"Field '%s{ident.idText}' has type %s{describeType fieldType}, but %s{coreName} is satisfiable with no arguments at all: %s{describeWhyEmpty ()} There is then no way to tell 'this group was supplied, and everything in it took its default' from 'this group was never mentioned', so it cannot be wrapped in %s{wrapper}. Make one of %s{coreName}'s arguments mandatory, or give the field the plain type %s{coreName}." + + let assemble (payload : SynExpr option) : SynExpr = + match kind, payload with + | ContainerKind.Optional, Some payload -> + SynExpr.applyFunction (SynExpr.createIdent "Some") payload + | ContainerKind.Optional, None -> SynExpr.createIdent "None" + | ContainerKind.Defaulted _, Some payload -> + SynExpr.applyFunction (SynExpr.createIdent "Choice1Of2") payload + | ContainerKind.Defaulted (ArgumentDefaultSpec.FunctionCall (owner, name)), None -> + SynExpr.callMethod (backtickIdent name.idText) (SynExpr.createIdent' owner) + |> SynExpr.paren + |> SynExpr.applyFunction (SynExpr.createIdent "Choice2Of2") + | ContainerKind.Defaulted spec, None -> + // `structuralDefault` admits nothing else. + failwith + $"WoofWare.Myriad internal error: a defaulted argument group was given a default of an unsupported kind (%O{spec})" + + ParseTree.Container (sumId, header, kind, payload, assemble), counter + match ambientRecordMatch with | Some childRecord -> // The structural branches are taken before any leaf machinery runs, so they @@ -1776,14 +2013,24 @@ module internal ArgParserGenerator = | None -> prefix | Some attrExpr -> extendPrefix ident prefix attrExpr + let describeWhyEmpty () : string = + let fields = + childRecord.Fields + |> List.choose (fun (SynField.SynField (idOpt = idOpt)) -> + idOpt |> Option.map (fun i -> $"'%s{i.idText}'") + ) + |> String.concat ", " + + $"every one of its fields (%s{fields}) is optional, has a default, or is a [] sink, which accepts zero tokens." + let spec, counter = - toParseSpec - ancestors - (Some (groupHeader childRecord.Name.idText childRecord.Attributes)) - childPrefix - counter - ambient - childRecord + withContainer + childRecord.Name.idText + childRecord.Attributes + describeWhyEmpty + (fun header counter -> + toParseSpec ancestors header childPrefix counter ambient childRecord + ) counter, (ident, spec) :: acc | None -> @@ -1802,14 +2049,15 @@ module internal ArgParserGenerator = | None -> prefix | Some attrExpr -> extendPrefix ident prefix attrExpr + let describeWhyEmpty () : string = + $"one of its cases can be selected by an empty command line, so an empty command line already means that case rather than meaning nothing at all." + let spec, counter = - unionToParseSpec - ancestors - (Some (groupHeader union.Name.idText union.Attributes)) - childPrefix - counter - ambient - union + withContainer + union.Name.idText + union.Attributes + describeWhyEmpty + (fun header counter -> unionToParseSpec ancestors header childPrefix counter ambient union) counter, (ident, spec) :: acc | None -> @@ -1866,11 +2114,11 @@ module internal ArgParserGenerator = let enumCases = identifyAsEnum ambient.EnumDus parseTy + // A list whose element is itself a list, an optional or a map is rejected by + // `createParseFunction` above, for reasons which hold whether or not the + // field is positional; only the two shapes a positional field can actually + // take reach here. The `Choice` is the before/after-`--` tag, not a default. match accumulation with - | Accumulation.List (Accumulation.List _) -> - failwith "A list of positional args cannot contain lists." - | Accumulation.List Accumulation.Optional -> - failwith "A list of positional args cannot contain optionals. What would that even mean?" | Accumulation.List (Accumulation.Choice ()) -> { FieldName = ident @@ -1901,8 +2149,9 @@ module internal ArgParserGenerator = AcceptsNegation = false } |> ParseTree.PositionalLeaf - | Accumulation.List (Accumulation.Map _) -> - failwith "A list of positional args cannot contain maps." + | Accumulation.List Accumulation.Optional + | Accumulation.List (Accumulation.List _) + | Accumulation.List (Accumulation.Map _) | Accumulation.Choice _ | Accumulation.Optional | Accumulation.Required @@ -2019,7 +2268,7 @@ module internal ArgParserGenerator = // (a space, a keyword, ...) must be re-backticked before it is safe to place // in this record-construction expression, exactly as the record's own // declaration required it to be written. - SynLongIdent.create [ Ident.create (backtickRecordLabel ident) ], expr + SynLongIdent.create [ Ident.create (backtickIdent ident) ], expr ) |> SynExpr.createRecord None ) @@ -2127,7 +2376,7 @@ module internal ArgParserGenerator = |> SynExpr.paren | Accumulation.Choice (ArgumentDefaultSpec.FunctionCall (owner, var)) -> // Display the spelling the user would have to type to supply this value. - SynExpr.callMethod var.idText (SynExpr.createIdent' owner) + SynExpr.callMethod (backtickIdent var.idText) (SynExpr.createIdent' owner) |> renderLeafValue flagCases arg.EnumCases |> SynExpr.pipeThroughFunction ( SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst " (default value: %s)") @@ -2209,7 +2458,10 @@ module internal ArgParserGenerator = /// `child: Database settings`. The help text is a SynExpr rather than a literal (it may be /// any expression the author wrote in the attribute), so the description has to be /// assembled by the generated program rather than spliced here. - let groupLine (depth : int) (header : GroupHeader) : SynExpr = + /// `annotation` is appended to the label, e.g. " (optional)" for a group which need not + /// be supplied at all. It goes on the label rather than after the help text so that it + /// stays adjacent to what it qualifies however long the help runs. + let groupLineAnnotated (depth : int) (annotation : string) (header : GroupHeader) : SynExpr = let indent = String.replicate depth " " // The label is a field name, which may be a backticked identifier and so may contain @@ -2219,7 +2471,7 @@ module internal ArgParserGenerator = let label = SynExpr.Const ( SynConst.String ( - ArgFormEmission.escapeStringConstant (indent + header.Label), + ArgFormEmission.escapeStringConstant (indent + header.Label + annotation), SynStringKind.Regular, range0 ), @@ -2239,6 +2491,8 @@ module internal ArgParserGenerator = |> SynExpr.applyTo (SynExpr.paren help) |> SynExpr.paren + let groupLine (depth : int) (header : GroupHeader) : SynExpr = groupLineAnnotated depth "" header + // Walk the tree so that a union's alternatives, and a nested record's arguments, are // *grouped* in the help rather than flattened into one undifferentiated list: the user // must be able to see which arguments go together. Non-positional lines appear in @@ -2260,6 +2514,25 @@ module internal ArgParserGenerator = match header with | None -> sumHelp depth cases | Some header -> groupLine depth header :: sumHelp (depth + 1) cases + | ParseTree.Container (_, header, kind, payload, _) -> + // The group reads as it would if the field were declared bare, with a note that + // it need not be supplied. It is deliberately not presented as an alternation: + // the two cases it erases to are ours, not the author's, and a reader shown + // "exactly one of" would go looking for a choice they never wrote. + // A defaulted group's value cannot be spelled the way a defaulted leaf's can: + // there is no single token which supplies a whole group, so `renderLeafValue` + // has nothing to render. Say that a default exists, and leave it at that. + let annotation = + match kind with + | ContainerKind.Optional -> " (optional)" + | ContainerKind.Defaulted _ -> " (optional; a default is used if omitted)" + + // A container is always reached through a field, so it always has a header to + // hang the annotation on; `toParseSpec` is the only thing which builds one. + match header with + | Some header -> groupLineAnnotated depth annotation header :: fieldHelp (depth + 1) payload + | None -> + failwith "WoofWare.Myriad internal error: an optional argument group had no header to describe it" and sumHelp (depth : int) (cases : (Ident * SynExpr option * ParseTree) list) : SynExpr list = let indent = String.replicate depth " " @@ -3042,7 +3315,9 @@ module internal ArgParserGenerator = | ArgumentDefaultSpec.FunctionCall (owner, name) -> SynExpr.sequential [ - storeDefault (SynExpr.callMethod name.idText (SynExpr.createIdent' owner)) + storeDefault ( + SynExpr.callMethod (backtickIdent name.idText) (SynExpr.createIdent' owner) + ) SynExpr.createIdent "None" ] | ArgumentDefaultSpec.Literal value -> diff --git a/WoofWare.Myriad.Plugins/Test/TestArgParserRejection.fs b/WoofWare.Myriad.Plugins/Test/TestArgParserRejection.fs index e983f31..22e64bc 100644 --- a/WoofWare.Myriad.Plugins/Test/TestArgParserRejection.fs +++ b/WoofWare.Myriad.Plugins/Test/TestArgParserRejection.fs @@ -1789,6 +1789,275 @@ type Args = |> shouldRejectWith "ArgParser does not support lists of maps at field Blah: a map already accumulates across occurrences." + /// The list arm used to check only for maps, so these two shapes classified successfully and + /// died much later against an assertion phrased as an internal error -- although they are + /// reachable from ordinary source. The positional arm has always rejected them properly, so + /// these pin the same treatment on both paths. + let private nestedList (field : string) (ty : string) : string = + $"ArgParser does not support nested lists at field %s{field}: %s{ty}. Each occurrence supplies one element, so there is no way to spell where one inner list ends and the next begins." + + let private listOfOptionals (field : string) (ty : string) : string = + $"ArgParser does not support lists of optionals at field %s{field}: %s{ty}. An element is supplied by an occurrence, so an absent element would be an occurrence which is not there." + + [] + let ``A nested list is rejected`` () = + """namespace TestMe + +open WoofWare.Myriad.Plugins + +[] +type Args = + { + Blah : int list list + } +""" + |> shouldRejectWith (nestedList "Blah" "int32 list list") + + [] + let ``A list of optionals is rejected`` () = + """namespace TestMe + +open WoofWare.Myriad.Plugins + +[] +type Args = + { + Blah : int option list + } +""" + |> shouldRejectWith (listOfOptionals "Blah" "int32 option list") + + [] + let ``A positional nested list is rejected`` () = + """namespace TestMe + +open WoofWare.Myriad.Plugins + +[] +type Args = + { + [] + Blah : int list list + } +""" + |> shouldRejectWith (nestedList "Blah" "int32 list list") + + [] + let ``A positional list of optionals is rejected`` () = + """namespace TestMe + +open WoofWare.Myriad.Plugins + +[] +type Args = + { + [] + Blah : int option list + } +""" + |> shouldRejectWith (listOfOptionals "Blah" "int32 option list") + + /// An optional argument group is present exactly when something beneath it was supplied. A + /// group which is itself satisfiable by supplying nothing therefore cannot be told apart from + /// its own absence, so it may not be wrapped. These pin the message, which must name the + /// field and the types rather than the two case names the generator invented. + [] + let ``An option wrapping an all-optional record is rejected`` () = + """namespace TestMe + +open WoofWare.Myriad.Plugins + +type Child = + { + Verbose : bool option + Colour : string option + } + +[] +type Args = + { + Child : Child option + } +""" + |> shouldRejectWith + "Field 'Child' has type Child option, but Child is satisfiable with no arguments at all: every one of its fields ('Verbose', 'Colour') is optional, has a default, or is a [] sink, which accepts zero tokens. There is then no way to tell 'this group was supplied, and everything in it took its default' from 'this group was never mentioned', so it cannot be wrapped in an option. Make one of Child's arguments mandatory, or give the field the plain type Child." + + /// A positional sink accepts zero tokens, so a record which is nothing but a sink is + /// satisfiable by an empty command line just as an all-optional record is. This is the case + /// an author is most likely to misjudge as "requires something", so the message names it. + [] + let ``An option wrapping a record of only positional args is rejected`` () = + """namespace TestMe + +open WoofWare.Myriad.Plugins + +type Child = + { + [] + Rest : string list + } + +[] +type Args = + { + Child : Child option + } +""" + |> shouldRejectWith + "Field 'Child' has type Child option, but Child is satisfiable with no arguments at all: every one of its fields ('Rest') is optional, has a default, or is a [] sink, which accepts zero tokens. There is then no way to tell 'this group was supplied, and everything in it took its default' from 'this group was never mentioned', so it cannot be wrapped in an option. Make one of Child's arguments mandatory, or give the field the plain type Child." + + [] + let ``An option wrapping a union with an empty-satisfiable case is rejected`` () = + """namespace TestMe + +open WoofWare.Myriad.Plugins + +type AutoArgs = + { + Quiet : bool option + } + +type ManualArgs = + { + Level : int + } + +type Mode = + | Auto of AutoArgs + | Manual of ManualArgs + +[] +type Args = + { + Mode : Mode option + } +""" + |> shouldRejectWith + "Field 'Mode' has type Mode option, but Mode is satisfiable with no arguments at all: one of its cases can be selected by an empty command line, so an empty command line already means that case rather than meaning nothing at all. There is then no way to tell 'this group was supplied, and everything in it took its default' from 'this group was never mentioned', so it cannot be wrapped in an option. Make one of Mode's arguments mandatory, or give the field the plain type Mode." + + /// A whole group of arguments can only be defaulted by a function: neither a literal nor an + /// environment variable can construct a record. + let private structuralDefaultSource (attribute : string) : string = + $"""namespace TestMe + +open WoofWare.Myriad.Plugins + +type Child = + {{ + Thing : int + }} + +[] +type Args = + {{ + [<{attribute}>] + Child : Choice + }} +""" + + [] + let ``ArgumentDefaultValue on a defaulted group is rejected`` () = + structuralDefaultSource "ArgumentDefaultValue 3" + |> shouldRejectWith + "Field 'Child' has a [], but its type Choice wraps an argument record or a union of alternative argument sets, so what it defaults to is a whole group of arguments. An attribute argument is a compile-time constant, and there is no constant which is a record. Use [] instead, and write a static member which returns the group." + + [] + let ``ArgumentDefaultEnvironmentVariable on a defaulted group is rejected`` () = + structuralDefaultSource "ArgumentDefaultEnvironmentVariable \"CHILD\"" + |> shouldRejectWith + "Field 'Child' has a [], but its type Choice wraps an argument record or a union of alternative argument sets, so what it defaults to is a whole group of arguments. An environment variable is one string, and there is no spelling by which one string becomes a whole group of arguments. Use [] instead, and write a static member which returns the group." + + /// A Choice says the group need not be supplied, so something must say what its absence + /// means; there is no sensible fallback to invent. + [] + let ``A Choice-wrapped group with no default attribute is rejected`` () = + """namespace TestMe + +open WoofWare.Myriad.Plugins + +type Child = + { + Thing : int + } + +[] +type Args = + { + Child : Choice + } +""" + |> shouldRejectWith + "Field 'Child' has type Choice, so it must say where its default comes from when none of the group's arguments are supplied. Add [] and a static member `DefaultChild ()` returning the group, or give the field the plain type without the Choice." + + /// At most one attribute may say where a default comes from, exactly as for a defaulted leaf. + /// The other two kinds are refused outright on a group, so repeating this one is the only way + /// to have several. + [] + let ``Repeated ArgumentDefaultFunction on a defaulted group is rejected`` () = + """namespace TestMe + +open WoofWare.Myriad.Plugins + +type Child = + { + Thing : int + } + +[] +type Args = + { + [] + [] + Child : Choice + } +""" + |> shouldRejectWith + "Expected Choice to be annotated with at most one ArgumentDefaultFunction or similar, but it was annotated with multiple. Field: Child" + + [] + let ``A Choice wrapping an all-optional record is rejected`` () = + """namespace TestMe + +open WoofWare.Myriad.Plugins + +type Child = + { + Verbose : bool option + } + +[] +type Args = + { + [] + Child : Choice + } +""" + |> shouldRejectWith + "Field 'Child' has type Choice, but Child is satisfiable with no arguments at all: every one of its fields ('Verbose') is optional, has a default, or is a [] sink, which accepts zero tokens. There is then no way to tell 'this group was supplied, and everything in it took its default' from 'this group was never mentioned', so it cannot be wrapped in a Choice. Make one of Child's arguments mandatory, or give the field the plain type Child." + + /// The attribute checks which guard a structural field were previously unreachable for a + /// wrapped one, because the field failed to classify at all before they ran. + [] + let ``ArgumentLongForm on an optional group is rejected`` () = + """namespace TestMe + +open WoofWare.Myriad.Plugins + +type Child = + { + Thing : int + } + +[] +type Args = + { + [] + Child : Child option + } +""" + |> shouldRejectWith + "Field 'Child' has an [], but its type Child option is an argument record or a discriminated union of alternative argument sets, so it contributes a whole set of arguments rather than one. [] renames a single argument, and there is none here to rename: the names come from the fields of Child option itself. Put the attribute on the field you mean to rename." + [] let ``A map with a non-scalar value type is rejected`` () = """namespace TestMe