Compare commits

...

29 Commits

Author SHA1 Message Date
Smaug123
f686109331 More 2025-04-18 15:08:20 +01:00
Smaug123
7b2c3d2168 Start on the union generator 2025-04-17 21:56:25 +01:00
Smaug123
3ed8d4db00 Add help text placeholder 2025-04-17 21:38:44 +01:00
Smaug123
75ce8c1f64 Fix test 2025-04-17 18:45:57 +01:00
Smaug123
01714aeba0 Fix all but the help text 2025-04-17 18:31:25 +01:00
Smaug123
2f266b052d Fix another test 2025-04-17 16:02:20 +01:00
Smaug123
d3d50cae7c Fix another test 2025-04-17 15:49:12 +01:00
Smaug123
573d410416 Fix another test 2025-04-17 12:47:48 +01:00
Smaug123
a82ece0f6c Plumb through indices 2025-04-17 12:41:55 +01:00
Smaug123
51991cab74 Fix another test 2025-04-17 11:45:34 +01:00
Smaug123
55a3876610 More 2025-04-17 11:13:37 +01:00
Smaug123
c14f89f807 Fix another test 2025-04-17 11:05:08 +01:00
Smaug123
54e3f17d9c It's sort of working 2025-04-17 00:18:53 +01:00
Smaug123
4013271254 More 2025-04-16 23:04:23 +01:00
Smaug123
aa2ef830c3 Add flags 2025-04-16 21:26:30 +01:00
Smaug123
4e62a154c0 Undo accidental revert 2025-04-15 22:51:43 +01:00
Smaug123
751e43eec4 More 2025-04-15 22:50:14 +01:00
Smaug123
fccc981045 WIP 2025-04-15 09:23:24 +01:00
Smaug123
f8a1505b99 Undo build-offline mode 2025-04-14 23:08:40 +01:00
Smaug123
eb25b9ccb8 Merge branch 'main' into du-parser 2025-04-14 23:07:34 +01:00
Smaug123
34587b8dea Merge branch 'main' into du-parser 2025-04-14 23:02:19 +01:00
Smaug123
963a097360 First line of implementation 2025-04-14 22:52:18 +01:00
Smaug123
67eb89cfc0 Getting there 2025-04-14 22:27:57 +01:00
Smaug123
0c5ddf9df7 WIP 2025-04-14 00:01:55 +01:00
Smaug123
8535481e0d Bump Whippet 2025-04-13 21:09:12 +01:00
Smaug123
df6079e763 WIP 2025-04-13 20:34:52 +01:00
Smaug123
4befdb93e5 WIP: define the helper types 2025-04-13 18:43:23 +01:00
Smaug123
17da7317e8 Merge branch 'main' into du-parser 2025-04-13 16:07:59 +01:00
Smaug123
fa022b75ea WIP: complete arg parser 2025-04-13 11:52:17 +01:00
17 changed files with 9239 additions and 3338 deletions

View File

@@ -235,3 +235,9 @@ type FlagsIntoPositionalArgs' =
[<PositionalArgs false>] [<PositionalArgs false>]
DontGrabEverything : string list DontGrabEverything : string list
} }
[<ArgParser true>]
type PassThru =
{
A : ParentRecordChildPos
}

View File

@@ -0,0 +1,35 @@
namespace ConsumePlugin.ArgsWithUnions
open System
open System.IO
open WoofWare.Myriad.Plugins
type BasicNoPositionals =
{
Foo : int
Bar : string
Baz : bool
Rest : int list
}
type UsernamePasswordAuth =
{
Username : string
Password : string
}
type TokenAuth =
{
Token : string
}
type AuthOptions =
| UsernamePassword of UsernamePasswordAuth
| Token of TokenAuth
[<ArgParser>]
type DoTheThing =
{
Basics : BasicNoPositionals
Auth : AuthOptions
}

View File

@@ -12,6 +12,7 @@
<ItemGroup> <ItemGroup>
<None Include="myriad.toml"/> <None Include="myriad.toml"/>
<Compile Include="AssemblyInfo.fs" /> <Compile Include="AssemblyInfo.fs" />
<!--
<Compile Include="RecordFile.fs"/> <Compile Include="RecordFile.fs"/>
<Compile Include="GeneratedRecord.fs"> <Compile Include="GeneratedRecord.fs">
<MyriadFile>RecordFile.fs</MyriadFile> <MyriadFile>RecordFile.fs</MyriadFile>
@@ -66,10 +67,16 @@
<Compile Include="ListCata.fs"> <Compile Include="ListCata.fs">
<MyriadFile>List.fs</MyriadFile> <MyriadFile>List.fs</MyriadFile>
</Compile> </Compile>
-->
<Compile Include="Args.fs" /> <Compile Include="Args.fs" />
<Compile Include="GeneratedArgs.fs"> <Compile Include="GeneratedArgs.fs">
<MyriadFile>Args.fs</MyriadFile> <MyriadFile>Args.fs</MyriadFile>
</Compile> </Compile>
<Compile Include="ArgsWithUnions.fs" />
<Compile Include="GeneratedArgsWithUnions.fs">
<MyriadFile>ArgsWithUnions.fs</MyriadFile>
</Compile>
<!--
<None Include="swagger-gitea.json" /> <None Include="swagger-gitea.json" />
<Compile Include="GeneratedSwaggerGitea.fs"> <Compile Include="GeneratedSwaggerGitea.fs">
<MyriadFile>swagger-gitea.json</MyriadFile> <MyriadFile>swagger-gitea.json</MyriadFile>
@@ -81,6 +88,7 @@
<Compile Include="Generated2SwaggerGitea.fs"> <Compile Include="Generated2SwaggerGitea.fs">
<MyriadFile>GeneratedSwaggerGitea.fs</MyriadFile> <MyriadFile>GeneratedSwaggerGitea.fs</MyriadFile>
</Compile> </Compile>
-->
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,686 @@
//------------------------------------------------------------------------------
// This code was generated by myriad.
// Changes to this file will be lost when the code is regenerated.
//------------------------------------------------------------------------------
namespace ArgParserHelpers
/// Helper types for arg parsing
module internal ArgParseHelpers_ConsumePlugin_ArgsWithUnions =
open System
open System.IO
open WoofWare.Myriad.Plugins
open ConsumePlugin.ArgsWithUnions
/// A partially-parsed BasicNoPositionals.
type internal BasicNoPositionals_InProgress =
{
mutable Bar : string option
mutable Baz : bool option
mutable Foo : int option
mutable Rest : ResizeArray<int>
}
/// Freeze this in-progress type. On success, returns the frozen type and the arg (if any) which consumed the input positional args.
member this.Assemble_
(getEnvironmentVariable : string -> string)
(positionals : Choice<string * int, string * int> list)
: Result<BasicNoPositionals * string option, string list>
=
let errors = ResizeArray<string> ()
let positionalConsumers = ResizeArray<string> ()
let outOfPlacePositionals : ResizeArray<string> = ResizeArray ()
let arg0 : int =
match this.Foo with
| Some result -> result
| None ->
errors.Add (sprintf "Required argument '--%s' received no value" "foo")
Unchecked.defaultof<_>
let arg1 : string =
match this.Bar with
| Some result -> result
| None ->
errors.Add (sprintf "Required argument '--%s' received no value" "bar")
Unchecked.defaultof<_>
let arg2 : bool =
match this.Baz with
| Some result -> result
| None ->
errors.Add (sprintf "Required argument '--%s' received no value" "baz")
Unchecked.defaultof<_>
let arg3 : int list = this.Rest |> Seq.toList
if positionalConsumers.Count <= 1 then
if outOfPlacePositionals.Count > 0 then
outOfPlacePositionals
|> String.concat " "
|> (fun x ->
if 0 = outOfPlacePositionals.Count then
"Unmatched args which look like they are meant to be flags. " + x
else
sprintf
"Unmatched args which look like they are meant to be flags. If you intended them as positional args, explicitly pass them with the `%s=` syntax, or place them after a trailing `--`. %s"
positionalConsumers.[0]
x
)
|> errors.Add
else
()
if errors.Count = 0 then
Ok (
{
Foo = arg0
Bar = arg1
Baz = arg2
Rest = arg3
},
Seq.tryExactlyOne positionalConsumers
)
else
errors |> Seq.toList |> Error
else
("Multiple parsers consumed positional args; this is an error in the application, not an error by the user: "
+ String.concat ", " positionalConsumers)
|> List.singleton
|> Error
static member _Empty () : BasicNoPositionals_InProgress =
{
Bar = None
Baz = None
Foo = None
Rest = ResizeArray ()
}
/// 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(<the message>).
/// This can nevertheless be a successful parse, e.g. when the key may have arity 0.
member this.ProcessKeyValueSelf_
(argNum_ : int)
(errors_ : ResizeArray<string>)
(key : string)
(value : string)
: Result<unit, string option>
=
if System.String.Equals (key, sprintf "--%s" "rest", System.StringComparison.OrdinalIgnoreCase) then
value |> (fun x -> System.Int32.Parse x) |> (fun x -> x) |> this.Rest.Add
() |> Ok
else if System.String.Equals (key, sprintf "--%s" "foo", System.StringComparison.OrdinalIgnoreCase) then
match this.Foo with
| Some x ->
sprintf
"Argument '%s' was supplied multiple times: %s and %s"
(sprintf "--%s" "foo")
(x.ToString ())
(value.ToString ())
|> errors_.Add
Ok ()
| None ->
try
this.Foo <- value |> (fun x -> System.Int32.Parse x) |> Some
Ok ()
with _ as exc ->
exc.Message |> Some |> Error
else if System.String.Equals (key, sprintf "--%s" "baz", System.StringComparison.OrdinalIgnoreCase) then
match this.Baz with
| Some x ->
sprintf
"Argument '%s' was supplied multiple times: %s and %s"
(sprintf "--%s" "baz")
(x.ToString ())
(value.ToString ())
|> errors_.Add
Ok ()
| None ->
try
this.Baz <- value |> (fun x -> System.Boolean.Parse x) |> Some
Ok ()
with _ as exc ->
exc.Message |> Some |> Error
else if System.String.Equals (key, sprintf "--%s" "bar", System.StringComparison.OrdinalIgnoreCase) then
match this.Bar with
| Some x ->
sprintf
"Argument '%s' was supplied multiple times: %s and %s"
(sprintf "--%s" "bar")
(x.ToString ())
(value.ToString ())
|> errors_.Add
Ok ()
| None ->
try
this.Bar <- value |> (fun x -> x) |> Some
Ok ()
with _ as exc ->
exc.Message |> Some |> Error
else
Error None
member this.ProcessKeyValue
(argNum_ : int)
(errors_ : ResizeArray<string>)
(key : string)
(value : string)
: Result<unit, string option>
=
match this.ProcessKeyValueSelf_ argNum_ errors_ key value with
| Ok () -> Ok ()
| Error None -> Error None
| Error (Some errorFromLeaf) -> Error (Some errorFromLeaf)
/// Returns false if we didn't set a value.
member this.SetFlagValue_ (errors_ : ResizeArray<string>) (key : string) : bool =
if System.String.Equals (key, sprintf "--%s" "baz", System.StringComparison.OrdinalIgnoreCase) then
match this.Baz with
| Some _ ->
sprintf "Flag '%s' was supplied multiple times" (sprintf "--%s" "baz")
|> errors_.Add
true
| None ->
this.Baz <- true |> Some
true
else
false
/// Compute help text for this parser, optionally noting the given prefix on each argument and indenting each line by this many spaces.
static member HelpText_ (prefix : string option) (indent : int) : string = failwith "TODO"
/// A partially-parsed UsernamePasswordAuth.
type internal UsernamePasswordAuth_InProgress =
{
mutable Password : string option
mutable Username : string option
}
/// Freeze this in-progress type. On success, returns the frozen type and the arg (if any) which consumed the input positional args.
member this.Assemble_
(getEnvironmentVariable : string -> string)
(positionals : Choice<string * int, string * int> list)
: Result<UsernamePasswordAuth * string option, string list>
=
let errors = ResizeArray<string> ()
let positionalConsumers = ResizeArray<string> ()
let outOfPlacePositionals : ResizeArray<string> = ResizeArray ()
let arg0 : string =
match this.Username with
| Some result -> result
| None ->
errors.Add (sprintf "Required argument '--%s' received no value" "username")
Unchecked.defaultof<_>
let arg1 : string =
match this.Password with
| Some result -> result
| None ->
errors.Add (sprintf "Required argument '--%s' received no value" "password")
Unchecked.defaultof<_>
if positionalConsumers.Count <= 1 then
if outOfPlacePositionals.Count > 0 then
outOfPlacePositionals
|> String.concat " "
|> (fun x ->
if 0 = outOfPlacePositionals.Count then
"Unmatched args which look like they are meant to be flags. " + x
else
sprintf
"Unmatched args which look like they are meant to be flags. If you intended them as positional args, explicitly pass them with the `%s=` syntax, or place them after a trailing `--`. %s"
positionalConsumers.[0]
x
)
|> errors.Add
else
()
if errors.Count = 0 then
Ok (
{
Username = arg0
Password = arg1
},
Seq.tryExactlyOne positionalConsumers
)
else
errors |> Seq.toList |> Error
else
("Multiple parsers consumed positional args; this is an error in the application, not an error by the user: "
+ String.concat ", " positionalConsumers)
|> List.singleton
|> Error
static member _Empty () : UsernamePasswordAuth_InProgress =
{
Password = None
Username = 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(<the message>).
/// This can nevertheless be a successful parse, e.g. when the key may have arity 0.
member this.ProcessKeyValueSelf_
(argNum_ : int)
(errors_ : ResizeArray<string>)
(key : string)
(value : string)
: Result<unit, string option>
=
if System.String.Equals (key, sprintf "--%s" "username", System.StringComparison.OrdinalIgnoreCase) then
match this.Username with
| Some x ->
sprintf
"Argument '%s' was supplied multiple times: %s and %s"
(sprintf "--%s" "username")
(x.ToString ())
(value.ToString ())
|> errors_.Add
Ok ()
| None ->
try
this.Username <- value |> (fun x -> x) |> Some
Ok ()
with _ as exc ->
exc.Message |> Some |> Error
else if
System.String.Equals (key, sprintf "--%s" "password", System.StringComparison.OrdinalIgnoreCase)
then
match this.Password with
| Some x ->
sprintf
"Argument '%s' was supplied multiple times: %s and %s"
(sprintf "--%s" "password")
(x.ToString ())
(value.ToString ())
|> errors_.Add
Ok ()
| None ->
try
this.Password <- value |> (fun x -> x) |> Some
Ok ()
with _ as exc ->
exc.Message |> Some |> Error
else
Error None
member this.ProcessKeyValue
(argNum_ : int)
(errors_ : ResizeArray<string>)
(key : string)
(value : string)
: Result<unit, string option>
=
match this.ProcessKeyValueSelf_ argNum_ errors_ key value with
| Ok () -> Ok ()
| Error None -> Error None
| Error (Some errorFromLeaf) -> Error (Some errorFromLeaf)
/// Returns false if we didn't set a value.
member this.SetFlagValue_ (errors_ : ResizeArray<string>) (key : string) : bool = false
/// Compute help text for this parser, optionally noting the given prefix on each argument and indenting each line by this many spaces.
static member HelpText_ (prefix : string option) (indent : int) : string = failwith "TODO"
/// A partially-parsed TokenAuth.
type internal TokenAuth_InProgress =
{
mutable Token : string option
}
/// Freeze this in-progress type. On success, returns the frozen type and the arg (if any) which consumed the input positional args.
member this.Assemble_
(getEnvironmentVariable : string -> string)
(positionals : Choice<string * int, string * int> list)
: Result<TokenAuth * string option, string list>
=
let errors = ResizeArray<string> ()
let positionalConsumers = ResizeArray<string> ()
let outOfPlacePositionals : ResizeArray<string> = ResizeArray ()
let arg0 : string =
match this.Token with
| Some result -> result
| None ->
errors.Add (sprintf "Required argument '--%s' received no value" "token")
Unchecked.defaultof<_>
if positionalConsumers.Count <= 1 then
if outOfPlacePositionals.Count > 0 then
outOfPlacePositionals
|> String.concat " "
|> (fun x ->
if 0 = outOfPlacePositionals.Count then
"Unmatched args which look like they are meant to be flags. " + x
else
sprintf
"Unmatched args which look like they are meant to be flags. If you intended them as positional args, explicitly pass them with the `%s=` syntax, or place them after a trailing `--`. %s"
positionalConsumers.[0]
x
)
|> errors.Add
else
()
if errors.Count = 0 then
Ok (
{
Token = arg0
},
Seq.tryExactlyOne positionalConsumers
)
else
errors |> Seq.toList |> Error
else
("Multiple parsers consumed positional args; this is an error in the application, not an error by the user: "
+ String.concat ", " positionalConsumers)
|> List.singleton
|> Error
static member _Empty () : TokenAuth_InProgress =
{
Token = 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(<the message>).
/// This can nevertheless be a successful parse, e.g. when the key may have arity 0.
member this.ProcessKeyValueSelf_
(argNum_ : int)
(errors_ : ResizeArray<string>)
(key : string)
(value : string)
: Result<unit, string option>
=
if System.String.Equals (key, sprintf "--%s" "token", System.StringComparison.OrdinalIgnoreCase) then
match this.Token with
| Some x ->
sprintf
"Argument '%s' was supplied multiple times: %s and %s"
(sprintf "--%s" "token")
(x.ToString ())
(value.ToString ())
|> errors_.Add
Ok ()
| None ->
try
this.Token <- value |> (fun x -> x) |> Some
Ok ()
with _ as exc ->
exc.Message |> Some |> Error
else
Error None
member this.ProcessKeyValue
(argNum_ : int)
(errors_ : ResizeArray<string>)
(key : string)
(value : string)
: Result<unit, string option>
=
match this.ProcessKeyValueSelf_ argNum_ errors_ key value with
| Ok () -> Ok ()
| Error None -> Error None
| Error (Some errorFromLeaf) -> Error (Some errorFromLeaf)
/// Returns false if we didn't set a value.
member this.SetFlagValue_ (errors_ : ResizeArray<string>) (key : string) : bool = false
/// Compute help text for this parser, optionally noting the given prefix on each argument and indenting each line by this many spaces.
static member HelpText_ (prefix : string option) (indent : int) : string = failwith "TODO"
/// A partially-parsed AuthOptions.
type internal AuthOptions_InProgress =
{
Token : TokenAuth_InProgress
UsernamePassword : UsernamePasswordAuth_InProgress
}
/// Freeze this in-progress type. On success, returns the frozen type and the arg (if any) which consumed the input positional args.
member this.Assemble_
(getEnvironmentVariable : string -> string)
(positionals : Choice<string * int, string * int> list)
: Result<AuthOptions * string option, string list>
=
failwith "TODO"
static member _Empty () : AuthOptions_InProgress =
{
Token = TokenAuth_InProgress._Empty ()
UsernamePassword = UsernamePasswordAuth_InProgress._Empty ()
}
/// Compute help text for this parser, optionally noting the given prefix on each argument and indenting each line by this many spaces.
static member HelpText_ (prefix : string option) (indent : int) : string = failwith "TODO"
/// A partially-parsed DoTheThing.
type internal DoTheThing_InProgress =
{
mutable Auth : AuthOptions_InProgress
mutable Basics : BasicNoPositionals_InProgress
}
/// Freeze this in-progress type. On success, returns the frozen type and the arg (if any) which consumed the input positional args.
member this.Assemble_
(getEnvironmentVariable : string -> string)
(positionals : Choice<string * int, string * int> list)
: Result<DoTheThing * string option, string list>
=
let errors = ResizeArray<string> ()
let positionalConsumers = ResizeArray<string> ()
let outOfPlacePositionals : ResizeArray<string> = ResizeArray ()
let arg0 : BasicNoPositionals =
match this.Basics.Assemble_ getEnvironmentVariable positionals with
| Ok (result, consumedPositional) ->
match consumedPositional with
| None -> ()
| Some positionalConsumer -> positionalConsumers.Add positionalConsumer
result
| Error err ->
errors.AddRange err
Unchecked.defaultof<_>
let arg1 : AuthOptions =
match this.Auth.Assemble_ getEnvironmentVariable positionals with
| Ok (result, consumedPositional) ->
match consumedPositional with
| None -> ()
| Some positionalConsumer -> positionalConsumers.Add positionalConsumer
result
| Error err ->
errors.AddRange err
Unchecked.defaultof<_>
if positionalConsumers.Count <= 1 then
if outOfPlacePositionals.Count > 0 then
outOfPlacePositionals
|> String.concat " "
|> (fun x ->
if 0 = outOfPlacePositionals.Count then
"Unmatched args which look like they are meant to be flags. " + x
else
sprintf
"Unmatched args which look like they are meant to be flags. If you intended them as positional args, explicitly pass them with the `%s=` syntax, or place them after a trailing `--`. %s"
positionalConsumers.[0]
x
)
|> errors.Add
else
()
if errors.Count = 0 then
Ok (
{
Basics = arg0
Auth = arg1
},
Seq.tryExactlyOne positionalConsumers
)
else
errors |> Seq.toList |> Error
else
("Multiple parsers consumed positional args; this is an error in the application, not an error by the user: "
+ String.concat ", " positionalConsumers)
|> List.singleton
|> Error
static member _Empty () : DoTheThing_InProgress =
{
Basics = BasicNoPositionals_InProgress._Empty ()
Auth = AuthOptions_InProgress._Empty ()
}
/// Passes the key-value pair to any child records, 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(<the message>).
/// This can nevertheless be a successful parse, e.g. when the key may have arity 0.
member this.ProcessKeyValueRecord_
(argNum_ : int)
(errors_ : ResizeArray<string>)
(key : string)
(value : string)
: Result<unit, string option>
=
let errors : ResizeArray<string> = ResizeArray ()
match this.Basics.ProcessKeyValue argNum_ errors_ key value with
| Ok () -> Ok ()
| Error e -> Error None
member this.ProcessKeyValue
(argNum_ : int)
(errors_ : ResizeArray<string>)
(key : string)
(value : string)
: Result<unit, string option>
=
match this.ProcessKeyValueRecord_ argNum_ errors_ key value with
| Ok () -> Ok ()
| Error errorFromRecord -> Error errorFromRecord
/// Returns false if we didn't set a value.
member this.SetFlagValue_ (errors_ : ResizeArray<string>) (key : string) : bool = false
/// Compute help text for this parser, optionally noting the given prefix on each argument and indenting each line by this many spaces.
static member HelpText_ (prefix : string option) (indent : int) : string = failwith "TODO"
namespace ConsumePlugin.ArgsWithUnions
open ArgParserHelpers
open System
open System.IO
open WoofWare.Myriad.Plugins
/// Methods to parse arguments for the type DoTheThing
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module DoTheThing =
type internal ParseState_DoTheThing =
/// Ready to consume a key or positional arg
| AwaitingKey
/// Waiting to receive a value for the key we've already consumed
| AwaitingValue of key : string
let parse' (getEnvironmentVariable : string -> string) (args : string list) : DoTheThing =
let inProgress =
ArgParseHelpers_ConsumePlugin_ArgsWithUnions.DoTheThing_InProgress._Empty ()
let positionals : ResizeArray<Choice<string * int, string * int>> = ResizeArray ()
let errors_ = ResizeArray ()
let rec go (argNum_ : int) (state : ParseState_DoTheThing) (args : string list) =
match args with
| [] ->
match state with
| ParseState_DoTheThing.AwaitingKey -> ()
| ParseState_DoTheThing.AwaitingValue key ->
if inProgress.SetFlagValue_ errors_ key then
()
else
sprintf
"Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args."
key
|> errors_.Add
| "--" :: rest -> positionals.AddRange (rest |> Seq.map (fun x -> (x, argNum_ + 1)) |> Seq.map Choice2Of2)
| arg :: args ->
match state with
| ParseState_DoTheThing.AwaitingKey ->
if arg.StartsWith ("--", System.StringComparison.Ordinal) then
if arg = "--help" then
"TODO" |> failwithf "Help text requested.\n%s"
else
let equals = arg.IndexOf (char 61)
if equals < 0 then
go (argNum_ + 1) (ParseState_DoTheThing.AwaitingValue arg) args
else
let key = arg.[0 .. equals - 1]
let value = arg.[equals + 1 ..]
match inProgress.ProcessKeyValue argNum_ errors_ key value with
| Ok () -> go (argNum_ + 1) ParseState_DoTheThing.AwaitingKey args
| Error x ->
match x with
| None ->
positionals.Add (Choice1Of2 (arg, argNum_))
go (argNum_ + 1) ParseState_DoTheThing.AwaitingKey args
| Some msg ->
sprintf "%s (at arg %s)" msg arg |> errors_.Add
go (argNum_ + 1) ParseState_DoTheThing.AwaitingKey args
else
(arg, argNum_) |> Choice1Of2 |> positionals.Add
go (argNum_ + 1) ParseState_DoTheThing.AwaitingKey args
| ParseState_DoTheThing.AwaitingValue key ->
match inProgress.ProcessKeyValue argNum_ errors_ key arg with
| Ok () -> go argNum_ ParseState_DoTheThing.AwaitingKey args
| Error exc ->
if inProgress.SetFlagValue_ errors_ key then
go argNum_ ParseState_DoTheThing.AwaitingKey (arg :: args)
else
(key, argNum_) |> Choice1Of2 |> positionals.Add
go (argNum_ + 1) ParseState_DoTheThing.AwaitingKey (arg :: args)
go 0 ParseState_DoTheThing.AwaitingKey args
if 0 = errors_.Count then
()
else
errors_
|> String.concat System.Environment.NewLine
|> (fun x -> "Errors during parse!\n" + x)
|> failwith
match inProgress.Assemble_ getEnvironmentVariable (positionals |> Seq.toList) with
| Ok (result, posConsumer) ->
if positionals.Count > 0 && posConsumer.IsNone then
positionals
|> Seq.map (fun choiceValue ->
match choiceValue with
| Choice1Of2 (arg, _) -> arg
| Choice2Of2 (arg, _) -> arg
)
|> String.concat " "
|> sprintf "Parse error: The following arguments were not consumed: %s"
|> failwith
else
result
| Error e ->
e
|> String.concat System.Environment.NewLine
|> (fun x -> "Errors during parse!\n" + x)
|> failwith
let parse (args : string list) : DoTheThing =
parse' System.Environment.GetEnvironmentVariable args

47
Playground/Domain.fs Normal file
View File

@@ -0,0 +1,47 @@
namespace Playground
open System
open WoofWare.Myriad.Plugins
[<ArgParser>]
type SubMode1 =
{
Info1 : int
Info2 : string
Rest : string list
}
[<ArgParser>]
type SubMode2 =
{
Info1 : int
Info2 : string
Rest : int list
}
[<ArgParser>]
type Mode1 =
{
Things : SubMode1
Whatnot : int
}
[<ArgParser>]
type Mode2 =
{
Things : SubMode2
Whatnot : DateTime
}
[<ArgParser>]
type Modes =
| Mode1 of Mode1
| Mode2 of Mode2
[<ArgParser>]
type Args =
{
WhatToDo : Modes
[<PositionalArgs>]
OtherArgs : string list
}

563
Playground/Library.fs Normal file
View File

@@ -0,0 +1,563 @@
//------------------------------------------------------------------------------
// This code was generated by myriad.
// Changes to this file will be lost when the code is regenerated.
//------------------------------------------------------------------------------
namespace Playground // Assuming a namespace
open System
open System.IO
open WoofWare.Myriad.Plugins // Assuming attributes are here
// Assume original type definitions are accessible here
// [<ArgParser>] type SubMode1 = { Info1 : int; Info2 : string; Rest : string list }
// [<ArgParser>] type SubMode2 = { Info1 : int; Info2 : string; Rest : int list }
// [<ArgParser>] type Mode1 = { Things : SubMode1; Whatnot : int }
// [<ArgParser>] type Mode2 = { Things : SubMode2; Whatnot : DateTime }
// [<ArgParser>] type Modes = | Mode1 of Mode1 | Mode2 of Mode2
// [<ArgParser>] type Args = { WhatToDo : Modes; [<PositionalArgs>] OtherArgs : string list }
/// Methods to parse arguments for the type Args
[<RequireQualifiedAccess ; CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module Args =
//--------------------------------------------------------------------------
// Internal state definitions (Non-Flattened with combined Assemble/Validate)
//--------------------------------------------------------------------------
/// State representing the parse progress for SubMode1 record
type private State_SubMode1 =
{
mutable Info1 : int option
mutable Info2 : string option
Rest : ResizeArray<string> // Corresponds to --rest
}
static member Create () =
{
Info1 = None
Info2 = None
Rest = ResizeArray ()
}
/// Check completeness and assemble the SubMode1 record from state.
member this.Assemble () : Result<SubMode1, string list> =
let errors = ResizeArray<string> ()
let mutable complete = true
if this.Info1.IsNone then
complete <- false
errors.Add ("Argument '--info1' is required.")
if this.Info2.IsNone then
complete <- false
errors.Add ("Argument '--info2' is required.")
// Rest is list, always 'complete'
if complete then
Ok
{
Info1 = this.Info1.Value
Info2 = this.Info2.Value
Rest = this.Rest |> Seq.toList
}
else
Error (errors |> Seq.toList)
/// State representing the parse progress for SubMode2 record
type private State_SubMode2 =
{
mutable Info1 : int option
mutable Info2 : string option
Rest : ResizeArray<int> // Corresponds to --rest
}
static member Create () =
{
Info1 = None
Info2 = None
Rest = ResizeArray ()
}
/// Check completeness and assemble the SubMode2 record from state.
member this.Assemble () : Result<SubMode2, string list> =
let errors = ResizeArray<string> ()
if this.Info1.IsNone then
errors.Add ("Argument '--info1' is required.")
if this.Info2.IsNone then
errors.Add ("Argument '--info2' is required.")
// Rest is list, always 'complete'
if errors.Count = 0 then
Ok
{
Info1 = this.Info1.Value
Info2 = this.Info2.Value
Rest = this.Rest |> Seq.toList
}
else
Error (errors |> Seq.toList)
/// State representing the parse progress for Mode1 record (references SubMode1 state)
type private State_Mode1 =
{
ThingsState : State_SubMode1 // Holds state for the nested record
mutable Whatnot : int option
}
static member Create () =
{
ThingsState = State_SubMode1.Create ()
Whatnot = None
}
/// Check completeness and assemble the Mode1 record from state (including nested).
member this.Assemble () : Result<Mode1, string list> =
let errors = ResizeArray<string> ()
// Check direct fields
if this.Whatnot.IsNone then
errors.Add ("Argument '--whatnot' is required for Mode1.")
// Assemble nested state (which includes its own validation)
let thingsResult = this.ThingsState.Assemble ()
let mutable thingsValue = None
match thingsResult with
| Ok v -> thingsValue <- Some v
| Error nestedErrors -> errors.AddRange (nestedErrors |> List.map (sprintf "Things: %s")) // Add context
if errors.Count = 0 then
Ok
{
Things = thingsValue.Value
Whatnot = this.Whatnot.Value
}
else
Error (errors |> Seq.toList)
/// State representing the parse progress for Mode2 record (references SubMode2 state)
type private State_Mode2 =
{
ThingsState : State_SubMode2 // Holds state for the nested record
mutable Whatnot : DateTime option
}
static member Create () =
{
ThingsState = State_SubMode2.Create ()
Whatnot = None
}
/// Check completeness and assemble the Mode2 record from state (including nested).
member this.Assemble () : Result<Mode2, string list> =
let errors = ResizeArray<string> ()
// Check direct fields
if this.Whatnot.IsNone then
errors.Add ("Argument '--whatnot' is required for Mode2.")
// Assemble nested state (which includes its own validation)
let thingsResult = this.ThingsState.Assemble ()
let mutable thingsValue = Unchecked.defaultof<_>
match thingsResult with
| Ok v -> thingsValue <- v
| Error nestedErrors -> errors.AddRange (nestedErrors |> List.map (sprintf "Things: %s")) // Add context
if errors.Count = 0 then
{
Things = thingsValue
Whatnot = this.Whatnot.Value
}
|> Ok
else
Error (errors |> Seq.toList)
/// State for a single candidate parse path for the Modes DU (Structure unchanged)
type private CandidateParseState_Modes =
{
CaseName : string // "Mode1" or "Mode2"
mutable IsViable : bool
Errors : ResizeArray<string> // Errors specific to this candidate's path
ConsumedArgIndices : System.Collections.Generic.HashSet<int> // Indices consumed *by this candidate*
CaseState : obj // Holds either State_Mode1 or State_Mode2
}
static member CreateMode1 () =
{
CaseName = "Mode1"
IsViable = true
Errors = ResizeArray ()
ConsumedArgIndices = System.Collections.Generic.HashSet ()
CaseState = State_Mode1.Create () :> obj
}
static member CreateMode2 () =
{
CaseName = "Mode2"
IsViable = true
Errors = ResizeArray ()
ConsumedArgIndices = System.Collections.Generic.HashSet ()
CaseState = State_Mode2.Create () :> obj
}
//--------------------------------------------------------------------------
// Main Parser Logic
//--------------------------------------------------------------------------
type private ParseState_Args =
| AwaitingArg
| AwaitingValue of keyIndex : int * key : string
let parse' (getEnvironmentVariable : string -> string) (args : string list) : Args =
let ArgParser_errors = ResizeArray () // Global errors accumulator
let helpText () =
// Help text generation unchanged
[
(sprintf "%s int32%s%s" (sprintf "--%s" "info1") "" " (for Mode1/Mode2 Things)")
(sprintf "%s string%s%s" (sprintf "--%s" "info2") "" " (for Mode1/Mode2 Things)")
(sprintf "%s string%s%s" (sprintf "--%s" "rest") " (can be repeated)" " (for Mode1 Things)")
(sprintf "%s int32%s%s" (sprintf "--%s" "rest") " (can be repeated)" " (for Mode2 Things)")
(sprintf "%s int32%s%s" (sprintf "--%s" "whatnot") "" " (for Mode1)")
(sprintf "%s DateTime%s%s" (sprintf "--%s" "whatnot") "" " (for Mode2)")
(sprintf "%s string%s%s" (sprintf "--%s" "other-args") " (positional args) (can be repeated)" "")
]
|> String.concat "\n"
let arg_OtherArgs : string ResizeArray = ResizeArray ()
let mutable candidates_WhatToDo : CandidateParseState_Modes list =
[
CandidateParseState_Modes.CreateMode1 ()
CandidateParseState_Modes.CreateMode2 ()
]
let consumedArgIndices_WhatToDo = System.Collections.Generic.HashSet<int> ()
//----------------------------------------------------------------------
// Helper functions for applying args (applyKeyValueToSubModeXState unchanged)
//----------------------------------------------------------------------
let applyKeyValueToSubMode1State
(argIndex : int)
(keyIndex : int)
(key : string)
(value : string)
(subState : State_SubMode1)
(candidate : CandidateParseState_Modes)
: unit
=
// ... (Implementation identical to previous version) ...
if String.Equals (key, "--info1", StringComparison.OrdinalIgnoreCase) then
match subState.Info1 with
| Some _ ->
candidate.Errors.Add (sprintf "Argument '--info1' supplied multiple times (SubMode1)")
candidate.IsViable <- false
| None ->
try
subState.Info1 <- Some (Int32.Parse value)
candidate.ConsumedArgIndices.Add argIndex |> ignore
candidate.ConsumedArgIndices.Add keyIndex |> ignore
with ex ->
candidate.Errors.Add (
sprintf "Failed to parse '%s' for --info1 (SubMode1): %s" value ex.Message
)
candidate.IsViable <- false
elif String.Equals (key, "--info2", StringComparison.OrdinalIgnoreCase) then
match subState.Info2 with
| Some _ ->
candidate.Errors.Add (sprintf "Argument '--info2' supplied multiple times (SubMode1)")
candidate.IsViable <- false
| None ->
subState.Info2 <- Some value
candidate.ConsumedArgIndices.Add argIndex |> ignore
candidate.ConsumedArgIndices.Add keyIndex |> ignore
elif String.Equals (key, "--rest", StringComparison.OrdinalIgnoreCase) then
subState.Rest.Add value
candidate.ConsumedArgIndices.Add argIndex |> ignore
candidate.ConsumedArgIndices.Add keyIndex |> ignore
else
()
let applyKeyValueToSubMode2State
(argIndex : int)
(keyIndex : int)
(key : string)
(value : string)
(subState : State_SubMode2)
(candidate : CandidateParseState_Modes)
: unit
=
// ... (Implementation identical to previous version) ...
if String.Equals (key, "--info1", StringComparison.OrdinalIgnoreCase) then
match subState.Info1 with
| Some _ ->
candidate.Errors.Add (sprintf "Argument '--info1' supplied multiple times (SubMode2)")
candidate.IsViable <- false
| None ->
try
subState.Info1 <- Some (Int32.Parse value)
candidate.ConsumedArgIndices.Add argIndex |> ignore
candidate.ConsumedArgIndices.Add keyIndex |> ignore
with ex ->
candidate.Errors.Add (
sprintf "Failed to parse '%s' for --info1 (SubMode2): %s" value ex.Message
)
candidate.IsViable <- false
elif String.Equals (key, "--info2", StringComparison.OrdinalIgnoreCase) then
match subState.Info2 with
| Some _ ->
candidate.Errors.Add (sprintf "Argument '--info2' supplied multiple times (SubMode2)")
candidate.IsViable <- false
| None ->
subState.Info2 <- Some value
candidate.ConsumedArgIndices.Add argIndex |> ignore
candidate.ConsumedArgIndices.Add keyIndex |> ignore
elif String.Equals (key, "--rest", StringComparison.OrdinalIgnoreCase) then
try
subState.Rest.Add (Int32.Parse value)
candidate.ConsumedArgIndices.Add argIndex |> ignore
candidate.ConsumedArgIndices.Add keyIndex |> ignore
with ex ->
candidate.Errors.Add (
sprintf "Failed to parse '%s' as int32 for --rest (SubMode2): %s" value ex.Message
)
candidate.IsViable <- false
else
()
//----------------------------------------------------------------------
// Routing and Main Application Logic (applyKeyValueToCandidate unchanged)
//----------------------------------------------------------------------
let applyKeyValueToCandidate
(argIndex : int, keyIndex : int, key : string, value : string)
(candidate : CandidateParseState_Modes)
: unit
=
// ... (Implementation identical to previous version, calling sub-state helpers) ...
if not candidate.IsViable then
()
else
match candidate.CaseName with
| "Mode1" ->
let state = candidate.CaseState :?> State_Mode1
if String.Equals (key, "--whatnot", StringComparison.OrdinalIgnoreCase) then
match state.Whatnot with
| Some _ ->
candidate.Errors.Add (
sprintf "Argument '--whatnot' supplied multiple times for Mode1 candidate"
)
candidate.IsViable <- false
| None ->
try
state.Whatnot <- Some (Int32.Parse value)
candidate.ConsumedArgIndices.Add argIndex |> ignore
candidate.ConsumedArgIndices.Add keyIndex |> ignore
with ex ->
candidate.Errors.Add (
sprintf "Failed to parse '%s' as int32 for --whatnot (Mode1): %s" value ex.Message
)
candidate.IsViable <- false
elif key = "--info1" || key = "--info2" || key = "--rest" then
applyKeyValueToSubMode1State argIndex keyIndex key value state.ThingsState candidate
else
()
| "Mode2" ->
let state = candidate.CaseState :?> State_Mode2
if String.Equals (key, "--whatnot", StringComparison.OrdinalIgnoreCase) then
match state.Whatnot with
| Some _ ->
candidate.Errors.Add (
sprintf "Argument '--whatnot' supplied multiple times for Mode2 candidate"
)
candidate.IsViable <- false
| None ->
try
state.Whatnot <- Some (DateTime.Parse value)
candidate.ConsumedArgIndices.Add argIndex |> ignore
candidate.ConsumedArgIndices.Add keyIndex |> ignore
with ex ->
candidate.Errors.Add (
sprintf "Failed to parse '%s' as DateTime for --whatnot (Mode2): %s" value ex.Message
)
candidate.IsViable <- false
elif key = "--info1" || key = "--info2" || key = "--rest" then
applyKeyValueToSubMode2State argIndex keyIndex key value state.ThingsState candidate
else
()
| _ -> failwith "Internal error: Unknown case name"
// processKeyValue, setFlagValue, and main loop `go` are identical to previous version
let processKeyValue (keyIndex : int, key : string, valueIndex : int, value : string) : bool =
let mutable handled = false
for candidate in candidates_WhatToDo do
let initialConsumedCount = candidate.ConsumedArgIndices.Count
if candidate.IsViable then
applyKeyValueToCandidate (valueIndex, keyIndex, key, value) candidate
if candidate.IsViable && candidate.ConsumedArgIndices.Count > initialConsumedCount then
handled <- true
consumedArgIndices_WhatToDo.Add keyIndex |> ignore
consumedArgIndices_WhatToDo.Add valueIndex |> ignore
handled
let setFlagValue (keyIndex : int) (key : string) : bool = false // No flags
let rec go (state : ParseState_Args) (args : (int * string) list) =
// ... (Implementation identical to previous version) ...
match args with
| [] ->
match state with
| ParseState_Args.AwaitingArg -> ()
| ParseState_Args.AwaitingValue (i, k) ->
if not (setFlagValue i k) then
ArgParser_errors.Add (sprintf "Trailing argument '%s' (at index %d) requires a value." k i)
| (idx, arg) :: rest ->
match state with
| ParseState_Args.AwaitingArg ->
if arg = "--" then
rest
|> List.iter (fun (i, v) ->
if not (consumedArgIndices_WhatToDo.Contains i) then
arg_OtherArgs.Add v
)
go ParseState_Args.AwaitingArg []
elif arg.StartsWith ("--") then
if arg = "--help" then
helpText () |> failwithf "Help text requested:\n%s"
else
let eq = arg.IndexOf ('=')
if eq > 0 then
let k = arg.[.. eq - 1]
let v = arg.[eq + 1 ..]
if not (processKeyValue (idx, k, idx, v)) then
if not (consumedArgIndices_WhatToDo.Contains idx) then
arg_OtherArgs.Add arg
go ParseState_Args.AwaitingArg rest
elif setFlagValue idx arg then
consumedArgIndices_WhatToDo.Add idx |> ignore
go ParseState_Args.AwaitingArg rest
else
go (ParseState_Args.AwaitingValue (idx, arg)) rest
else
if not (consumedArgIndices_WhatToDo.Contains idx) then
arg_OtherArgs.Add arg
go ParseState_Args.AwaitingArg rest
| ParseState_Args.AwaitingValue (keyIdx, key) ->
if processKeyValue (keyIdx, key, idx, arg) then
go ParseState_Args.AwaitingArg rest
elif setFlagValue keyIdx key then
consumedArgIndices_WhatToDo.Add keyIdx |> ignore<bool>
go ParseState_Args.AwaitingArg ((idx, arg) :: rest) // Reprocess arg
elif not (consumedArgIndices_WhatToDo.Contains keyIdx) then
arg_OtherArgs.Add key
if not (consumedArgIndices_WhatToDo.Contains idx) then
arg_OtherArgs.Add arg
go ParseState_Args.AwaitingArg rest
args |> List.mapi (fun i s -> (i, s)) |> go ParseState_Args.AwaitingArg
//----------------------------------------------------------------------
// Final Validation and Assembly (Uses new Assemble methods)
//----------------------------------------------------------------------
let viableWinners = candidates_WhatToDo |> List.filter (fun c -> c.IsViable)
// No longer filter based on IsComplete here; Assemble handles it.
// Still need to check for relative leftovers if that logic were implemented.
let whatToDoResult =
match viableWinners with
| [] ->
// Add specific errors from candidates that were viable *before* Assemble check
ArgParser_errors.Add ("No valid parse found for 'WhatToDo'.")
candidates_WhatToDo
|> List.iter (fun c ->
if c.Errors.Count <> 0 then
ArgParser_errors.Add (
sprintf " Candidate %s parse errors: %s" c.CaseName (String.concat "; " c.Errors)
)
// Potentially try to Assemble even non-viable ones to get completion errors? Maybe too complex.
)
Unchecked.defaultof<_> // Error path
| [ winner ] ->
// Assemble the winning case, checking the Result for completion errors
match winner.CaseName with
| "Mode1" ->
match (winner.CaseState :?> State_Mode1).Assemble () with
| Ok mode1Value -> Modes.Mode1 mode1Value
| Error completionErrors ->
ArgParser_errors.Add (sprintf "Validation failed for selected candidate Mode1:")
ArgParser_errors.AddRange completionErrors
Unchecked.defaultof<_> // Error path
| "Mode2" ->
match (winner.CaseState :?> State_Mode2).Assemble () with
| Ok mode2Value -> Modes.Mode2 mode2Value
| Error completionErrors ->
ArgParser_errors.Add (sprintf "Validation failed for selected candidate Mode2:")
ArgParser_errors.AddRange completionErrors
Unchecked.defaultof<_> // Error path
| _ -> failwith "Internal error: Unknown winning case name"
| winners -> // Ambiguous parse
ArgParser_errors.Add ("Ambiguous parse for 'WhatToDo'. Multiple modes potentially viable:")
winners
|> List.iter (fun c ->
ArgParser_errors.Add (
sprintf
" - %s (Initial Errors: %s)"
c.CaseName
(if c.Errors.Count = 0 then
"None"
else
String.concat "; " c.Errors)
)
)
Unchecked.defaultof<_> // Error path
// Finalize OtherArgs (unchanged)
let otherArgsResult = arg_OtherArgs |> Seq.toList
// Assemble Final Result or Fail (unchanged)
if ArgParser_errors.Count > 0 then
ArgParser_errors
|> String.concat "\n"
|> failwithf "Errors during parse!\n%s\n\nHelp Text:\n%s" (helpText ())
else
{
WhatToDo = whatToDoResult
OtherArgs = otherArgsResult
}
let parse (args : string list) : Args =
parse' System.Environment.GetEnvironmentVariable args

View File

@@ -0,0 +1,19 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<TargetFramework>net9.0</TargetFramework>
<GenerateDocumentationFile>true</GenerateDocumentationFile>
<OutputType>Exe</OutputType>
</PropertyGroup>
<ItemGroup>
<Compile Include="Domain.fs" />
<Compile Include="Library.fs"/>
<Compile Include="Program.fs" />
</ItemGroup>
<ItemGroup>
<ProjectReference Include="..\WoofWare.Myriad.Plugins.Attributes\WoofWare.Myriad.Plugins.Attributes.fsproj" />
</ItemGroup>
</Project>

10
Playground/Program.fs Normal file
View File

@@ -0,0 +1,10 @@
namespace Playground
module Program =
[<EntryPoint>]
let main argv =
[ "--whatnot=2024-01-12" ; "--info1=4" ; "--info2=hi" ]
|> Args.parse
|> printfn "%O"
0

View File

@@ -79,11 +79,8 @@ module TestArgParser =
exc.Message exc.Message
|> shouldEqual |> shouldEqual
"""Unable to process supplied arg --non-existent. Help text follows. """Errors during parse!
--foo int32 : This is a foo! Unmatched args which look like they are meant to be flags. If you intended them as positional args, explicitly pass them with the `--rest=` syntax, or place them after a trailing `--`. --non-existent"""
--bar string
--baz bool
--rest string (positional args) (can be repeated) : Here's where the rest of the args go"""
[<Test>] [<Test>]
let ``Can supply positional args with key`` () = let ``Can supply positional args with key`` () =
@@ -318,8 +315,7 @@ Required argument '--baz' received no value"""
exc.Message exc.Message
|> shouldEqual |> shouldEqual
"""Errors during parse! """Errors during parse!
Input string was not in a correct format. (at arg --invariant-exact=23:59) Input string was not in a correct format. (at arg --invariant-exact=23:59)"""
Required argument '--invariant-exact' received no value"""
let exc = let exc =
Assert.Throws<exn> (fun () -> Assert.Throws<exn> (fun () ->
@@ -337,8 +333,7 @@ Required argument '--invariant-exact' received no value"""
exc.Message exc.Message
|> shouldEqual |> shouldEqual
"""Errors during parse! """Errors during parse!
Input string was not in a correct format. (at arg --exact=11:34) Input string was not in a correct format. (at arg --exact=11:34)"""
Required argument '--exact' received no value"""
count.Value |> shouldEqual 0 count.Value |> shouldEqual 0
@@ -444,7 +439,7 @@ Required argument '--exact' received no value"""
] ]
|> List.map TestCaseData |> List.map TestCaseData
[<TestCaseSource(nameof (boolCases))>] [<TestCaseSource(nameof boolCases)>]
let ``Bool env vars can be populated`` (envValue : string, boolValue : bool) = let ``Bool env vars can be populated`` (envValue : string, boolValue : bool) =
let getEnvVar (s : string) = let getEnvVar (s : string) =
s |> shouldEqual "CONSUMEPLUGIN_THINGS" s |> shouldEqual "CONSUMEPLUGIN_THINGS"
@@ -604,7 +599,10 @@ Required argument '--exact' received no value"""
) )
exc.Message exc.Message
|> shouldEqual """Unable to process argument --do-the-thing=foo as key --do-the-thing and value foo""" |> shouldEqual
"""Errors during parse!
Required argument '--do-something-else' received no value
Required argument '--turn-it-on' received no value"""
[<Test>] [<Test>]
let ``Long-form args help text`` () = let ``Long-form args help text`` () =
@@ -692,7 +690,9 @@ Required argument '--exact' received no value"""
) )
exc.Message exc.Message
|> shouldEqual """Unable to process argument --b=false as key --b and value false""" |> shouldEqual
"""Errors during parse!
Unmatched args which look like they are meant to be flags. If you intended them as positional args, explicitly pass them with the `--dont-grab-everything=` syntax, or place them after a trailing `--`. --b=false --c"""
let exc = let exc =
Assert.Throws<exn> (fun () -> Assert.Throws<exn> (fun () ->
@@ -703,4 +703,6 @@ Required argument '--exact' received no value"""
// Again perhaps eccentric! // Again perhaps eccentric!
// Again, we don't try to detect that the user has missed out the desired argument to `--a`. // Again, we don't try to detect that the user has missed out the desired argument to `--a`.
exc.Message exc.Message
|> shouldEqual """Unable to process argument --c=hi as key --c and value hi""" |> shouldEqual
"""Errors during parse!
Unmatched args which look like they are meant to be flags. If you intended them as positional args, explicitly pass them with the `--my-arg-name=` syntax, or place them after a trailing `--`. --c=hi"""

View File

@@ -0,0 +1,21 @@
namespace WoofWare.Myriad.Plugins.Test
open FsUnitTyped
open NUnit.Framework
open ConsumePlugin.ArgsWithUnions
[<TestFixture>]
module TestArgsWithUnions =
let argsWithUnionsCases =
[
["--token" ; "hello" ; "--foo" ; "3" ; "--bar=hi" ; "--baz"], { Auth = AuthOptions.Token { Token = "hello" } ; Basics = { Foo = 3 ; Bar = "hi" ; Baz = true ; Rest = [] } }
]
|> List.map TestCaseData
[<TestCaseSource (nameof argsWithUnionsCases)>]
let ``foo`` (args : string list, expected : DoTheThing) : unit =
args
|> DoTheThing.parse' (fun _ -> failwith "didn't expect env var")
|> shouldEqual expected

View File

@@ -13,6 +13,7 @@
</PropertyGroup> </PropertyGroup>
<ItemGroup> <ItemGroup>
<!--
<Compile Include="HttpClient.fs"/> <Compile Include="HttpClient.fs"/>
<Compile Include="PureGymDtos.fs"/> <Compile Include="PureGymDtos.fs"/>
<Compile Include="TestJsonParse\TestJsonParse.fs" /> <Compile Include="TestJsonParse\TestJsonParse.fs" />
@@ -34,10 +35,14 @@
<Compile Include="TestCataGenerator\TestGift.fs" /> <Compile Include="TestCataGenerator\TestGift.fs" />
<Compile Include="TestCataGenerator\TestMyList.fs" /> <Compile Include="TestCataGenerator\TestMyList.fs" />
<Compile Include="TestCataGenerator\TestMyList2.fs" /> <Compile Include="TestCataGenerator\TestMyList2.fs" />
-->
<Compile Include="TestArgParser\TestArgParser.fs" /> <Compile Include="TestArgParser\TestArgParser.fs" />
<Compile Include="TestArgParser\TestArgsWithUnions.fs" />
<!--
<Compile Include="TestSwagger\TestSwaggerParse.fs" /> <Compile Include="TestSwagger\TestSwaggerParse.fs" />
<Compile Include="TestRemoveOptions.fs"/> <Compile Include="TestRemoveOptions.fs"/>
<Compile Include="TestSurface.fs"/> <Compile Include="TestSurface.fs"/>
-->
<None Include="../.github/workflows/dotnet.yaml" /> <None Include="../.github/workflows/dotnet.yaml" />
</ItemGroup> </ItemGroup>

View File

@@ -7,82 +7,6 @@ open Fantomas.FCS.Text.Range
open TypeEquality open TypeEquality
open WoofWare.Whippet.Fantomas open WoofWare.Whippet.Fantomas
type internal ArgParserOutputSpec =
{
ExtensionMethods : bool
}
type internal FlagDu =
{
Name : Ident
Case1Name : Ident
Case2Name : Ident
/// Hopefully this is simply the const bool True or False, but it might e.g. be a literal
Case1Arg : SynExpr
/// Hopefully this is simply the const bool True or False, but it might e.g. be a literal
Case2Arg : SynExpr
}
static member FromBoolean (flagDu : FlagDu) (value : SynExpr) =
SynExpr.ifThenElse
(SynExpr.equals value flagDu.Case1Arg)
(SynExpr.createLongIdent' [ flagDu.Name ; flagDu.Case2Name ])
(SynExpr.createLongIdent' [ flagDu.Name ; flagDu.Case1Name ])
/// The default value of an argument which admits default values can be pulled from different sources.
/// This defines which source a particular default value comes from.
type private ArgumentDefaultSpec =
/// From parsing the environment variable with the given name (e.g. "WOOFWARE_DISABLE_FOO" or whatever).
| EnvironmentVariable of name : SynExpr
/// From calling the static member `{typeWeParseInto}.Default{name}()`
/// For example, if `type MyArgs = { Thing : Choice<int, int> }`, then
/// we would use `MyArgs.DefaultThing () : int`.
///
| FunctionCall of name : Ident
type private Accumulation<'choice> =
| Required
| Optional
| Choice of 'choice
| List of Accumulation<'choice>
type private ParseFunction<'acc> =
{
FieldName : Ident
TargetVariable : Ident
/// Any of the forms in this set are acceptable, but make sure they all start with a dash, or we might
/// get confused with positional args or something! I haven't thought that hard about this.
/// In the default case, this is `Const("arg-name")` for the `ArgName : blah` field; note that we have
/// omitted the initial `--` that will be required at runtime.
ArgForm : SynExpr list
/// If this is a boolean-like field (e.g. a bool or a flag DU), the help text should look a bit different:
/// we should lie to the user about the value of the cases there.
/// Similarly, if we're reading from an environment variable with the laxer parsing rules of accepting e.g.
/// "0" instead of "false", we need to know if we're reading a bool.
/// In that case, `boolCases` is Some, and contains the construction of the flag (or boolean, in which case
/// you get no data).
BoolCases : Choice<FlagDu, unit> option
Help : SynExpr option
/// A function string -> %TargetType%, where TargetVariable is probably a `%TargetType% option`.
/// (Depending on `Accumulation`, we'll remove the `option` at the end of the parse, asserting that the
/// argument was supplied.)
/// This is allowed to throw if it fails to parse.
Parser : SynExpr
/// If `Accumulation` is `List`, then this is the type of the list *element*; analogously for optionals
/// and choices and so on.
TargetType : SynType
Accumulation : 'acc
}
/// A SynExpr of type `string` which we can display to the user at generated-program runtime to display all
/// the ways they can refer to this arg.
member arg.HumanReadableArgForm : SynExpr =
let formatString = List.replicate arg.ArgForm.Length "--%s" |> String.concat " / "
(SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst formatString), arg.ArgForm)
||> List.fold SynExpr.applyFunction
|> SynExpr.paren
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
type private ChoicePositional = type private ChoicePositional =
| Normal of includeFlagLike : SynExpr option | Normal of includeFlagLike : SynExpr option
@@ -114,14 +38,14 @@ type private ParseTree<'hasPositional> =
/// `assemble` takes the SynExpr's (e.g. each record field contents) corresponding to each `Ident` in /// `assemble` takes the SynExpr's (e.g. each record field contents) corresponding to each `Ident` in
/// the branch (e.g. each record field name), /// the branch (e.g. each record field name),
/// and composes them into a `SynExpr` (e.g. the record-typed object). /// and composes them into a `SynExpr` (e.g. the record-typed object).
| Branch of | DescendRecord of
fields : (Ident * ParseTree<HasNoPositional>) list * fields : (Ident * ParseTree<HasNoPositional>) list *
assemble : (Map<string, SynExpr> -> SynExpr) * assemble : (Map<string, SynExpr> -> SynExpr) *
Teq<'hasPositional, HasNoPositional> Teq<'hasPositional, HasNoPositional>
/// `assemble` takes the SynExpr's (e.g. each record field contents) corresponding to each `Ident` in /// `assemble` takes the SynExpr's (e.g. each record field contents) corresponding to each `Ident` in
/// the branch (e.g. each record field name), /// the branch (e.g. each record field name),
/// and composes them into a `SynExpr` (e.g. the record-typed object). /// and composes them into a `SynExpr` (e.g. the record-typed object).
| BranchPos of | DescendRecordPos of
posField : Ident * posField : Ident *
fields : ParseTree<HasPositional> * fields : ParseTree<HasPositional> *
(Ident * ParseTree<HasNoPositional>) list * (Ident * ParseTree<HasNoPositional>) list *
@@ -184,63 +108,6 @@ module private ParseTree =
go None ([], None) subs go None ([], None) subs
let rec accumulatorsNonPos (tree : ParseTree<HasNoPositional>) : ParseFunctionNonPositional 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<HasPositional>)
: ParseFunctionNonPositional list * ParseFunctionPositional
=
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>) : ParseFunctionNonPositional list * ParseFunctionPositional 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
|> fun (nonPos, pos) ->
let duplicateArgs =
// This is best-effort. We can't necessarily detect all SynExprs here, but usually it'll be strings.
Option.toList (pos |> Option.map _.ArgForm) @ (nonPos |> List.map _.ArgForm)
|> Seq.concat
|> Seq.choose (fun expr ->
match expr |> SynExpr.stripOptionalParen with
| SynExpr.Const (SynConst.String (s, _, _), _) -> Some s
| _ -> None
)
|> List.ofSeq
|> List.groupBy id
|> List.choose (fun (key, v) -> if v.Length > 1 then Some key else None)
match duplicateArgs with
| [] -> nonPos, pos
| dups ->
let dups = dups |> String.concat " "
failwith $"Duplicate args detected! %s{dups}"
/// Build the return value. /// Build the return value.
let rec instantiate<'a> (tree : ParseTree<'a>) : SynExpr = let rec instantiate<'a> (tree : ParseTree<'a>) : SynExpr =
match tree with match tree with

View File

@@ -21,3 +21,13 @@ module private List =
| Some head :: tail -> go (head :: acc) tail | Some head :: tail -> go (head :: acc) tail
go [] l go [] l
/// Return the first error encountered, or the entire list.
let allOkOrError<'ok, 'err> (l : Result<'ok, 'err> list) : Result<'ok list, 'err> =
let rec go acc l =
match l with
| [] -> Ok (List.rev acc)
| Error e :: _ -> Error e
| Ok o :: rest -> go (o :: acc) rest
go [] l

File diff suppressed because it is too large Load Diff

View File

@@ -40,7 +40,8 @@
<Compile Include="JsonParseGenerator.fs"/> <Compile Include="JsonParseGenerator.fs"/>
<Compile Include="HttpClientGenerator.fs"/> <Compile Include="HttpClientGenerator.fs"/>
<Compile Include="CataGenerator.fs" /> <Compile Include="CataGenerator.fs" />
<Compile Include="ArgParserGenerator.fs" /> <Compile Include="ShibaGenerator.fs" />
<None Include="ArgParserGenerator.fs" />
<Compile Include="Swagger.fs" /> <Compile Include="Swagger.fs" />
<Compile Include="SwaggerClientGenerator.fs" /> <Compile Include="SwaggerClientGenerator.fs" />
<None Include="ApacheLicence.txt" /> <None Include="ApacheLicence.txt" />

View File

@@ -10,6 +10,8 @@ Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "WoofWare.Myriad.Plugins.Att
EndProject EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "WoofWare.Myriad.Plugins.Attributes.Test", "WoofWare.Myriad.Plugins.Attributes\Test\WoofWare.Myriad.Plugins.Attributes.Test.fsproj", "{26DC0C94-85F2-45B4-8FA1-1B27201F7AFB}" Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "WoofWare.Myriad.Plugins.Attributes.Test", "WoofWare.Myriad.Plugins.Attributes\Test\WoofWare.Myriad.Plugins.Attributes.Test.fsproj", "{26DC0C94-85F2-45B4-8FA1-1B27201F7AFB}"
EndProject EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Playground", "Playground\Playground.fsproj", "{6DF8C756-DE59-4AFF-A4BB-2D05C74192A4}"
EndProject
Global Global
GlobalSection(SolutionConfigurationPlatforms) = preSolution GlobalSection(SolutionConfigurationPlatforms) = preSolution
Debug|Any CPU = Debug|Any CPU Debug|Any CPU = Debug|Any CPU
@@ -36,5 +38,9 @@ Global
{26DC0C94-85F2-45B4-8FA1-1B27201F7AFB}.Debug|Any CPU.Build.0 = Debug|Any CPU {26DC0C94-85F2-45B4-8FA1-1B27201F7AFB}.Debug|Any CPU.Build.0 = Debug|Any CPU
{26DC0C94-85F2-45B4-8FA1-1B27201F7AFB}.Release|Any CPU.ActiveCfg = Release|Any CPU {26DC0C94-85F2-45B4-8FA1-1B27201F7AFB}.Release|Any CPU.ActiveCfg = Release|Any CPU
{26DC0C94-85F2-45B4-8FA1-1B27201F7AFB}.Release|Any CPU.Build.0 = Release|Any CPU {26DC0C94-85F2-45B4-8FA1-1B27201F7AFB}.Release|Any CPU.Build.0 = Release|Any CPU
{6DF8C756-DE59-4AFF-A4BB-2D05C74192A4}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
{6DF8C756-DE59-4AFF-A4BB-2D05C74192A4}.Debug|Any CPU.Build.0 = Debug|Any CPU
{6DF8C756-DE59-4AFF-A4BB-2D05C74192A4}.Release|Any CPU.ActiveCfg = Release|Any CPU
{6DF8C756-DE59-4AFF-A4BB-2D05C74192A4}.Release|Any CPU.Build.0 = Release|Any CPU
EndGlobalSection EndGlobalSection
EndGlobal EndGlobal