diff --git a/.fantomasignore b/.fantomasignore new file mode 100644 index 0000000..9b42106 --- /dev/null +++ b/.fantomasignore @@ -0,0 +1 @@ +.direnv/ diff --git a/CHANGELOG.md b/CHANGELOG.md index 57e40fe..93f6e00 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ Notable changes are recorded here. +# WoofWare.Myriad.Plugins 2.2.1, WoofWare.Myriad.Plugins.Attributes 3.2.1 + +New generator: `ArgParser`, a basic reflection-free argument parser. + # WoofWare.Myriad.Plugins 2.1.45, WoofWare.Myriad.Plugins.Attributes 3.1.7 The NuGet packages are now attested to through [GitHub Attestations](https://github.blog/2024-05-02-introducing-artifact-attestations-now-in-public-beta/). diff --git a/ConsumePlugin/Args.fs b/ConsumePlugin/Args.fs index 0b68947..30e3419 100644 --- a/ConsumePlugin/Args.fs +++ b/ConsumePlugin/Args.fs @@ -93,3 +93,38 @@ type DatesAndTimes = [] InvariantExact : TimeSpan } + +type ChildRecord = + { + Thing1 : int + Thing2 : string + } + +[] +type ParentRecord = + { + Child : ChildRecord + AndAnother : bool + } + +type ChildRecordWithPositional = + { + Thing1 : int + [] + Thing2 : string list + } + +[] +type ParentRecordChildPos = + { + Child : ChildRecordWithPositional + AndAnother : bool + } + +[] +type ParentRecordSelfPos = + { + Child : ChildRecord + [] + AndAnother : bool list + } diff --git a/ConsumePlugin/GeneratedArgs.fs b/ConsumePlugin/GeneratedArgs.fs index f8e02ef..dbb090d 100644 --- a/ConsumePlugin/GeneratedArgs.fs +++ b/ConsumePlugin/GeneratedArgs.fs @@ -34,20 +34,20 @@ module BasicNoPositionals = |> String.concat "\n" let parser_LeftoverArgs : string ResizeArray = ResizeArray () - let mutable Foo : int option = None - let mutable Bar : string option = None - let mutable Baz : bool option = None - let Rest : int ResizeArray = ResizeArray () + let mutable arg_0 : int option = None + let mutable arg_1 : string option = None + let mutable arg_2 : bool option = None + let arg_3 : int ResizeArray = ResizeArray () /// Processes the key-value pair, returning Error if no key was matched. - /// If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(). + /// If the key is an arg which can have arity 1, but throws when consuming that arg, we return Error(). /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. let processKeyValue (key : string) (value : string) : Result = if System.String.Equals (key, "--rest", System.StringComparison.OrdinalIgnoreCase) then - (fun x -> System.Int32.Parse x) value |> Rest.Add + value |> (fun x -> System.Int32.Parse x) |> arg_3.Add () |> Ok else if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then - match Baz with + match arg_2 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--baz" x value |> ArgParser_errors.Add @@ -55,12 +55,12 @@ module BasicNoPositionals = Ok () | None -> try - Baz <- value |> (fun x -> System.Boolean.Parse x) |> Some + arg_2 <- value |> (fun x -> System.Boolean.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--bar", System.StringComparison.OrdinalIgnoreCase) then - match Bar with + match arg_1 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--bar" x value |> ArgParser_errors.Add @@ -68,12 +68,12 @@ module BasicNoPositionals = Ok () | None -> try - Bar <- value |> (fun x -> x) |> Some + arg_1 <- value |> (fun x -> x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--foo", System.StringComparison.OrdinalIgnoreCase) then - match Foo with + match arg_0 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--foo" x value |> ArgParser_errors.Add @@ -81,7 +81,7 @@ module BasicNoPositionals = Ok () | None -> try - Foo <- value |> (fun x -> System.Int32.Parse x) |> Some + arg_0 <- value |> (fun x -> System.Int32.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error @@ -91,12 +91,12 @@ module BasicNoPositionals = /// Returns false if we didn't set a value. let setFlagValue (key : string) : bool = if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then - match Baz with + match arg_2 with | Some x -> sprintf "Flag '%s' was supplied multiple times" "--baz" |> ArgParser_errors.Add true | None -> - Baz <- Some true + arg_2 <- Some true true else false @@ -165,8 +165,8 @@ module BasicNoPositionals = Unchecked.defaultof<_> - let Foo = - match Foo with + let arg_0 = + match arg_0 with | None -> sprintf "Required argument '%s' received no value" "--foo" |> ArgParser_errors.Add @@ -174,8 +174,8 @@ module BasicNoPositionals = Unchecked.defaultof<_> | Some x -> x - let Bar = - match Bar with + let arg_1 = + match arg_1 with | None -> sprintf "Required argument '%s' received no value" "--bar" |> ArgParser_errors.Add @@ -183,8 +183,8 @@ module BasicNoPositionals = Unchecked.defaultof<_> | Some x -> x - let Baz = - match Baz with + let arg_2 = + match arg_2 with | None -> sprintf "Required argument '%s' received no value" "--baz" |> ArgParser_errors.Add @@ -192,14 +192,14 @@ module BasicNoPositionals = Unchecked.defaultof<_> | Some x -> x - let Rest = Rest |> Seq.toList + let arg_3 = arg_3 |> Seq.toList if 0 = ArgParser_errors.Count then { - Foo = Foo - Bar = Bar - Baz = Baz - Rest = Rest + Bar = arg_1 + Baz = arg_2 + Foo = arg_0 + Rest = arg_3 } else ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" @@ -234,17 +234,17 @@ module Basic = ] |> String.concat "\n" - let Rest : string ResizeArray = ResizeArray () - let mutable Foo : int option = None - let mutable Bar : string option = None - let mutable Baz : bool option = None + let arg_3 : string ResizeArray = ResizeArray () + let mutable arg_0 : int option = None + let mutable arg_1 : string option = None + let mutable arg_2 : bool option = None /// Processes the key-value pair, returning Error if no key was matched. - /// If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(). + /// If the key is an arg which can have arity 1, but throws when consuming that arg, we return Error(). /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. let processKeyValue (key : string) (value : string) : Result = if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then - match Baz with + match arg_2 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--baz" x value |> ArgParser_errors.Add @@ -252,12 +252,12 @@ module Basic = Ok () | None -> try - Baz <- value |> (fun x -> System.Boolean.Parse x) |> Some + arg_2 <- value |> (fun x -> System.Boolean.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--bar", System.StringComparison.OrdinalIgnoreCase) then - match Bar with + match arg_1 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--bar" x value |> ArgParser_errors.Add @@ -265,12 +265,12 @@ module Basic = Ok () | None -> try - Bar <- value |> (fun x -> x) |> Some + arg_1 <- value |> (fun x -> x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--foo", System.StringComparison.OrdinalIgnoreCase) then - match Foo with + match arg_0 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--foo" x value |> ArgParser_errors.Add @@ -278,12 +278,12 @@ module Basic = Ok () | None -> try - Foo <- value |> (fun x -> System.Int32.Parse x) |> Some + arg_0 <- value |> (fun x -> System.Int32.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--rest", System.StringComparison.OrdinalIgnoreCase) then - (fun x -> x) value |> Rest.Add + value |> (fun x -> x) |> arg_3.Add () |> Ok else Error None @@ -291,12 +291,12 @@ module Basic = /// Returns false if we didn't set a value. let setFlagValue (key : string) : bool = if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then - match Baz with + match arg_2 with | Some x -> sprintf "Flag '%s' was supplied multiple times" "--baz" |> ArgParser_errors.Add true | None -> - Baz <- Some true + arg_2 <- Some true true else false @@ -314,7 +314,7 @@ module Basic = "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." key |> ArgParser_errors.Add - | "--" :: rest -> Rest.AddRange (rest |> Seq.map (fun x -> x)) + | "--" :: rest -> arg_3.AddRange (rest |> Seq.map (fun x -> x)) | arg :: args -> match state with | ParseState_Basic.AwaitingKey -> @@ -338,7 +338,7 @@ module Basic = sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add go ParseState_Basic.AwaitingKey args else - arg |> (fun x -> x) |> Rest.Add + arg |> (fun x -> x) |> arg_3.Add go ParseState_Basic.AwaitingKey args | ParseState_Basic.AwaitingValue key -> match processKeyValue key arg with @@ -353,10 +353,10 @@ module Basic = | Some msg -> msg |> ArgParser_errors.Add go ParseState_Basic.AwaitingKey args - let Rest = Rest |> Seq.toList + let arg_3 = arg_3 |> Seq.toList - let Foo = - match Foo with + let arg_0 = + match arg_0 with | None -> sprintf "Required argument '%s' received no value" "--foo" |> ArgParser_errors.Add @@ -364,8 +364,8 @@ module Basic = Unchecked.defaultof<_> | Some x -> x - let Bar = - match Bar with + let arg_1 = + match arg_1 with | None -> sprintf "Required argument '%s' received no value" "--bar" |> ArgParser_errors.Add @@ -373,8 +373,8 @@ module Basic = Unchecked.defaultof<_> | Some x -> x - let Baz = - match Baz with + let arg_2 = + match arg_2 with | None -> sprintf "Required argument '%s' received no value" "--baz" |> ArgParser_errors.Add @@ -384,10 +384,10 @@ module Basic = if 0 = ArgParser_errors.Count then { - Rest = Rest - Foo = Foo - Bar = Bar - Baz = Baz + Bar = arg_1 + Baz = arg_2 + Foo = arg_0 + Rest = arg_3 } else ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" @@ -419,17 +419,17 @@ module BasicWithIntPositionals = ] |> String.concat "\n" - let Rest : int ResizeArray = ResizeArray () - let mutable Foo : int option = None - let mutable Bar : string option = None - let mutable Baz : bool option = None + let arg_3 : int ResizeArray = ResizeArray () + let mutable arg_0 : int option = None + let mutable arg_1 : string option = None + let mutable arg_2 : bool option = None /// Processes the key-value pair, returning Error if no key was matched. - /// If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(). + /// If the key is an arg which can have arity 1, but throws when consuming that arg, we return Error(). /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. let processKeyValue (key : string) (value : string) : Result = if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then - match Baz with + match arg_2 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--baz" x value |> ArgParser_errors.Add @@ -437,12 +437,12 @@ module BasicWithIntPositionals = Ok () | None -> try - Baz <- value |> (fun x -> System.Boolean.Parse x) |> Some + arg_2 <- value |> (fun x -> System.Boolean.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--bar", System.StringComparison.OrdinalIgnoreCase) then - match Bar with + match arg_1 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--bar" x value |> ArgParser_errors.Add @@ -450,12 +450,12 @@ module BasicWithIntPositionals = Ok () | None -> try - Bar <- value |> (fun x -> x) |> Some + arg_1 <- value |> (fun x -> x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--foo", System.StringComparison.OrdinalIgnoreCase) then - match Foo with + match arg_0 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--foo" x value |> ArgParser_errors.Add @@ -463,12 +463,12 @@ module BasicWithIntPositionals = Ok () | None -> try - Foo <- value |> (fun x -> System.Int32.Parse x) |> Some + arg_0 <- value |> (fun x -> System.Int32.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--rest", System.StringComparison.OrdinalIgnoreCase) then - (fun x -> System.Int32.Parse x) value |> Rest.Add + value |> (fun x -> System.Int32.Parse x) |> arg_3.Add () |> Ok else Error None @@ -476,12 +476,12 @@ module BasicWithIntPositionals = /// Returns false if we didn't set a value. let setFlagValue (key : string) : bool = if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then - match Baz with + match arg_2 with | Some x -> sprintf "Flag '%s' was supplied multiple times" "--baz" |> ArgParser_errors.Add true | None -> - Baz <- Some true + arg_2 <- Some true true else false @@ -499,7 +499,7 @@ module BasicWithIntPositionals = "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." key |> ArgParser_errors.Add - | "--" :: rest -> Rest.AddRange (rest |> Seq.map (fun x -> System.Int32.Parse x)) + | "--" :: rest -> arg_3.AddRange (rest |> Seq.map (fun x -> System.Int32.Parse x)) | arg :: args -> match state with | ParseState_BasicWithIntPositionals.AwaitingKey -> @@ -523,7 +523,7 @@ module BasicWithIntPositionals = sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add go ParseState_BasicWithIntPositionals.AwaitingKey args else - arg |> (fun x -> System.Int32.Parse x) |> Rest.Add + arg |> (fun x -> System.Int32.Parse x) |> arg_3.Add go ParseState_BasicWithIntPositionals.AwaitingKey args | ParseState_BasicWithIntPositionals.AwaitingValue key -> match processKeyValue key arg with @@ -538,10 +538,10 @@ module BasicWithIntPositionals = | Some msg -> msg |> ArgParser_errors.Add go ParseState_BasicWithIntPositionals.AwaitingKey args - let Rest = Rest |> Seq.toList + let arg_3 = arg_3 |> Seq.toList - let Foo = - match Foo with + let arg_0 = + match arg_0 with | None -> sprintf "Required argument '%s' received no value" "--foo" |> ArgParser_errors.Add @@ -549,8 +549,8 @@ module BasicWithIntPositionals = Unchecked.defaultof<_> | Some x -> x - let Bar = - match Bar with + let arg_1 = + match arg_1 with | None -> sprintf "Required argument '%s' received no value" "--bar" |> ArgParser_errors.Add @@ -558,8 +558,8 @@ module BasicWithIntPositionals = Unchecked.defaultof<_> | Some x -> x - let Baz = - match Baz with + let arg_2 = + match arg_2 with | None -> sprintf "Required argument '%s' received no value" "--baz" |> ArgParser_errors.Add @@ -569,10 +569,10 @@ module BasicWithIntPositionals = if 0 = ArgParser_errors.Count then { - Rest = Rest - Foo = Foo - Bar = Bar - Baz = Baz + Bar = arg_1 + Baz = arg_2 + Foo = arg_0 + Rest = arg_3 } else ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" @@ -623,26 +623,26 @@ module LoadsOfTypes = ] |> String.concat "\n" - let Positionals : int ResizeArray = ResizeArray () - let mutable Foo : int option = None - let mutable Bar : string option = None - let mutable Baz : bool option = None - let mutable SomeFile : FileInfo option = None - let mutable SomeDirectory : DirectoryInfo option = None - let SomeList : DirectoryInfo ResizeArray = ResizeArray () - let mutable OptionalThingWithNoDefault : int option = None - let mutable OptionalThing : bool option = None - let mutable AnotherOptionalThing : int option = None - let mutable YetAnotherOptionalThing : string option = None + let arg_7 : int ResizeArray = ResizeArray () + let mutable arg_0 : int option = None + let mutable arg_1 : string option = None + let mutable arg_2 : bool option = None + let mutable arg_3 : FileInfo option = None + let mutable arg_4 : DirectoryInfo option = None + let arg_5 : DirectoryInfo ResizeArray = ResizeArray () + let mutable arg_6 : int option = None + let mutable arg_8 : bool option = None + let mutable arg_9 : int option = None + let mutable arg_10 : string option = None /// Processes the key-value pair, returning Error if no key was matched. - /// If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(). + /// If the key is an arg which can have arity 1, but throws when consuming that arg, we return Error(). /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. let processKeyValue (key : string) (value : string) : Result = if System.String.Equals (key, "--yet-another-optional-thing", System.StringComparison.OrdinalIgnoreCase) then - match YetAnotherOptionalThing with + match arg_10 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" @@ -654,14 +654,14 @@ module LoadsOfTypes = Ok () | None -> try - YetAnotherOptionalThing <- value |> (fun x -> x) |> Some + arg_10 <- value |> (fun x -> x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--another-optional-thing", System.StringComparison.OrdinalIgnoreCase) then - match AnotherOptionalThing with + match arg_9 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--another-optional-thing" x value |> ArgParser_errors.Add @@ -669,12 +669,12 @@ module LoadsOfTypes = Ok () | None -> try - AnotherOptionalThing <- value |> (fun x -> System.Int32.Parse x) |> Some + arg_9 <- value |> (fun x -> System.Int32.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--optional-thing", System.StringComparison.OrdinalIgnoreCase) then - match OptionalThing with + match arg_8 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--optional-thing" x value |> ArgParser_errors.Add @@ -682,7 +682,7 @@ module LoadsOfTypes = Ok () | None -> try - OptionalThing <- value |> (fun x -> System.Boolean.Parse x) |> Some + arg_8 <- value |> (fun x -> System.Boolean.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error @@ -693,7 +693,7 @@ module LoadsOfTypes = System.StringComparison.OrdinalIgnoreCase ) then - match OptionalThingWithNoDefault with + match arg_6 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" @@ -705,15 +705,15 @@ module LoadsOfTypes = Ok () | None -> try - OptionalThingWithNoDefault <- value |> (fun x -> System.Int32.Parse x) |> Some + arg_6 <- value |> (fun x -> System.Int32.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--some-list", System.StringComparison.OrdinalIgnoreCase) then - (fun x -> System.IO.DirectoryInfo x) value |> SomeList.Add + value |> (fun x -> System.IO.DirectoryInfo x) |> arg_5.Add () |> Ok else if System.String.Equals (key, "--some-directory", System.StringComparison.OrdinalIgnoreCase) then - match SomeDirectory with + match arg_4 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--some-directory" x value |> ArgParser_errors.Add @@ -721,12 +721,12 @@ module LoadsOfTypes = Ok () | None -> try - SomeDirectory <- value |> (fun x -> System.IO.DirectoryInfo x) |> Some + arg_4 <- value |> (fun x -> System.IO.DirectoryInfo x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--some-file", System.StringComparison.OrdinalIgnoreCase) then - match SomeFile with + match arg_3 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--some-file" x value |> ArgParser_errors.Add @@ -734,12 +734,12 @@ module LoadsOfTypes = Ok () | None -> try - SomeFile <- value |> (fun x -> System.IO.FileInfo x) |> Some + arg_3 <- value |> (fun x -> System.IO.FileInfo x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then - match Baz with + match arg_2 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--baz" x value |> ArgParser_errors.Add @@ -747,12 +747,12 @@ module LoadsOfTypes = Ok () | None -> try - Baz <- value |> (fun x -> System.Boolean.Parse x) |> Some + arg_2 <- value |> (fun x -> System.Boolean.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--bar", System.StringComparison.OrdinalIgnoreCase) then - match Bar with + match arg_1 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--bar" x value |> ArgParser_errors.Add @@ -760,12 +760,12 @@ module LoadsOfTypes = Ok () | None -> try - Bar <- value |> (fun x -> x) |> Some + arg_1 <- value |> (fun x -> x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--foo", System.StringComparison.OrdinalIgnoreCase) then - match Foo with + match arg_0 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--foo" x value |> ArgParser_errors.Add @@ -773,12 +773,12 @@ module LoadsOfTypes = Ok () | None -> try - Foo <- value |> (fun x -> System.Int32.Parse x) |> Some + arg_0 <- value |> (fun x -> System.Int32.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--positionals", System.StringComparison.OrdinalIgnoreCase) then - (fun x -> System.Int32.Parse x) value |> Positionals.Add + value |> (fun x -> System.Int32.Parse x) |> arg_7.Add () |> Ok else Error None @@ -786,22 +786,22 @@ module LoadsOfTypes = /// Returns false if we didn't set a value. let setFlagValue (key : string) : bool = if System.String.Equals (key, "--optional-thing", System.StringComparison.OrdinalIgnoreCase) then - match OptionalThing with + match arg_8 with | Some x -> sprintf "Flag '%s' was supplied multiple times" "--optional-thing" |> ArgParser_errors.Add true | None -> - OptionalThing <- Some true + arg_8 <- Some true true else if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then - match Baz with + match arg_2 with | Some x -> sprintf "Flag '%s' was supplied multiple times" "--baz" |> ArgParser_errors.Add true | None -> - Baz <- Some true + arg_2 <- Some true true else false @@ -819,7 +819,7 @@ module LoadsOfTypes = "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." key |> ArgParser_errors.Add - | "--" :: rest -> Positionals.AddRange (rest |> Seq.map (fun x -> System.Int32.Parse x)) + | "--" :: rest -> arg_7.AddRange (rest |> Seq.map (fun x -> System.Int32.Parse x)) | arg :: args -> match state with | ParseState_LoadsOfTypes.AwaitingKey -> @@ -843,7 +843,7 @@ module LoadsOfTypes = sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add go ParseState_LoadsOfTypes.AwaitingKey args else - arg |> (fun x -> System.Int32.Parse x) |> Positionals.Add + arg |> (fun x -> System.Int32.Parse x) |> arg_7.Add go ParseState_LoadsOfTypes.AwaitingKey args | ParseState_LoadsOfTypes.AwaitingValue key -> match processKeyValue key arg with @@ -858,10 +858,10 @@ module LoadsOfTypes = | Some msg -> msg |> ArgParser_errors.Add go ParseState_LoadsOfTypes.AwaitingKey args - let Positionals = Positionals |> Seq.toList + let arg_7 = arg_7 |> Seq.toList - let Foo = - match Foo with + let arg_0 = + match arg_0 with | None -> sprintf "Required argument '%s' received no value" "--foo" |> ArgParser_errors.Add @@ -869,8 +869,8 @@ module LoadsOfTypes = Unchecked.defaultof<_> | Some x -> x - let Bar = - match Bar with + let arg_1 = + match arg_1 with | None -> sprintf "Required argument '%s' received no value" "--bar" |> ArgParser_errors.Add @@ -878,8 +878,8 @@ module LoadsOfTypes = Unchecked.defaultof<_> | Some x -> x - let Baz = - match Baz with + let arg_2 = + match arg_2 with | None -> sprintf "Required argument '%s' received no value" "--baz" |> ArgParser_errors.Add @@ -887,8 +887,8 @@ module LoadsOfTypes = Unchecked.defaultof<_> | Some x -> x - let SomeFile = - match SomeFile with + let arg_3 = + match arg_3 with | None -> sprintf "Required argument '%s' received no value" "--some-file" |> ArgParser_errors.Add @@ -896,8 +896,8 @@ module LoadsOfTypes = Unchecked.defaultof<_> | Some x -> x - let SomeDirectory = - match SomeDirectory with + let arg_4 = + match arg_4 with | None -> sprintf "Required argument '%s' received no value" "--some-directory" |> ArgParser_errors.Add @@ -905,21 +905,21 @@ module LoadsOfTypes = Unchecked.defaultof<_> | Some x -> x - let SomeList = SomeList |> Seq.toList - let OptionalThingWithNoDefault = OptionalThingWithNoDefault + let arg_5 = arg_5 |> Seq.toList + let arg_6 = arg_6 - let OptionalThing = - match OptionalThing with + let arg_8 = + match arg_8 with | None -> LoadsOfTypes.DefaultOptionalThing () |> Choice2Of2 | Some x -> Choice1Of2 x - let AnotherOptionalThing = - match AnotherOptionalThing with + let arg_9 = + match arg_9 with | None -> LoadsOfTypes.DefaultAnotherOptionalThing () |> Choice2Of2 | Some x -> Choice1Of2 x - let YetAnotherOptionalThing = - match YetAnotherOptionalThing with + let arg_10 = + match arg_10 with | None -> match "CONSUMEPLUGIN_THINGS" |> getEnvironmentVariable with | null -> @@ -936,17 +936,17 @@ module LoadsOfTypes = if 0 = ArgParser_errors.Count then { - Positionals = Positionals - Foo = Foo - Bar = Bar - Baz = Baz - SomeFile = SomeFile - SomeDirectory = SomeDirectory - SomeList = SomeList - OptionalThingWithNoDefault = OptionalThingWithNoDefault - OptionalThing = OptionalThing - AnotherOptionalThing = AnotherOptionalThing - YetAnotherOptionalThing = YetAnotherOptionalThing + AnotherOptionalThing = arg_9 + Bar = arg_1 + Baz = arg_2 + Foo = arg_0 + OptionalThing = arg_8 + OptionalThingWithNoDefault = arg_6 + Positionals = arg_7 + SomeDirectory = arg_4 + SomeFile = arg_3 + SomeList = arg_5 + YetAnotherOptionalThing = arg_10 } else ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" @@ -998,25 +998,25 @@ module LoadsOfTypesNoPositionals = |> String.concat "\n" let parser_LeftoverArgs : string ResizeArray = ResizeArray () - let mutable Foo : int option = None - let mutable Bar : string option = None - let mutable Baz : bool option = None - let mutable SomeFile : FileInfo option = None - let mutable SomeDirectory : DirectoryInfo option = None - let SomeList : DirectoryInfo ResizeArray = ResizeArray () - let mutable OptionalThingWithNoDefault : int option = None - let mutable OptionalThing : bool option = None - let mutable AnotherOptionalThing : int option = None - let mutable YetAnotherOptionalThing : string option = None + let mutable arg_0 : int option = None + let mutable arg_1 : string option = None + let mutable arg_2 : bool option = None + let mutable arg_3 : FileInfo option = None + let mutable arg_4 : DirectoryInfo option = None + let arg_5 : DirectoryInfo ResizeArray = ResizeArray () + let mutable arg_6 : int option = None + let mutable arg_7 : bool option = None + let mutable arg_8 : int option = None + let mutable arg_9 : string option = None /// Processes the key-value pair, returning Error if no key was matched. - /// If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(). + /// If the key is an arg which can have arity 1, but throws when consuming that arg, we return Error(). /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. let processKeyValue (key : string) (value : string) : Result = if System.String.Equals (key, "--yet-another-optional-thing", System.StringComparison.OrdinalIgnoreCase) then - match YetAnotherOptionalThing with + match arg_9 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" @@ -1028,14 +1028,14 @@ module LoadsOfTypesNoPositionals = Ok () | None -> try - YetAnotherOptionalThing <- value |> (fun x -> x) |> Some + arg_9 <- value |> (fun x -> x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--another-optional-thing", System.StringComparison.OrdinalIgnoreCase) then - match AnotherOptionalThing with + match arg_8 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--another-optional-thing" x value |> ArgParser_errors.Add @@ -1043,12 +1043,12 @@ module LoadsOfTypesNoPositionals = Ok () | None -> try - AnotherOptionalThing <- value |> (fun x -> System.Int32.Parse x) |> Some + arg_8 <- value |> (fun x -> System.Int32.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--optional-thing", System.StringComparison.OrdinalIgnoreCase) then - match OptionalThing with + match arg_7 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--optional-thing" x value |> ArgParser_errors.Add @@ -1056,7 +1056,7 @@ module LoadsOfTypesNoPositionals = Ok () | None -> try - OptionalThing <- value |> (fun x -> System.Boolean.Parse x) |> Some + arg_7 <- value |> (fun x -> System.Boolean.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error @@ -1067,7 +1067,7 @@ module LoadsOfTypesNoPositionals = System.StringComparison.OrdinalIgnoreCase ) then - match OptionalThingWithNoDefault with + match arg_6 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" @@ -1079,15 +1079,15 @@ module LoadsOfTypesNoPositionals = Ok () | None -> try - OptionalThingWithNoDefault <- value |> (fun x -> System.Int32.Parse x) |> Some + arg_6 <- value |> (fun x -> System.Int32.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--some-list", System.StringComparison.OrdinalIgnoreCase) then - (fun x -> System.IO.DirectoryInfo x) value |> SomeList.Add + value |> (fun x -> System.IO.DirectoryInfo x) |> arg_5.Add () |> Ok else if System.String.Equals (key, "--some-directory", System.StringComparison.OrdinalIgnoreCase) then - match SomeDirectory with + match arg_4 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--some-directory" x value |> ArgParser_errors.Add @@ -1095,12 +1095,12 @@ module LoadsOfTypesNoPositionals = Ok () | None -> try - SomeDirectory <- value |> (fun x -> System.IO.DirectoryInfo x) |> Some + arg_4 <- value |> (fun x -> System.IO.DirectoryInfo x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--some-file", System.StringComparison.OrdinalIgnoreCase) then - match SomeFile with + match arg_3 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--some-file" x value |> ArgParser_errors.Add @@ -1108,12 +1108,12 @@ module LoadsOfTypesNoPositionals = Ok () | None -> try - SomeFile <- value |> (fun x -> System.IO.FileInfo x) |> Some + arg_3 <- value |> (fun x -> System.IO.FileInfo x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then - match Baz with + match arg_2 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--baz" x value |> ArgParser_errors.Add @@ -1121,12 +1121,12 @@ module LoadsOfTypesNoPositionals = Ok () | None -> try - Baz <- value |> (fun x -> System.Boolean.Parse x) |> Some + arg_2 <- value |> (fun x -> System.Boolean.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--bar", System.StringComparison.OrdinalIgnoreCase) then - match Bar with + match arg_1 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--bar" x value |> ArgParser_errors.Add @@ -1134,12 +1134,12 @@ module LoadsOfTypesNoPositionals = Ok () | None -> try - Bar <- value |> (fun x -> x) |> Some + arg_1 <- value |> (fun x -> x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--foo", System.StringComparison.OrdinalIgnoreCase) then - match Foo with + match arg_0 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--foo" x value |> ArgParser_errors.Add @@ -1147,7 +1147,7 @@ module LoadsOfTypesNoPositionals = Ok () | None -> try - Foo <- value |> (fun x -> System.Int32.Parse x) |> Some + arg_0 <- value |> (fun x -> System.Int32.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error @@ -1157,22 +1157,22 @@ module LoadsOfTypesNoPositionals = /// Returns false if we didn't set a value. let setFlagValue (key : string) : bool = if System.String.Equals (key, "--optional-thing", System.StringComparison.OrdinalIgnoreCase) then - match OptionalThing with + match arg_7 with | Some x -> sprintf "Flag '%s' was supplied multiple times" "--optional-thing" |> ArgParser_errors.Add true | None -> - OptionalThing <- Some true + arg_7 <- Some true true else if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then - match Baz with + match arg_2 with | Some x -> sprintf "Flag '%s' was supplied multiple times" "--baz" |> ArgParser_errors.Add true | None -> - Baz <- Some true + arg_2 <- Some true true else false @@ -1241,8 +1241,8 @@ module LoadsOfTypesNoPositionals = Unchecked.defaultof<_> - let Foo = - match Foo with + let arg_0 = + match arg_0 with | None -> sprintf "Required argument '%s' received no value" "--foo" |> ArgParser_errors.Add @@ -1250,8 +1250,8 @@ module LoadsOfTypesNoPositionals = Unchecked.defaultof<_> | Some x -> x - let Bar = - match Bar with + let arg_1 = + match arg_1 with | None -> sprintf "Required argument '%s' received no value" "--bar" |> ArgParser_errors.Add @@ -1259,8 +1259,8 @@ module LoadsOfTypesNoPositionals = Unchecked.defaultof<_> | Some x -> x - let Baz = - match Baz with + let arg_2 = + match arg_2 with | None -> sprintf "Required argument '%s' received no value" "--baz" |> ArgParser_errors.Add @@ -1268,8 +1268,8 @@ module LoadsOfTypesNoPositionals = Unchecked.defaultof<_> | Some x -> x - let SomeFile = - match SomeFile with + let arg_3 = + match arg_3 with | None -> sprintf "Required argument '%s' received no value" "--some-file" |> ArgParser_errors.Add @@ -1277,8 +1277,8 @@ module LoadsOfTypesNoPositionals = Unchecked.defaultof<_> | Some x -> x - let SomeDirectory = - match SomeDirectory with + let arg_4 = + match arg_4 with | None -> sprintf "Required argument '%s' received no value" "--some-directory" |> ArgParser_errors.Add @@ -1286,21 +1286,21 @@ module LoadsOfTypesNoPositionals = Unchecked.defaultof<_> | Some x -> x - let SomeList = SomeList |> Seq.toList - let OptionalThingWithNoDefault = OptionalThingWithNoDefault + let arg_5 = arg_5 |> Seq.toList + let arg_6 = arg_6 - let OptionalThing = - match OptionalThing with + let arg_7 = + match arg_7 with | None -> LoadsOfTypesNoPositionals.DefaultOptionalThing () |> Choice2Of2 | Some x -> Choice1Of2 x - let AnotherOptionalThing = - match AnotherOptionalThing with + let arg_8 = + match arg_8 with | None -> LoadsOfTypesNoPositionals.DefaultAnotherOptionalThing () |> Choice2Of2 | Some x -> Choice1Of2 x - let YetAnotherOptionalThing = - match YetAnotherOptionalThing with + let arg_9 = + match arg_9 with | None -> match "CONSUMEPLUGIN_THINGS" |> getEnvironmentVariable with | null -> @@ -1317,16 +1317,16 @@ module LoadsOfTypesNoPositionals = if 0 = ArgParser_errors.Count then { - Foo = Foo - Bar = Bar - Baz = Baz - SomeFile = SomeFile - SomeDirectory = SomeDirectory - SomeList = SomeList - OptionalThingWithNoDefault = OptionalThingWithNoDefault - OptionalThing = OptionalThing - AnotherOptionalThing = AnotherOptionalThing - YetAnotherOptionalThing = YetAnotherOptionalThing + AnotherOptionalThing = arg_8 + Bar = arg_1 + Baz = arg_2 + Foo = arg_0 + OptionalThing = arg_7 + OptionalThingWithNoDefault = arg_6 + SomeDirectory = arg_4 + SomeFile = arg_3 + SomeList = arg_5 + YetAnotherOptionalThing = arg_9 } else ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" @@ -1369,17 +1369,17 @@ module DatesAndTimesArgParse = |> String.concat "\n" let parser_LeftoverArgs : string ResizeArray = ResizeArray () - let mutable Plain : TimeSpan option = None - let mutable Invariant : TimeSpan option = None - let mutable Exact : TimeSpan option = None - let mutable InvariantExact : TimeSpan option = None + let mutable arg_0 : TimeSpan option = None + let mutable arg_1 : TimeSpan option = None + let mutable arg_2 : TimeSpan option = None + let mutable arg_3 : TimeSpan option = None /// Processes the key-value pair, returning Error if no key was matched. - /// If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(). + /// If the key is an arg which can have arity 1, but throws when consuming that arg, we return Error(). /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. let processKeyValue (key : string) (value : string) : Result = if System.String.Equals (key, "--invariant-exact", System.StringComparison.OrdinalIgnoreCase) then - match InvariantExact with + match arg_3 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--invariant-exact" x value |> ArgParser_errors.Add @@ -1387,7 +1387,7 @@ module DatesAndTimesArgParse = Ok () | None -> try - InvariantExact <- + arg_3 <- value |> (fun x -> System.TimeSpan.ParseExact ( @@ -1402,7 +1402,7 @@ module DatesAndTimesArgParse = with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--exact", System.StringComparison.OrdinalIgnoreCase) then - match Exact with + match arg_2 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--exact" x value |> ArgParser_errors.Add @@ -1410,7 +1410,7 @@ module DatesAndTimesArgParse = Ok () | None -> try - Exact <- + arg_2 <- value |> (fun x -> System.TimeSpan.ParseExact ( @@ -1425,7 +1425,7 @@ module DatesAndTimesArgParse = with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--invariant", System.StringComparison.OrdinalIgnoreCase) then - match Invariant with + match arg_1 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--invariant" x value |> ArgParser_errors.Add @@ -1433,7 +1433,7 @@ module DatesAndTimesArgParse = Ok () | None -> try - Invariant <- + arg_1 <- value |> (fun x -> System.TimeSpan.Parse (x, System.Globalization.CultureInfo.InvariantCulture) @@ -1444,7 +1444,7 @@ module DatesAndTimesArgParse = with _ as exc -> exc.Message |> Some |> Error else if System.String.Equals (key, "--plain", System.StringComparison.OrdinalIgnoreCase) then - match Plain with + match arg_0 with | Some x -> sprintf "Argument '%s' was supplied multiple times: %O and %O" "--plain" x value |> ArgParser_errors.Add @@ -1452,7 +1452,7 @@ module DatesAndTimesArgParse = Ok () | None -> try - Plain <- value |> (fun x -> System.TimeSpan.Parse x) |> Some + arg_0 <- value |> (fun x -> System.TimeSpan.Parse x) |> Some Ok () with _ as exc -> exc.Message |> Some |> Error @@ -1529,8 +1529,8 @@ module DatesAndTimesArgParse = Unchecked.defaultof<_> - let Plain = - match Plain with + let arg_0 = + match arg_0 with | None -> sprintf "Required argument '%s' received no value" "--plain" |> ArgParser_errors.Add @@ -1538,8 +1538,8 @@ module DatesAndTimesArgParse = Unchecked.defaultof<_> | Some x -> x - let Invariant = - match Invariant with + let arg_1 = + match arg_1 with | None -> sprintf "Required argument '%s' received no value" "--invariant" |> ArgParser_errors.Add @@ -1547,8 +1547,8 @@ module DatesAndTimesArgParse = Unchecked.defaultof<_> | Some x -> x - let Exact = - match Exact with + let arg_2 = + match arg_2 with | None -> sprintf "Required argument '%s' received no value" "--exact" |> ArgParser_errors.Add @@ -1556,8 +1556,8 @@ module DatesAndTimesArgParse = Unchecked.defaultof<_> | Some x -> x - let InvariantExact = - match InvariantExact with + let arg_3 = + match arg_3 with | None -> sprintf "Required argument '%s' received no value" "--invariant-exact" |> ArgParser_errors.Add @@ -1567,13 +1567,544 @@ module DatesAndTimesArgParse = if 0 = ArgParser_errors.Count then { - Plain = Plain - Invariant = Invariant - Exact = Exact - InvariantExact = InvariantExact + Exact = arg_2 + Invariant = arg_1 + InvariantExact = arg_3 + Plain = arg_0 } else ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" static member parse (args : string list) : DatesAndTimes = DatesAndTimes.parse' System.Environment.GetEnvironmentVariable args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type ParentRecord +[] +module ParentRecordArgParse = + type private ParseState_ParentRecord = + | AwaitingKey + | AwaitingValue of key : string + + /// Extension methods for argument parsing + type ParentRecord with + + static member parse' (getEnvironmentVariable : string -> string) (args : string list) : ParentRecord = + let ArgParser_errors = ResizeArray () + + let helpText () = + [ + (sprintf "--thing1 int32%s%s" "" "") + (sprintf "--thing2 string%s%s" "" "") + (sprintf "--and-another bool%s%s" "" "") + ] + |> String.concat "\n" + + let parser_LeftoverArgs : string ResizeArray = ResizeArray () + let mutable arg_0 : int option = None + let mutable arg_1 : string option = None + let mutable arg_2 : bool option = None + + /// Processes the key-value pair, returning Error if no key was matched. + /// If the key is an arg which can have arity 1, but throws when consuming that arg, we return Error(). + /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. + let processKeyValue (key : string) (value : string) : Result = + if System.String.Equals (key, "--and-another", System.StringComparison.OrdinalIgnoreCase) then + match arg_2 with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--and-another" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + arg_2 <- value |> (fun x -> System.Boolean.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--thing2", System.StringComparison.OrdinalIgnoreCase) then + match arg_1 with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--thing2" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + arg_1 <- value |> (fun x -> x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--thing1", System.StringComparison.OrdinalIgnoreCase) then + match arg_0 with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--thing1" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + arg_0 <- value |> (fun x -> System.Int32.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else + Error None + + /// Returns false if we didn't set a value. + let setFlagValue (key : string) : bool = + if System.String.Equals (key, "--and-another", System.StringComparison.OrdinalIgnoreCase) then + match arg_2 with + | Some x -> + sprintf "Flag '%s' was supplied multiple times" "--and-another" + |> ArgParser_errors.Add + + true + | None -> + arg_2 <- Some true + true + else + false + + let rec go (state : ParseState_ParentRecord) (args : string list) = + match args with + | [] -> + match state with + | ParseState_ParentRecord.AwaitingKey -> () + | ParseState_ParentRecord.AwaitingValue key -> + if setFlagValue key then + () + else + sprintf + "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." + key + |> ArgParser_errors.Add + | "--" :: rest -> parser_LeftoverArgs.AddRange (rest |> Seq.map (fun x -> x)) + | arg :: args -> + match state with + | ParseState_ParentRecord.AwaitingKey -> + if arg.StartsWith ("--", System.StringComparison.Ordinal) then + if arg = "--help" then + helpText () |> failwithf "Help text requested.\n%s" + else + let equals = arg.IndexOf (char 61) + + if equals < 0 then + args |> go (ParseState_ParentRecord.AwaitingValue arg) + else + let key = arg.[0 .. equals - 1] + let value = arg.[equals + 1 ..] + + match processKeyValue key value with + | Ok () -> go ParseState_ParentRecord.AwaitingKey args + | Error None -> + failwithf "Unable to process argument %s as key %s and value %s" arg key value + | Error (Some msg) -> + sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add + go ParseState_ParentRecord.AwaitingKey args + else + arg |> (fun x -> x) |> parser_LeftoverArgs.Add + go ParseState_ParentRecord.AwaitingKey args + | ParseState_ParentRecord.AwaitingValue key -> + match processKeyValue key arg with + | Ok () -> go ParseState_ParentRecord.AwaitingKey args + | Error exc -> + if setFlagValue key then + go ParseState_ParentRecord.AwaitingKey (arg :: args) + else + match exc with + | None -> + failwithf + "Unable to process supplied arg %s. Help text follows.\n%s" + key + (helpText ()) + | Some msg -> msg |> ArgParser_errors.Add + + go ParseState_ParentRecord.AwaitingKey args + + let parser_LeftoverArgs = + if 0 = parser_LeftoverArgs.Count then + () + else + parser_LeftoverArgs + |> String.concat " " + |> sprintf "There were leftover args: %s" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + + let arg_0 = + match arg_0 with + | None -> + sprintf "Required argument '%s' received no value" "--thing1" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let arg_1 = + match arg_1 with + | None -> + sprintf "Required argument '%s' received no value" "--thing2" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let arg_2 = + match arg_2 with + | None -> + sprintf "Required argument '%s' received no value" "--and-another" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + if 0 = ArgParser_errors.Count then + { + AndAnother = arg_2 + Child = + { + Thing1 = arg_0 + Thing2 = arg_1 + } + } + else + ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + static member parse (args : string list) : ParentRecord = + ParentRecord.parse' System.Environment.GetEnvironmentVariable args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type ParentRecordChildPos +[] +module ParentRecordChildPosArgParse = + type private ParseState_ParentRecordChildPos = + | AwaitingKey + | AwaitingValue of key : string + + /// Extension methods for argument parsing + type ParentRecordChildPos with + + static member parse' (getEnvironmentVariable : string -> string) (args : string list) : ParentRecordChildPos = + let ArgParser_errors = ResizeArray () + + let helpText () = + [ + (sprintf "--and-another bool%s%s" "" "") + (sprintf "--thing1 int32%s%s" "" "") + (sprintf "--thing2 string (positional args)%s%s" " (can be repeated)" "") + ] + |> String.concat "\n" + + let arg_1 : string ResizeArray = ResizeArray () + let mutable arg_2 : bool option = None + let mutable arg_0 : int option = None + + /// Processes the key-value pair, returning Error if no key was matched. + /// If the key is an arg which can have arity 1, but throws when consuming that arg, we return Error(). + /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. + let processKeyValue (key : string) (value : string) : Result = + if System.String.Equals (key, "--thing1", System.StringComparison.OrdinalIgnoreCase) then + match arg_0 with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--thing1" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + arg_0 <- value |> (fun x -> System.Int32.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--and-another", System.StringComparison.OrdinalIgnoreCase) then + match arg_2 with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--and-another" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + arg_2 <- value |> (fun x -> System.Boolean.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--thing2", System.StringComparison.OrdinalIgnoreCase) then + value |> (fun x -> x) |> arg_1.Add + () |> Ok + else + Error None + + /// Returns false if we didn't set a value. + let setFlagValue (key : string) : bool = + if System.String.Equals (key, "--and-another", System.StringComparison.OrdinalIgnoreCase) then + match arg_2 with + | Some x -> + sprintf "Flag '%s' was supplied multiple times" "--and-another" + |> ArgParser_errors.Add + + true + | None -> + arg_2 <- Some true + true + else + false + + let rec go (state : ParseState_ParentRecordChildPos) (args : string list) = + match args with + | [] -> + match state with + | ParseState_ParentRecordChildPos.AwaitingKey -> () + | ParseState_ParentRecordChildPos.AwaitingValue key -> + if setFlagValue key then + () + else + sprintf + "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." + key + |> ArgParser_errors.Add + | "--" :: rest -> arg_1.AddRange (rest |> Seq.map (fun x -> x)) + | arg :: args -> + match state with + | ParseState_ParentRecordChildPos.AwaitingKey -> + if arg.StartsWith ("--", System.StringComparison.Ordinal) then + if arg = "--help" then + helpText () |> failwithf "Help text requested.\n%s" + else + let equals = arg.IndexOf (char 61) + + if equals < 0 then + args |> go (ParseState_ParentRecordChildPos.AwaitingValue arg) + else + let key = arg.[0 .. equals - 1] + let value = arg.[equals + 1 ..] + + match processKeyValue key value with + | Ok () -> go ParseState_ParentRecordChildPos.AwaitingKey args + | Error None -> + failwithf "Unable to process argument %s as key %s and value %s" arg key value + | Error (Some msg) -> + sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add + go ParseState_ParentRecordChildPos.AwaitingKey args + else + arg |> (fun x -> x) |> arg_1.Add + go ParseState_ParentRecordChildPos.AwaitingKey args + | ParseState_ParentRecordChildPos.AwaitingValue key -> + match processKeyValue key arg with + | Ok () -> go ParseState_ParentRecordChildPos.AwaitingKey args + | Error exc -> + if setFlagValue key then + go ParseState_ParentRecordChildPos.AwaitingKey (arg :: args) + else + match exc with + | None -> + failwithf + "Unable to process supplied arg %s. Help text follows.\n%s" + key + (helpText ()) + | Some msg -> msg |> ArgParser_errors.Add + + go ParseState_ParentRecordChildPos.AwaitingKey args + let arg_1 = arg_1 |> Seq.toList + + let arg_2 = + match arg_2 with + | None -> + sprintf "Required argument '%s' received no value" "--and-another" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let arg_0 = + match arg_0 with + | None -> + sprintf "Required argument '%s' received no value" "--thing1" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + if 0 = ArgParser_errors.Count then + { + AndAnother = arg_2 + Child = + { + Thing1 = arg_0 + Thing2 = arg_1 + } + } + else + ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + static member parse (args : string list) : ParentRecordChildPos = + ParentRecordChildPos.parse' System.Environment.GetEnvironmentVariable args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type ParentRecordSelfPos +[] +module ParentRecordSelfPosArgParse = + type private ParseState_ParentRecordSelfPos = + | AwaitingKey + | AwaitingValue of key : string + + /// Extension methods for argument parsing + type ParentRecordSelfPos with + + static member parse' (getEnvironmentVariable : string -> string) (args : string list) : ParentRecordSelfPos = + let ArgParser_errors = ResizeArray () + + let helpText () = + [ + (sprintf "--thing1 int32%s%s" "" "") + (sprintf "--thing2 string%s%s" "" "") + (sprintf "--and-another bool (positional args)%s%s" " (can be repeated)" "") + ] + |> String.concat "\n" + + let arg_2 : bool ResizeArray = ResizeArray () + let mutable arg_0 : int option = None + let mutable arg_1 : string option = None + + /// Processes the key-value pair, returning Error if no key was matched. + /// If the key is an arg which can have arity 1, but throws when consuming that arg, we return Error(). + /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. + let processKeyValue (key : string) (value : string) : Result = + if System.String.Equals (key, "--thing2", System.StringComparison.OrdinalIgnoreCase) then + match arg_1 with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--thing2" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + arg_1 <- value |> (fun x -> x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--thing1", System.StringComparison.OrdinalIgnoreCase) then + match arg_0 with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--thing1" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + arg_0 <- value |> (fun x -> System.Int32.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--and-another", System.StringComparison.OrdinalIgnoreCase) then + value |> (fun x -> System.Boolean.Parse x) |> arg_2.Add + () |> Ok + else + Error None + + /// Returns false if we didn't set a value. + let setFlagValue (key : string) : bool = false + + let rec go (state : ParseState_ParentRecordSelfPos) (args : string list) = + match args with + | [] -> + match state with + | ParseState_ParentRecordSelfPos.AwaitingKey -> () + | ParseState_ParentRecordSelfPos.AwaitingValue key -> + if setFlagValue key then + () + else + sprintf + "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." + key + |> ArgParser_errors.Add + | "--" :: rest -> arg_2.AddRange (rest |> Seq.map (fun x -> System.Boolean.Parse x)) + | arg :: args -> + match state with + | ParseState_ParentRecordSelfPos.AwaitingKey -> + if arg.StartsWith ("--", System.StringComparison.Ordinal) then + if arg = "--help" then + helpText () |> failwithf "Help text requested.\n%s" + else + let equals = arg.IndexOf (char 61) + + if equals < 0 then + args |> go (ParseState_ParentRecordSelfPos.AwaitingValue arg) + else + let key = arg.[0 .. equals - 1] + let value = arg.[equals + 1 ..] + + match processKeyValue key value with + | Ok () -> go ParseState_ParentRecordSelfPos.AwaitingKey args + | Error None -> + failwithf "Unable to process argument %s as key %s and value %s" arg key value + | Error (Some msg) -> + sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add + go ParseState_ParentRecordSelfPos.AwaitingKey args + else + arg |> (fun x -> System.Boolean.Parse x) |> arg_2.Add + go ParseState_ParentRecordSelfPos.AwaitingKey args + | ParseState_ParentRecordSelfPos.AwaitingValue key -> + match processKeyValue key arg with + | Ok () -> go ParseState_ParentRecordSelfPos.AwaitingKey args + | Error exc -> + if setFlagValue key then + go ParseState_ParentRecordSelfPos.AwaitingKey (arg :: args) + else + match exc with + | None -> + failwithf + "Unable to process supplied arg %s. Help text follows.\n%s" + key + (helpText ()) + | Some msg -> msg |> ArgParser_errors.Add + + go ParseState_ParentRecordSelfPos.AwaitingKey args + let arg_2 = arg_2 |> Seq.toList + + let arg_0 = + match arg_0 with + | None -> + sprintf "Required argument '%s' received no value" "--thing1" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let arg_1 = + match arg_1 with + | None -> + sprintf "Required argument '%s' received no value" "--thing2" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + if 0 = ArgParser_errors.Count then + { + AndAnother = arg_2 + Child = + { + Thing1 = arg_0 + Thing2 = arg_1 + } + } + else + ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + static member parse (args : string list) : ParentRecordSelfPos = + ParentRecordSelfPos.parse' System.Environment.GetEnvironmentVariable args diff --git a/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParser.fs b/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParser.fs index 4f35486..5b45bde 100644 --- a/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParser.fs +++ b/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParser.fs @@ -341,3 +341,83 @@ Input string was not in a correct format. (at arg --exact=11:34) Required argument '--exact' received no value""" count.Value |> shouldEqual 0 + + [] + let ``Can consume stacked record without positionals`` () = + let getEnvVar (_ : string) = failwith "should not call" + + let parsed = + ParentRecord.parse' getEnvVar [ "--and-another=true" ; "--thing1=9" ; "--thing2=a thing!" ] + + parsed + |> shouldEqual + { + Child = + { + Thing1 = 9 + Thing2 = "a thing!" + } + AndAnother = true + } + + [] + let ``Can consume stacked record, child has positionals`` () = + let getEnvVar (_ : string) = failwith "should not call" + + let parsed = + ParentRecordChildPos.parse' + getEnvVar + [ "--and-another=true" ; "--thing1=9" ; "--thing2=some" ; "--thing2=thing" ] + + parsed + |> shouldEqual + { + Child = + { + Thing1 = 9 + Thing2 = [ "some" ; "thing" ] + } + AndAnother = true + } + + [] + let ``Can consume stacked record, child has no positionals, parent has positionals`` () = + let getEnvVar (_ : string) = failwith "should not call" + + let parsed = + ParentRecordSelfPos.parse' + getEnvVar + [ + "--and-another=true" + "--and-another=false" + "--and-another=true" + "--thing1=9" + "--thing2=some" + ] + + parsed + |> shouldEqual + { + Child = + { + Thing1 = 9 + Thing2 = "some" + } + AndAnother = [ true ; false ; true ] + } + + [] + let ``Help text for stacked records`` () = + let getEnvVar (_ : string) = failwith "should not call" + + let exc = + Assert.Throws (fun () -> + ParentRecordSelfPos.parse' getEnvVar [ "--help" ] |> ignore + ) + + exc.Message + |> shouldEqual + """Help text requested. +--thing1 int32 +--thing2 string +--and-another bool (positional args) (can be repeated)""" diff --git a/WoofWare.Myriad.Plugins/ArgParserGenerator.fs b/WoofWare.Myriad.Plugins/ArgParserGenerator.fs index 7358589..b823f38 100644 --- a/WoofWare.Myriad.Plugins/ArgParserGenerator.fs +++ b/WoofWare.Myriad.Plugins/ArgParserGenerator.fs @@ -57,6 +57,150 @@ type private ArgToParse = | Positional of ParseFunction | NonPositional of ParseFunction +type private HasPositional = HasPositional +type private HasNoPositional = HasNoPositional + +[] +module private TeqUtils = + let exFalso<'a> (_ : Teq) : 'a = failwith "LOGIC ERROR!" + let exFalso'<'a> (_ : Teq) : 'a = failwith "LOGIC ERROR!" + +[] +type private ParseTree<'hasPositional> = + | NonPositionalLeaf of ParseFunction * Teq<'hasPositional, HasNoPositional> + | PositionalLeaf of ParseFunction * Teq<'hasPositional, HasPositional> + /// `assemble` takes the SynExpr's (e.g. each record field contents) corresponding to each `Ident` in + /// the branch (e.g. each record field name), + /// and composes them into a `SynExpr` (e.g. the record-typed object). + | Branch of + fields : (Ident * ParseTree) list * + assemble : (Map -> SynExpr) * + Teq<'hasPositional, HasNoPositional> + /// `assemble` takes the SynExpr's (e.g. each record field contents) corresponding to each `Ident` in + /// the branch (e.g. each record field name), + /// and composes them into a `SynExpr` (e.g. the record-typed object). + | BranchPos of + posField : Ident * + fields : ParseTree * + (Ident * ParseTree) list * + assemble : (Map -> SynExpr) * + Teq<'hasPositional, HasPositional> + +type private ParseTreeEval<'ret> = + abstract Eval<'a> : ParseTree<'a> -> 'ret + +type private ParseTreeCrate = + abstract Apply<'ret> : ParseTreeEval<'ret> -> 'ret + +[] +module private ParseTreeCrate = + let make<'a> (p : ParseTree<'a>) = + { new ParseTreeCrate with + member _.Apply a = a.Eval p + } + +[] +module private ParseTree = + [] + type State = + | Positional of ParseTree * ParseTree list + | NoPositional of ParseTree list + + let private cast (t : Teq<'a, 'b>) : Teq, ParseTree<'b>> = Teq.Cong.believeMe t + + /// The `Ident` here is the field name. + let branch (assemble : Map -> SynExpr) (subs : (Ident * ParseTreeCrate) list) : ParseTreeCrate = + let rec go + (selfIdent : Ident option) + (acc : (Ident * ParseTree) list, pos : (Ident * ParseTree) option) + (subs : (Ident * ParseTreeCrate) list) + : ParseTreeCrate + = + match subs with + | [] -> + match pos with + | None -> ParseTree.Branch (List.rev acc, assemble, Teq.refl) |> ParseTreeCrate.make + | Some (posField, pos) -> + ParseTree.BranchPos (posField, pos, List.rev acc, assemble, Teq.refl) + |> ParseTreeCrate.make + | (fieldName, sub) :: subs -> + { new ParseTreeEval<_> with + member _.Eval (t : ParseTree<'a>) = + match t with + | ParseTree.NonPositionalLeaf (_, teq) + | ParseTree.Branch (_, _, teq) -> + go selfIdent (((fieldName, Teq.cast (cast teq) t) :: acc), pos) subs + | ParseTree.PositionalLeaf (_, teq) + | ParseTree.BranchPos (_, _, _, _, teq) -> + match pos with + | None -> go selfIdent (acc, Some (fieldName, Teq.cast (cast teq) t)) subs + | Some (ident, _) -> + failwith + $"Multiple entries tried to claim positional args! %s{ident.idText} and %s{fieldName.idText}" + } + |> sub.Apply + + go None ([], None) subs + + let rec accumulatorsNonPos (tree : ParseTree) : ParseFunction list = + match tree with + | ParseTree.PositionalLeaf (_, teq) -> exFalso teq + | ParseTree.BranchPos (_, _, _, _, teq) -> exFalso teq + | ParseTree.NonPositionalLeaf (pf, _) -> [ pf ] + | ParseTree.Branch (trees, _, _) -> trees |> List.collect (snd >> accumulatorsNonPos) + + /// Returns the positional arg separately. + let rec accumulatorsPos (tree : ParseTree) : ParseFunction list * ParseFunction = + match tree with + | ParseTree.PositionalLeaf (pf, _) -> [], pf + | ParseTree.NonPositionalLeaf (_, teq) -> exFalso' teq + | ParseTree.Branch (_, _, teq) -> exFalso' teq + | ParseTree.BranchPos (_, tree, trees, _, _) -> + let nonPos = trees |> List.collect (snd >> accumulatorsNonPos) + + let nonPos2, pos = accumulatorsPos tree + nonPos @ nonPos2, pos + + /// Collect all the ParseFunctions which are necessary to define variables, throwing away + /// all information relevant to composing the resulting variables into records. + /// Returns the list of non-positional parsers, and any positional parser that exists. + let accumulators<'a> (tree : ParseTree<'a>) : ParseFunction list * ParseFunction option = + // Sad duplication of some code here, but it was the easiest way to make it type-safe :( + match tree with + | ParseTree.PositionalLeaf (pf, _) -> [], Some pf + | ParseTree.NonPositionalLeaf (pf, _) -> [ pf ], None + | ParseTree.Branch (trees, _, _) -> trees |> List.collect (snd >> accumulatorsNonPos) |> (fun i -> i, None) + | ParseTree.BranchPos (_, tree, trees, _, _) -> + let nonPos = trees |> List.collect (snd >> accumulatorsNonPos) + + let nonPos2, pos = accumulatorsPos tree + nonPos @ nonPos2, Some pos + + /// Build the return value. + let rec instantiate<'a> (tree : ParseTree<'a>) : SynExpr = + match tree with + | ParseTree.NonPositionalLeaf (pf, _) -> SynExpr.createIdent' pf.TargetVariable + | ParseTree.PositionalLeaf (pf, _) -> SynExpr.createIdent' pf.TargetVariable + | ParseTree.Branch (trees, assemble, _) -> + trees + |> List.map (fun (fieldName, contents) -> + let instantiated = instantiate contents + fieldName.idText, instantiated + ) + |> Map.ofList + |> assemble + | ParseTree.BranchPos (posField, tree, trees, assemble, _) -> + let withPos = instantiate tree + + trees + |> List.map (fun (fieldName, contents) -> + let instantiated = instantiate contents + fieldName.idText, instantiated + ) + |> Map.ofList + |> Map.add posField.idText withPos + |> assemble + [] module internal ArgParserGenerator = @@ -254,16 +398,21 @@ module internal ArgParserGenerator = | Accumulation.Required -> parseElt, Accumulation.List, childTy | _ -> failwith $"Could not decide how to parse arguments for field %s{fieldName.idText} of type %O{ty}" - let private toParseSpec (finalRecord : RecordType) : ParserSpec = + let rec private toParseSpec + (counter : int) + (ambientRecords : RecordType list) + (finalRecord : RecordType) + : ParseTreeCrate * int + = finalRecord.Fields |> List.iter (fun (SynField.SynField (isStatic = isStatic)) -> if isStatic then failwith "No static record fields allowed in ArgParserGenerator" ) - let args : ArgToParse list = - finalRecord.Fields - |> List.map (fun (SynField.SynField (attrs, _, identOption, fieldType, _, _, _, _, _)) -> + let counter, contents = + ((counter, []), finalRecord.Fields) + ||> List.fold (fun (counter, acc) (SynField.SynField (attrs, _, identOption, fieldType, _, _, _, _, _)) -> let attrs = attrs |> List.collect (fun a -> a.Attributes) let positionalArgAttr = @@ -313,6 +462,20 @@ module internal ArgParserGenerator = | None -> failwith "expected args field to have a name, but it did not" | Some i -> i + let ambientRecordMatch = + match fieldType with + | SynType.LongIdent (SynLongIdent.SynLongIdent (id, _, _)) -> + let target = List.last(id).idText + ambientRecords |> List.tryFind (fun r -> r.Name.idText = target) + | _ -> None + + match ambientRecordMatch with + | Some ambient -> + // This field has a type we need to obtain from parsing another record. + let spec, counter = toParseSpec counter ambientRecords ambient + counter, (ident, spec) :: acc + | None -> + let parser, accumulation, parseTy = createParseFunction ident attrs fieldType match positionalArgAttr with @@ -322,47 +485,41 @@ module internal ArgParserGenerator = { FieldName = ident Parser = parser - TargetVariable = ident + TargetVariable = Ident.create $"arg_%i{counter}" Accumulation = accumulation TargetType = parseTy ArgForm = argify ident Help = helpText } - |> ArgToParse.Positional + |> fun t -> ParseTree.PositionalLeaf (t, Teq.refl) + |> ParseTreeCrate.make | _ -> failwith $"Expected positional arg accumulation type to be List, but it was %O{fieldType}" | None -> { FieldName = ident Parser = parser - TargetVariable = ident + TargetVariable = Ident.create $"arg_%i{counter}" Accumulation = accumulation TargetType = parseTy ArgForm = argify ident Help = helpText } - |> ArgToParse.NonPositional + |> fun t -> ParseTree.NonPositionalLeaf (t, Teq.refl) + |> ParseTreeCrate.make + |> fun tree -> counter + 1, (ident, tree) :: acc ) - let positional, nonPositionals = - let mutable p = None - let n = ResizeArray () - - for arg in args do - match arg with - | ArgToParse.Positional arg -> - match p with - | None -> p <- Some arg - | Some existing -> - failwith - $"Multiple args were tagged with `Positional`: %s{existing.TargetVariable.idText}, %s{arg.TargetVariable.idText}" - | ArgToParse.NonPositional arg -> n.Add arg - - p, List.ofSeq n + let tree = + contents + |> List.rev + |> ParseTree.branch (fun args -> + args + |> Map.toList + |> List.map (fun (ident, expr) -> SynLongIdent.create [ Ident.create ident ], expr) + |> AstHelper.instantiateRecord + ) - { - NonPositionals = nonPositionals - Positionals = positional - } + tree, counter /// let helpText : string = ... let private helpText @@ -478,10 +635,10 @@ module internal ArgParserGenerator = | Accumulation.List -> [ SynExpr.createIdent "value" + |> SynExpr.pipeThroughFunction arg.Parser |> SynExpr.pipeThroughFunction ( SynExpr.createLongIdent' [ arg.TargetVariable ; Ident.create "Add" ] ) - |> SynExpr.applyFunction arg.Parser SynExpr.CreateConst () |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Ok") ] |> SynExpr.sequential @@ -508,14 +665,14 @@ module internal ArgParserGenerator = |> SynBinding.withXmlDoc ( [ " Processes the key-value pair, returning Error if no key was matched." - " If the key is an arg which can arity 1, but throws when consuming that arg, we return Error()." + " If the key is an arg which can have arity 1, but throws when consuming that arg, we return Error()." " This can nevertheless be a successful parse, e.g. when the key may have arity 0." ] |> PreXmlDoc.create' ) /// `let setFlagValue (key : string) : bool = ...` - let private setFlagValue (parseState : Ident) (argParseErrors : Ident) (flags : ParseFunction list) : SynBinding = + let private setFlagValue (argParseErrors : Ident) (flags : ParseFunction list) : SynBinding = (SynExpr.CreateConst false, flags) ||> List.fold (fun finalExpr flag -> let multipleErrorMessage = @@ -568,7 +725,7 @@ module internal ArgParserGenerator = (leftoverArgParser : SynExpr) : SynBinding = - /// `go (AwaitingValue arg) args + /// `go (AwaitingValue arg) args` let recurseValue = SynExpr.createIdent "go" |> SynExpr.applyTo ( @@ -608,9 +765,9 @@ module internal ArgParserGenerator = argStartsWithDashes (SynExpr.sequential [ - (SynExpr.createIdent "arg" - |> SynExpr.pipeThroughFunction leftoverArgParser - |> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' [ leftoverArgs ; Ident.create "Add" ])) + SynExpr.createIdent "arg" + |> SynExpr.pipeThroughFunction leftoverArgParser + |> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' [ leftoverArgs ; Ident.create "Add" ]) recurseKey ]) @@ -786,18 +943,24 @@ module internal ArgParserGenerator = SynPat.named "state" |> SynPat.annotateType (SynType.createLongIdent [ parseState ]) SynPat.named "args" - |> SynPat.annotateType (SynType.appPostfix "list" (SynType.string)) + |> SynPat.annotateType (SynType.appPostfix "list" SynType.string) ] SynBinding.basic [ Ident.create "go" ] args body |> SynBinding.withRecursion true /// Takes a single argument, `args : string list`, and returns something of the type indicated by `recordType`. - let createRecordParse (parseState : Ident) (recordType : RecordType) : SynExpr = - let spec = toParseSpec recordType + let createRecordParse (parseState : Ident) (ambientRecords : RecordType list) (recordType : RecordType) : SynExpr = + let spec, _ = toParseSpec 0 ambientRecords recordType // For each argument (positional and non-positional), create an accumulator for it. + let nonPos, pos = + { new ParseTreeEval<_> with + member _.Eval tree = ParseTree.accumulators tree + } + |> spec.Apply + let bindings = - spec.NonPositionals + nonPos |> List.map (fun pf -> match pf.Accumulation with | Accumulation.Required @@ -816,7 +979,7 @@ module internal ArgParserGenerator = let bindings, leftoverArgsName, leftoverArgsParser = let bindingName, leftoverArgsParser, leftoverArgsType = - match spec.Positionals with + match pos with | None -> Ident.create "parser_LeftoverArgs", (SynExpr.createLambda "x" (SynExpr.createIdent "x")), @@ -839,7 +1002,7 @@ module internal ArgParserGenerator = |> SynExpr.applyTo (SynExpr.CreateConst ()) |> SynBinding.basic [ argParseErrors ] [] - let helpText = helpText recordType.Name spec.Positionals spec.NonPositionals + let helpText = helpText recordType.Name pos nonPos let bindings = errorCollection :: helpText :: bindings @@ -849,7 +1012,7 @@ module internal ArgParserGenerator = // Determine whether any required arg is missing, and freeze args into immutable form. let freezeNonPositionalArgs = - spec.NonPositionals + nonPos |> List.map (fun pf -> match pf.Accumulation with | Accumulation.Choice spec -> @@ -912,7 +1075,7 @@ module internal ArgParserGenerator = let errorMessage = SynExpr.createIdent "sprintf" |> SynExpr.applyTo (SynExpr.CreateConst "Required argument '%s' received no value") - |> SynExpr.applyTo (SynExpr.CreateConst (argify pf.TargetVariable)) + |> SynExpr.applyTo (SynExpr.CreateConst pf.ArgForm) [ SynMatchClause.create @@ -935,7 +1098,7 @@ module internal ArgParserGenerator = ) let freezePositional = - match spec.Positionals with + match pos with | None -> // Check if there are leftover args. If there are, throw. let errorMessage = @@ -969,20 +1132,12 @@ module internal ArgParserGenerator = let freezeArgs = freezePositional @ freezeNonPositionalArgs - let retPositional = - match spec.Positionals with - | None -> [] - | Some pf -> - [ - SynLongIdent.createI pf.TargetVariable, SynExpr.createIdent' pf.TargetVariable - ] - let retValue = let happyPath = - spec.NonPositionals - |> List.map (fun pf -> SynLongIdent.createI pf.TargetVariable, SynExpr.createIdent' pf.TargetVariable) - |> fun np -> retPositional @ np - |> AstHelper.instantiateRecord + { new ParseTreeEval<_> with + member _.Eval tree = ParseTree.instantiate tree + } + |> spec.Apply let sadPath = SynExpr.createIdent' argParseErrors @@ -1001,7 +1156,7 @@ module internal ArgParserGenerator = SynExpr.ifThenElse areErrors sadPath happyPath let flags = - spec.NonPositionals + nonPos |> List.filter (fun pf -> match pf.TargetType with | PrimitiveType pt -> (pt |> List.map _.idText) = [ "System" ; "Boolean" ] @@ -1019,8 +1174,8 @@ module internal ArgParserGenerator = |> SynExpr.createLet ( bindings @ [ - processKeyValue argParseErrors (Option.toList spec.Positionals @ spec.NonPositionals) - setFlagValue parseState argParseErrors flags + processKeyValue argParseErrors (Option.toList pos @ nonPos) + setFlagValue argParseErrors flags mainLoop parseState argParseErrors leftoverArgsName leftoverArgsParser ] ) @@ -1029,10 +1184,13 @@ module internal ArgParserGenerator = (opens : SynOpenDeclTarget list) (ns : LongIdent) ((taggedType : SynTypeDefn, spec : ArgParserOutputSpec)) - (_allUnionTypesTODO : SynTypeDefn list) + (allUnionTypes : SynTypeDefn list) (allRecordTypes : SynTypeDefn list) : SynModuleOrNamespace = + // The type for which we're generating args may refer to any of these records/unions. + let allRecordTypes = allRecordTypes |> List.map RecordType.OfRecord + let taggedType = RecordType.OfRecord taggedType let modAttrs, modName = @@ -1086,7 +1244,7 @@ module internal ArgParserGenerator = |> SynPat.annotateType (SynType.appPostfix "list" SynType.string) let parsePrime = - createRecordParse parseStateIdent taggedType + createRecordParse parseStateIdent allRecordTypes taggedType |> SynBinding.basic [ Ident.create "parse'" ] [ @@ -1146,16 +1304,19 @@ module internal ArgParserGenerator = let ast, _ = Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head - let types = Ast.extractTypeDefn ast + let types = + Ast.extractTypeDefn ast + |> List.groupBy (fst >> List.map _.idText >> String.concat ".") + |> List.map (fun (_, v) -> fst (List.head v), List.collect snd v) let opens = AstHelper.extractOpens ast let namespaceAndTypes = types - |> List.choose (fun (ns, types) -> + |> List.collect (fun (ns, types) -> let typeWithAttr = types - |> List.tryPick (fun ty -> + |> List.choose (fun ty -> match Ast.getAttribute ty with | None -> None | Some attr -> @@ -1175,8 +1336,8 @@ module internal ArgParserGenerator = Some (ty, spec) ) - match typeWithAttr with - | Some taggedType -> + typeWithAttr + |> List.map (fun taggedType -> let unions, records, others = (([], [], []), types) ||> List.fold (fun @@ -1194,8 +1355,8 @@ module internal ArgParserGenerator = failwith $"Error: all types recursively defined together with an ArgParserGenerator type must be discriminated unions or records. %+A{others}" - Some (ns, taggedType, unions, records) - | _ -> None + (ns, taggedType, unions, records) + ) ) let modules = diff --git a/WoofWare.Myriad.Plugins/Teq.fs b/WoofWare.Myriad.Plugins/Teq.fs new file mode 100644 index 0000000..860e345 --- /dev/null +++ b/WoofWare.Myriad.Plugins/Teq.fs @@ -0,0 +1,18 @@ +namespace WoofWare.Myriad.Plugins + +// Extracted from https://github.com/G-Research/TypeEquality +// which is Apache-2.0 licenced. See `TeqLicence.txt`. +// We inline this code because Myriad doesn't seem to reliably load package references in the generator. +// I have reformatted a little, and stripped out all the code I don't use. + +type internal Teq<'a, 'b> = private | Teq of ('a -> 'b) * ('b -> 'a) + +[] +module internal Teq = + + let refl<'a> : Teq<'a, 'a> = Teq (id, id) + let cast (Teq (f, _)) a = f a + + [] + module Cong = + let believeMe<'a, 'b, 'a2, 'b2> (_ : Teq<'a, 'b>) : Teq<'a2, 'b2> = unbox <| (refl : Teq<'a2, 'a2>) diff --git a/WoofWare.Myriad.Plugins/TeqLicence.txt b/WoofWare.Myriad.Plugins/TeqLicence.txt new file mode 100644 index 0000000..b09cd78 --- /dev/null +++ b/WoofWare.Myriad.Plugins/TeqLicence.txt @@ -0,0 +1,201 @@ +Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj index 43bfedb..3a9c464 100644 --- a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj +++ b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj @@ -25,6 +25,7 @@ + @@ -56,6 +57,7 @@ +