From ce73ca1e081d1a4f4f9d87e39991ac806bd4a66d Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Fri, 4 Sep 2026 15:33:43 +0800 Subject: [PATCH 01/15] feat: safe handling of list actioninputs --- src/FSharp.SystemCommandLine/Inputs.fs | 66 +++++++++++++++++++++++--- src/Tests/ListOptionTest.fs | 35 ++++++++++++++ src/Tests/Tests.fsproj | 1 + 3 files changed, 95 insertions(+), 7 deletions(-) create mode 100644 src/Tests/ListOptionTest.fs diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index a02f338..5e59cc3 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -6,7 +6,7 @@ open System.CommandLine module private MaybeParser = /// Parses an argument token value. /// TODO: Ideally, this should use the S.CL Arugment parser. - let parseTokenValue<'T> (tokenValue: string) = + let parseTokenValue (tokenValue: string) = match typeof<'T> with | t when t = typeof -> IO.DirectoryInfo(tokenValue) |> unbox<'T> |> Some | t when t = typeof -> IO.FileInfo(tokenValue) |> unbox<'T> |> Some @@ -89,7 +89,7 @@ type Arity = | _ -> ArgumentArity (argumentArity.MinimumNumberOfValues, argumentArity.MaximumNumberOfValues) -module Input = +module Input = /// Injects an `ActionContext` into the action which contains the `ParseResult` and a cancellation token. let context = @@ -99,9 +99,6 @@ module Input = let inject<'T> (value: 'T) = ActionInput<'T>(Injection (box value)) - /// Creates a named option. Example: `option "--file-name"` - let option<'T> (name: string) = - Option<'T>(name) |> ActionInput.OfOption /// Edits the underlying System.CommandLine.Option<'T>. let editOption (edit: Option<'T> -> unit) (input: ActionInput<'T>) = @@ -177,7 +174,61 @@ module Input = let recursive (input: ActionInput<'T>) = input |> editOption (fun o -> o.Recursive <- true) + + type private SafeInputLists = + static member private dynamicParser<'T>(): Parsing.ArgumentResult -> Array = + fun result -> + let typ = typeof<'T> + let count = result.Tokens.Count + let elementType = + if typ.GetElementType() = null + then typ.GetGenericArguments()[0] + else typ.GetElementType() + + let dynamicArray = Array.CreateInstance(elementType, count) + for i, token in result.Tokens |> Seq.indexed do + dynamicArray.SetValue(Convert.ChangeType(token.Value, elementType), i) + dynamicArray + + static member protect<'T>(o: Argument<'T>) = + match typeof<'T> with + | typ when typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> -> + o.Arity <- ArgumentArity (0, 100_000) + o.CustomParser <- (SafeInputLists.dynamicParser<'T>() >> fun dynamicArray -> + let modl = typeof>.Assembly.GetType("Microsoft.FSharp.Collections.ListModule") + let meth = modl.GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + meth.MakeGenericMethod(typeof<'T>.GetGenericArguments()[0]).Invoke(null, [| dynamicArray |] ) |> unbox + ) + o.DefaultValueFactory <- (fun _ -> + let emptyProperty = typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + if emptyProperty <> null then emptyProperty.GetValue(null) |> unbox + else failwithf $"Could not find Empty property on type %s{typ.FullName}." + ) + o + | _ -> o + static member protect<'T>(o: Option<'T>) = + match typeof<'T> with + | typ when typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> -> + o.Arity <- ArgumentArity (0, 100_000) + o.CustomParser <- (SafeInputLists.dynamicParser<'T>() >> fun dynamicArray -> + let modl = typeof>.Assembly.GetType("Microsoft.FSharp.Collections.ListModule") + let meth = modl.GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + meth.MakeGenericMethod(typeof<'T>.GetGenericArguments()[0]).Invoke(null, [| dynamicArray |] ) |> unbox + ) + o.DefaultValueFactory <- (fun _ -> + let emptyProperty = typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + if emptyProperty <> null then emptyProperty.GetValue(null) |> unbox + else failwithf $"Could not find Empty property on type %s{typ.FullName}." + ) + o + | _ -> o + /// Creates a named option. Example: `option "--file-name"` + let option<'T> (name: string) = + Option<'T>(name) + |> SafeInputLists.protect<'T> + |> ActionInput.OfOption<'T> + /// Creates a named option of type `Option<'T option>` that defaults to `None`. let optionMaybe<'T> (name: string) = let o = Option<'T option>(name, aliases = [||]) @@ -217,8 +268,9 @@ module Input = /// Creates a named argument. Example: `argument "file-name"` let argument<'T> (name: string) = - let a = Argument<'T>(name) - ActionInput.OfArgument<'T> a + Argument<'T>(name) + |> SafeInputLists.protect<'T> + |> ActionInput.OfArgument<'T> /// Creates a named argument of type `Argument<'T option>` that defaults to `None`. let argumentMaybe<'T> (name: string) = diff --git a/src/Tests/ListOptionTest.fs b/src/Tests/ListOptionTest.fs new file mode 100644 index 0000000..30f4104 --- /dev/null +++ b/src/Tests/ListOptionTest.fs @@ -0,0 +1,35 @@ +module ListOptionTest + + +open NUnit.Framework +open Swensen.Unquote +open FSharp.SystemCommandLine +open Utils +open Input + +let mutable handlerCalled = false +let called() = handlerCalled <- true +[] +let setup () = handlerCalled <- false + +[] +let ``01 - No input to list option should be empty list``() = + let input = option "-p" |> arity Arity.ZeroOrMore + let commandRunner (shouldSucceed: bool): string -> (string list -> bool) -> unit = fun command comp -> + testRootCommand command { + description "Test" + inputs input + setAction (function + | values when comp values -> called(); 0 + | _ -> 1 + ) + } + |> if shouldSucceed then (=!) 0 else (<>!) 0 + handlerCalled =! shouldSucceed + handlerCalled <- false + let shouldSucceed = commandRunner true + let shouldFail = commandRunner false + + shouldSucceed "" List.isEmpty + shouldSucceed "-p a" (List.isEmpty >> not) + shouldFail "-p a" List.isEmpty diff --git a/src/Tests/Tests.fsproj b/src/Tests/Tests.fsproj index 701f2dd..048c08d 100644 --- a/src/Tests/Tests.fsproj +++ b/src/Tests/Tests.fsproj @@ -17,6 +17,7 @@ + From 083fcb70abff2e3c2dc507a6d1ae19d8793e66d8 Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Fri, 4 Sep 2026 15:35:17 +0800 Subject: [PATCH 02/15] chore: fix accidental removal of typar --- src/FSharp.SystemCommandLine/Inputs.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index 5e59cc3..ef26062 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -6,7 +6,7 @@ open System.CommandLine module private MaybeParser = /// Parses an argument token value. /// TODO: Ideally, this should use the S.CL Arugment parser. - let parseTokenValue (tokenValue: string) = + let parseTokenValue<'T> (tokenValue: string) = match typeof<'T> with | t when t = typeof -> IO.DirectoryInfo(tokenValue) |> unbox<'T> |> Some | t when t = typeof -> IO.FileInfo(tokenValue) |> unbox<'T> |> Some From 374059853abed017f462d981c740c8acf9c7e9b8 Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Fri, 4 Sep 2026 15:38:46 +0800 Subject: [PATCH 03/15] chore: relocate type helper to header --- src/FSharp.SystemCommandLine/Inputs.fs | 96 +++++++++++++------------- 1 file changed, 48 insertions(+), 48 deletions(-) diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index ef26062..01585a0 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -13,6 +13,54 @@ module private MaybeParser = | t when t = typeof -> Uri(tokenValue) |> unbox<'T> |> Some | t -> Convert.ChangeType(tokenValue, t) :?> 'T |> Some +type private SafeInputLists = + static member private dynamicParser<'T>(): Parsing.ArgumentResult -> Array = + fun result -> + let typ = typeof<'T> + let count = result.Tokens.Count + let elementType = + if typ.GetElementType() = null + then typ.GetGenericArguments()[0] + else typ.GetElementType() + + let dynamicArray = Array.CreateInstance(elementType, count) + for i, token in result.Tokens |> Seq.indexed do + dynamicArray.SetValue(Convert.ChangeType(token.Value, elementType), i) + dynamicArray + + static member protect<'T>(o: Argument<'T>) = + match typeof<'T> with + | typ when typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> -> + o.Arity <- ArgumentArity (0, 100_000) + o.CustomParser <- (SafeInputLists.dynamicParser<'T>() >> fun dynamicArray -> + let modl = typeof>.Assembly.GetType("Microsoft.FSharp.Collections.ListModule") + let meth = modl.GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + meth.MakeGenericMethod(typeof<'T>.GetGenericArguments()[0]).Invoke(null, [| dynamicArray |] ) |> unbox + ) + o.DefaultValueFactory <- (fun _ -> + let emptyProperty = typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + if emptyProperty <> null then emptyProperty.GetValue(null) |> unbox + else failwithf $"Could not find Empty property on type %s{typ.FullName}." + ) + o + | _ -> o + static member protect<'T>(o: Option<'T>) = + match typeof<'T> with + | typ when typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> -> + o.Arity <- ArgumentArity (0, 100_000) + o.CustomParser <- (SafeInputLists.dynamicParser<'T>() >> fun dynamicArray -> + let modl = typeof>.Assembly.GetType("Microsoft.FSharp.Collections.ListModule") + let meth = modl.GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + meth.MakeGenericMethod(typeof<'T>.GetGenericArguments()[0]).Invoke(null, [| dynamicArray |] ) |> unbox + ) + o.DefaultValueFactory <- (fun _ -> + let emptyProperty = typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + if emptyProperty <> null then emptyProperty.GetValue(null) |> unbox + else failwithf $"Could not find Empty property on type %s{typ.FullName}." + ) + o + | _ -> o + /// A custom action context that contains the `ParseResult` and a cancellation token. type ActionContext = { @@ -174,54 +222,6 @@ module Input = let recursive (input: ActionInput<'T>) = input |> editOption (fun o -> o.Recursive <- true) - - type private SafeInputLists = - static member private dynamicParser<'T>(): Parsing.ArgumentResult -> Array = - fun result -> - let typ = typeof<'T> - let count = result.Tokens.Count - let elementType = - if typ.GetElementType() = null - then typ.GetGenericArguments()[0] - else typ.GetElementType() - - let dynamicArray = Array.CreateInstance(elementType, count) - for i, token in result.Tokens |> Seq.indexed do - dynamicArray.SetValue(Convert.ChangeType(token.Value, elementType), i) - dynamicArray - - static member protect<'T>(o: Argument<'T>) = - match typeof<'T> with - | typ when typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> -> - o.Arity <- ArgumentArity (0, 100_000) - o.CustomParser <- (SafeInputLists.dynamicParser<'T>() >> fun dynamicArray -> - let modl = typeof>.Assembly.GetType("Microsoft.FSharp.Collections.ListModule") - let meth = modl.GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) - meth.MakeGenericMethod(typeof<'T>.GetGenericArguments()[0]).Invoke(null, [| dynamicArray |] ) |> unbox - ) - o.DefaultValueFactory <- (fun _ -> - let emptyProperty = typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) - if emptyProperty <> null then emptyProperty.GetValue(null) |> unbox - else failwithf $"Could not find Empty property on type %s{typ.FullName}." - ) - o - | _ -> o - static member protect<'T>(o: Option<'T>) = - match typeof<'T> with - | typ when typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> -> - o.Arity <- ArgumentArity (0, 100_000) - o.CustomParser <- (SafeInputLists.dynamicParser<'T>() >> fun dynamicArray -> - let modl = typeof>.Assembly.GetType("Microsoft.FSharp.Collections.ListModule") - let meth = modl.GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) - meth.MakeGenericMethod(typeof<'T>.GetGenericArguments()[0]).Invoke(null, [| dynamicArray |] ) |> unbox - ) - o.DefaultValueFactory <- (fun _ -> - let emptyProperty = typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) - if emptyProperty <> null then emptyProperty.GetValue(null) |> unbox - else failwithf $"Could not find Empty property on type %s{typ.FullName}." - ) - o - | _ -> o /// Creates a named option. Example: `option "--file-name"` let option<'T> (name: string) = From 7ba3f0f48be85d3ebda93945d44ad442dc01bb00 Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Fri, 4 Sep 2026 15:41:12 +0800 Subject: [PATCH 04/15] chore(docs): add note vis-a-vis GetElementType vs GetGenericArguments for dynamicParser --- src/FSharp.SystemCommandLine/Inputs.fs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index 01585a0..75fd4bd 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -19,8 +19,11 @@ type private SafeInputLists = let typ = typeof<'T> let count = result.Tokens.Count let elementType = + // if list is empty, then element type will return null if typ.GetElementType() = null + // use the generic arg passed to the generic type definition then typ.GetGenericArguments()[0] + // otherwise, we use the element type else typ.GetElementType() let dynamicArray = Array.CreateInstance(elementType, count) From f60aa8e4a8dd5c5cd6b6ff3dd018610c28e349fd Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Fri, 4 Sep 2026 09:03:46 +0800 Subject: [PATCH 05/15] chore(docs): Remove comment artifact for argument required --- src/FSharp.SystemCommandLine/Inputs.fs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index 75fd4bd..2a89042 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -220,7 +220,6 @@ module Input = input |> editOption (fun o -> o.Required <- true) - /// Marks an argument as required. /// When set to true, this option will be applied to its immediate parent command or commands and recursively to their subcommands. let recursive (input: ActionInput<'T>) = input From 2706b89612d76845bcfc9de15e2f75ad6a0f6d86 Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Fri, 4 Sep 2026 09:47:20 +0800 Subject: [PATCH 06/15] feat: 4 new functions for accepting a known set of values bound to a typed value (acceptOnlyFromChoices, acceptOnlyFromChoicesWith, acceptManyFromChoices, acceptManyFromChoicesWith, acceptOnlyFromChoicesIgnoreCase, acceptManyFromChoicesIgnoreCase) --- src/FSharp.SystemCommandLine/Inputs.fs | 67 ++++++++++++++++++++++++++ 1 file changed, 67 insertions(+) diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index 2a89042..69a4ad5 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -362,6 +362,73 @@ module Input = argResult.AddError(err) Unchecked.defaultof<'T> ) + + /// Maps an option whose legal values are a known set bound to a typed value. The parser closes over the table + /// when the input is built, and nothing downstream can reach back into the closure. Does not modify arity (ie + /// you will still need to set it manually) + let acceptManyFromChoicesWith (comparer: StringComparer) (choices: seq) (input: ActionInput<'T list>) = + let keys = choices |> Seq.map fst + let legal = keys |> String.concat ", " + let lookup token = choices |> Seq.tryFind (fun (key, _) -> comparer.Equals(key, token)) |> Option.map snd + let caseSensitive = not (comparer.Equals ("a", "A")) + if caseSensitive then + // acceptOnlyFromAmong always compares strings ordinally + acceptOnlyFromAmong keys input + else + // if not case sensitive, we will add the keys to the completion sources; the parser will validate them + editOption (fun opt -> for key in keys do opt.CompletionSources.Add key) input + |> editArgument (fun arg -> for key in keys do arg.CompletionSources.Add key) + |> tryParse (fun argResult -> + argResult.Tokens + |> Seq.fold (fun (acc, errs) token -> + match lookup token.Value with + | Some value -> value :: acc, errs + | None -> acc, $"'%s{token.Value}' is not a valid choice from: %s{legal}" :: errs + ) ([], []) + |> function + | values, [] -> Ok values + | _, errs -> Error (String.concat "\n" errs) + ) + + /// Maps an option whose legal values are a known set bound to a typed value. The parser closes over the table + /// when the input is built, and nothing downstream can reach back into the closure. + let acceptOnlyFromChoicesWith (comparer: StringComparer) (choices: seq) (input: ActionInput<'T>) = + let keys = choices |> Seq.map fst + let legal = keys |> String.concat ", " + let lookup token = choices |> Seq.tryFind (fun (key, _) -> comparer.Equals(key, token)) |> Option.map snd + let caseSensitive = not (comparer.Equals ("a", "A")) + if caseSensitive then + // acceptOnlyFromAmong always compares strings ordinally + acceptOnlyFromAmong keys input + else + // if not case sensitive, we will add the keys to the completion sources; the parser will validate them + editOption (fun opt -> for key in keys do opt.CompletionSources.Add key) input + |> editArgument (fun arg -> for key in keys do arg.CompletionSources.Add key) + |> tryParse (fun argResult -> + match argResult.Tokens |> Seq.tryLast with + | None -> Error $"'%s{argResult.Argument.Name}' needs one of: %s{legal}" + | Some token -> + match lookup token.Value with + | Some value -> Ok value + | None -> Error $"'%s{token.Value}' is not a valid choice from: %s{legal}" + ) + + /// Maps an option whose legal values are a known set bound to a typed value. Case sensitive. + let acceptOnlyFromChoices (choices: seq) (input: ActionInput<'T>) = + acceptOnlyFromChoicesWith StringComparer.Ordinal choices input + + /// Maps an option whose legal values are a known set bound to a typed value. Case sensitive. + let acceptManyFromChoices (choices: seq) (input: ActionInput<'T list>) = + acceptManyFromChoicesWith StringComparer.Ordinal choices input + + /// Maps an option whose legal values are a known set bound to a typed value. Case insensitive. + let acceptOnlyFromChoicesIgnoreCase (choices: seq) (input: ActionInput<'T>) = + acceptOnlyFromChoicesWith StringComparer.OrdinalIgnoreCase choices input + + /// Maps an option whose legal values are a known set bound to a typed value. Case insensitive. + let acceptManyFromChoicesIgnoreCase (choices: seq) (input: ActionInput<'T list>) = + acceptManyFromChoicesWith StringComparer.OrdinalIgnoreCase choices input + /// Sets the arity of an option or argument. let arity (arity: Arity) (input: ActionInput<'T>) = From 8039ac4c3537fe35354780fea6ebd966aace20a1 Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Fri, 4 Sep 2026 10:05:37 +0800 Subject: [PATCH 07/15] chore(docs): new utilities do not explicitly set arity --- src/FSharp.SystemCommandLine/Inputs.fs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index 69a4ad5..9d4c3ee 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -418,6 +418,7 @@ module Input = acceptOnlyFromChoicesWith StringComparer.Ordinal choices input /// Maps an option whose legal values are a known set bound to a typed value. Case sensitive. + /// Does not modify arity. let acceptManyFromChoices (choices: seq) (input: ActionInput<'T list>) = acceptManyFromChoicesWith StringComparer.Ordinal choices input @@ -426,6 +427,7 @@ module Input = acceptOnlyFromChoicesWith StringComparer.OrdinalIgnoreCase choices input /// Maps an option whose legal values are a known set bound to a typed value. Case insensitive. + /// Does not modify arity. let acceptManyFromChoicesIgnoreCase (choices: seq) (input: ActionInput<'T list>) = acceptManyFromChoicesWith StringComparer.OrdinalIgnoreCase choices input From a2d4023631bff8542a00d496f64aebd97bff14e6 Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Fri, 4 Sep 2026 12:23:12 +0800 Subject: [PATCH 08/15] feat(fscl): mapFromAmong and mapFromAmongWith for mapping input string to typed value Added tests; and bullet points in readme.md Tests demonstrate failing, correct, and undefined behaviours. --- src/FSharp.SystemCommandLine/Inputs.fs | 67 +++---------- src/Tests/MapFromAmongTest.fs | 127 +++++++++++++++++++++++++ src/Tests/Tests.fsproj | 1 + 3 files changed, 140 insertions(+), 55 deletions(-) create mode 100644 src/Tests/MapFromAmongTest.fs diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index 9d4c3ee..ea3ddd3 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -363,47 +363,18 @@ module Input = Unchecked.defaultof<'T> ) - /// Maps an option whose legal values are a known set bound to a typed value. The parser closes over the table - /// when the input is built, and nothing downstream can reach back into the closure. Does not modify arity (ie - /// you will still need to set it manually) - let acceptManyFromChoicesWith (comparer: StringComparer) (choices: seq) (input: ActionInput<'T list>) = - let keys = choices |> Seq.map fst - let legal = keys |> String.concat ", " - let lookup token = choices |> Seq.tryFind (fun (key, _) -> comparer.Equals(key, token)) |> Option.map snd - let caseSensitive = not (comparer.Equals ("a", "A")) - if caseSensitive then - // acceptOnlyFromAmong always compares strings ordinally - acceptOnlyFromAmong keys input - else - // if not case sensitive, we will add the keys to the completion sources; the parser will validate them - editOption (fun opt -> for key in keys do opt.CompletionSources.Add key) input - |> editArgument (fun arg -> for key in keys do arg.CompletionSources.Add key) - |> tryParse (fun argResult -> - argResult.Tokens - |> Seq.fold (fun (acc, errs) token -> - match lookup token.Value with - | Some value -> value :: acc, errs - | None -> acc, $"'%s{token.Value}' is not a valid choice from: %s{legal}" :: errs - ) ([], []) - |> function - | values, [] -> Ok values - | _, errs -> Error (String.concat "\n" errs) - ) - /// Maps an option whose legal values are a known set bound to a typed value. The parser closes over the table - /// when the input is built, and nothing downstream can reach back into the closure. - let acceptOnlyFromChoicesWith (comparer: StringComparer) (choices: seq) (input: ActionInput<'T>) = + /// + /// Maps an input whose legal values are a known set bound to a typed value using the given StringComparer. + /// Caution: avoid overriding downstream with Input.tryParse. + /// + let mapFromAmongWith (comparer: StringComparer) (choices: seq) (input: ActionInput<'T>) = let keys = choices |> Seq.map fst let legal = keys |> String.concat ", " let lookup token = choices |> Seq.tryFind (fun (key, _) -> comparer.Equals(key, token)) |> Option.map snd - let caseSensitive = not (comparer.Equals ("a", "A")) - if caseSensitive then - // acceptOnlyFromAmong always compares strings ordinally - acceptOnlyFromAmong keys input - else - // if not case sensitive, we will add the keys to the completion sources; the parser will validate them - editOption (fun opt -> for key in keys do opt.CompletionSources.Add key) input - |> editArgument (fun arg -> for key in keys do arg.CompletionSources.Add key) + editOption (fun opt -> for key in keys do opt.CompletionSources.Add key) input + |> editArgument (fun arg -> for key in keys do arg.CompletionSources.Add key) + // parser closes over lookup -> nothing downstream can reach in/modify or would break. |> tryParse (fun argResult -> match argResult.Tokens |> Seq.tryLast with | None -> Error $"'%s{argResult.Argument.Name}' needs one of: %s{legal}" @@ -413,24 +384,10 @@ module Input = | None -> Error $"'%s{token.Value}' is not a valid choice from: %s{legal}" ) - /// Maps an option whose legal values are a known set bound to a typed value. Case sensitive. - let acceptOnlyFromChoices (choices: seq) (input: ActionInput<'T>) = - acceptOnlyFromChoicesWith StringComparer.Ordinal choices input - - /// Maps an option whose legal values are a known set bound to a typed value. Case sensitive. - /// Does not modify arity. - let acceptManyFromChoices (choices: seq) (input: ActionInput<'T list>) = - acceptManyFromChoicesWith StringComparer.Ordinal choices input - - /// Maps an option whose legal values are a known set bound to a typed value. Case insensitive. - let acceptOnlyFromChoicesIgnoreCase (choices: seq) (input: ActionInput<'T>) = - acceptOnlyFromChoicesWith StringComparer.OrdinalIgnoreCase choices input - - /// Maps an option whose legal values are a known set bound to a typed value. Case insensitive. - /// Does not modify arity. - let acceptManyFromChoicesIgnoreCase (choices: seq) (input: ActionInput<'T list>) = - acceptManyFromChoicesWith StringComparer.OrdinalIgnoreCase choices input - + /// Maps an input whose legal values are a known set bound to a typed value. + /// Caution: avoid overriding downstream with Input.tryParse. + let mapFromAmong (choices: seq) (input: ActionInput<'T>) = + mapFromAmongWith StringComparer.Ordinal choices input /// Sets the arity of an option or argument. let arity (arity: Arity) (input: ActionInput<'T>) = diff --git a/src/Tests/MapFromAmongTest.fs b/src/Tests/MapFromAmongTest.fs new file mode 100644 index 0000000..5a0bf5d --- /dev/null +++ b/src/Tests/MapFromAmongTest.fs @@ -0,0 +1,127 @@ +module MapFromAmongTest + + +open System +open NUnit.Framework +open Swensen.Unquote +open FSharp.SystemCommandLine +open Utils +open Input + +let mutable actionCalled = false +let callAction() = actionCalled <- true +[] +let setup () = actionCalled <- false + +type DUType = + | A + | B + +let duChoices = [ + "a", A + B.ToString() (* "B" *), B +] + +[] +let ``01 - mapFromAmong requires input``() = + let input = + option "--du" |> mapFromAmong duChoices + testRootCommand "--du" { + description "Test" + inputs input + setAction (ignore >> callAction) + } <>! 0 + actionCalled <>! true + +[] +let ``02 - mapFromAmong returns correct typed DU value``() = + let input = option "--du" |> mapFromAmong duChoices + let compareAgainst (shouldSucceed: bool): string -> DUType -> unit = fun cmd v -> + testRootCommand cmd { + description "Test" + inputs input + setAction (fun o -> + if shouldSucceed + then o =! v |> callAction; 0 + else o <>! v; 1 + ) + } + |> if shouldSucceed then (=!) 0 else (<>!) 0 + actionCalled =! shouldSucceed + actionCalled <- false + let shouldSucceed = compareAgainst true + let shouldFail = compareAgainst false + // valid casing + shouldSucceed "--du a" A + shouldSucceed "--du B" B + // invalid casing + shouldFail "--du A" A + shouldFail "--du b" B + // invalid input + shouldFail "--du c" A + shouldFail "--du c" B + // invalid map + shouldFail "--du a" B + shouldFail "--du B" A + + +[] +let ``03 - mapFromAmongWith returns correct typed DU - case insensitive``() = + let input = option "--du" |> mapFromAmongWith StringComparer.OrdinalIgnoreCase duChoices + let compareAgainst (shouldSucceed: bool): string -> DUType -> unit = fun cmd v -> + testRootCommand cmd { + description "Test" + inputs input + setAction (fun o -> + if shouldSucceed + then o =! v |> callAction; 0 + else o <>! v; 1 + ) + } + |> if shouldSucceed then (=!) 0 else (<>!) 0 + actionCalled =! shouldSucceed + actionCalled <- false + let shouldSucceed = compareAgainst true + let shouldFail = compareAgainst false + shouldSucceed "--du a" A + shouldSucceed "--du A" A + shouldSucceed "--du b" B + shouldSucceed "--du B" B + // invalid input + shouldFail "--du c" A + shouldFail "--du c" B + // invalid map + shouldFail "--du a" B + shouldFail "--du B" A + +[] +let ``04 - mapFromAmong followed by different tryParse will override``() = + let input = option "--du" |> mapFromAmong duChoices |> tryParse (fun _ -> Ok A) + let compareAgainst (shouldSucceed: bool): string -> DUType -> unit = fun cmd v -> + testRootCommand cmd { + description "Test" + inputs input + setAction (fun o -> + if shouldSucceed + then o =! v |> callAction; 0 + else o <>! v; 1 + ) + } + |> if shouldSucceed then (=!) 0 else (<>!) 0 + actionCalled =! shouldSucceed + actionCalled <- false + let shouldSucceed = compareAgainst true + let shouldFail = compareAgainst false + shouldSucceed "--du a" A + shouldSucceed "--du A" A + shouldSucceed "--du b" A + shouldSucceed "--du B" A + shouldFail "--du a" B + shouldFail "--du A" B + shouldFail "--du b" B + shouldFail "--du B" B + // invalid input still processes + // completions will still show correctly + // undefined behaviour + shouldSucceed "--du c" A + shouldFail "--du c" B diff --git a/src/Tests/Tests.fsproj b/src/Tests/Tests.fsproj index 048c08d..d7700c0 100644 --- a/src/Tests/Tests.fsproj +++ b/src/Tests/Tests.fsproj @@ -17,6 +17,7 @@ + From 804d34bd8779092d8f48b158b4f9e84a2d4e66b4 Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Fri, 4 Sep 2026 12:27:26 +0800 Subject: [PATCH 09/15] chore(readme): forgot to `:w` --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index bf96625..c71386b 100644 --- a/README.md +++ b/README.md @@ -213,6 +213,8 @@ The new `Input` module contains functions for the underlying System.CommandLine * `validateDirectoryExists` ensures that the `DirectoryInfo` exists * `addValidator` allows you to add a validator to the underlying `Option` or `Argument` * `acceptOnlyFromAmong` validates the allowed values for an `Option` or `Argument` +* `mapFromAmong` validates allowed values against `string * 'T` tuples, providing the typed value +* `mapFromAmongWith` validates allowed values against `string * 'T` tuples using a given `StringComparer` * `customParser` allows you to parse the input tokens using a custom parser function. * `tryParse` allows you to parse the input tokens using a custom parser `Result<'T, string>` function. * `arity` sets the arity of an `Option` or `Argument` From 51440784fbfce57f0097546a17fd67d64c79d986 Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Fri, 4 Sep 2026 12:35:01 +0800 Subject: [PATCH 10/15] chore(readme): added example at end in details --- README.md | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/README.md b/README.md index c71386b..5d59374 100644 --- a/README.md +++ b/README.md @@ -784,6 +784,42 @@ Notes about invocation: +
+ Mapping to a bound set of typed values + +Use `Input.mapFromAmong` to map string inputs to typed values: + +```F# +open FSharp.SystemCommandLine +type Configuration = + | Debug + | Release + +let config = + Input.option + |> Input.mapFromAmong [ + "r", Release; "release", Release + "R", Release; "Release", Release + "d", Debug; "debug", Debug + "D", Debug; "Debug", Debug + ] + // is required unless you provide a default + +// use `Input.mapFromAmongWith` to pass a custom string comparer! + +let config = + Input.option + |> Input.mapFromAmongWith StringComparer.OrdinalIgnoreCase [ + "r", Release; "release", Release + "d", Debug; "debug", Debug + ] +``` + +Notes about overriding properties: +* `Input.tryParse` will overwrite the configuration from `.mapFromAmong` if it is used downstream. + +
+ --- ## Configuration From cdc27727c50ed1865c991fd06487c774c3e84091 Mon Sep 17 00:00:00 2001 From: Jordan Marr Date: Tue, 8 Sep 2026 18:34:21 -0400 Subject: [PATCH 11/15] Tidy mapFromAmong docs and tests after #37 - README example was missing the option name argument - Drop the "tryParse overrides mapFromAmong" note, remarks, and the test asserting that undefined behaviour - Reword doc comments with inline examples Co-Authored-By: Claude Fable 5.1 Claude-Session: https://claude.ai/code/session_01PsmkZPCobsju7AauvVH8du --- README.md | 7 ++---- src/FSharp.SystemCommandLine/Inputs.fs | 12 ++++------ src/Tests/MapFromAmongTest.fs | 32 -------------------------- 3 files changed, 7 insertions(+), 44 deletions(-) diff --git a/README.md b/README.md index 5d59374..03403ca 100644 --- a/README.md +++ b/README.md @@ -796,7 +796,7 @@ type Configuration = | Release let config = - Input.option + Input.option "--config" |> Input.mapFromAmong [ "r", Release; "release", Release "R", Release; "Release", Release @@ -808,16 +808,13 @@ let config = // use `Input.mapFromAmongWith` to pass a custom string comparer! let config = - Input.option + Input.option "--config" |> Input.mapFromAmongWith StringComparer.OrdinalIgnoreCase [ "r", Release; "release", Release "d", Debug; "debug", Debug ] ``` -Notes about overriding properties: -* `Input.tryParse` will overwrite the configuration from `.mapFromAmong` if it is used downstream. - --- diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index ea3ddd3..3e5723f 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -1,4 +1,4 @@ -namespace FSharp.SystemCommandLine +namespace FSharp.SystemCommandLine open System open System.CommandLine @@ -364,10 +364,8 @@ module Input = ) - /// - /// Maps an input whose legal values are a known set bound to a typed value using the given StringComparer. - /// Caution: avoid overriding downstream with Input.tryParse. - /// + /// Maps an input whose legal values are a known set of strings, each bound to a typed value, using the given `StringComparer`. + /// Example: `option "--env" |> mapFromAmongWith StringComparer.OrdinalIgnoreCase [ "dev", Dev; "prod", Prod ]` let mapFromAmongWith (comparer: StringComparer) (choices: seq) (input: ActionInput<'T>) = let keys = choices |> Seq.map fst let legal = keys |> String.concat ", " @@ -384,8 +382,8 @@ module Input = | None -> Error $"'%s{token.Value}' is not a valid choice from: %s{legal}" ) - /// Maps an input whose legal values are a known set bound to a typed value. - /// Caution: avoid overriding downstream with Input.tryParse. + /// Maps an input whose legal values are a known set of strings, each bound to a typed value (case-sensitive). + /// Example: `option "--env" |> mapFromAmong [ "dev", Dev; "prod", Prod ]` let mapFromAmong (choices: seq) (input: ActionInput<'T>) = mapFromAmongWith StringComparer.Ordinal choices input diff --git a/src/Tests/MapFromAmongTest.fs b/src/Tests/MapFromAmongTest.fs index 5a0bf5d..b70674e 100644 --- a/src/Tests/MapFromAmongTest.fs +++ b/src/Tests/MapFromAmongTest.fs @@ -93,35 +93,3 @@ let ``03 - mapFromAmongWith returns correct typed DU - case insensitive``() = // invalid map shouldFail "--du a" B shouldFail "--du B" A - -[] -let ``04 - mapFromAmong followed by different tryParse will override``() = - let input = option "--du" |> mapFromAmong duChoices |> tryParse (fun _ -> Ok A) - let compareAgainst (shouldSucceed: bool): string -> DUType -> unit = fun cmd v -> - testRootCommand cmd { - description "Test" - inputs input - setAction (fun o -> - if shouldSucceed - then o =! v |> callAction; 0 - else o <>! v; 1 - ) - } - |> if shouldSucceed then (=!) 0 else (<>!) 0 - actionCalled =! shouldSucceed - actionCalled <- false - let shouldSucceed = compareAgainst true - let shouldFail = compareAgainst false - shouldSucceed "--du a" A - shouldSucceed "--du A" A - shouldSucceed "--du b" A - shouldSucceed "--du B" A - shouldFail "--du a" B - shouldFail "--du A" B - shouldFail "--du b" B - shouldFail "--du B" B - // invalid input still processes - // completions will still show correctly - // undefined behaviour - shouldSucceed "--du c" A - shouldFail "--du c" B From 2768ebfd2e1981090627898fd472109a8fb30615 Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Fri, 4 Sep 2026 15:33:43 +0800 Subject: [PATCH 12/15] feat: safe handling of list actioninputs --- src/FSharp.SystemCommandLine/Inputs.fs | 50 +++++++++++++++++++++++++- 1 file changed, 49 insertions(+), 1 deletion(-) diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index 3e5723f..def9756 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -6,7 +6,7 @@ open System.CommandLine module private MaybeParser = /// Parses an argument token value. /// TODO: Ideally, this should use the S.CL Arugment parser. - let parseTokenValue<'T> (tokenValue: string) = + let parseTokenValue (tokenValue: string) = match typeof<'T> with | t when t = typeof -> IO.DirectoryInfo(tokenValue) |> unbox<'T> |> Some | t when t = typeof -> IO.FileInfo(tokenValue) |> unbox<'T> |> Some @@ -224,6 +224,54 @@ module Input = let recursive (input: ActionInput<'T>) = input |> editOption (fun o -> o.Recursive <- true) + + type private SafeInputLists = + static member private dynamicParser<'T>(): Parsing.ArgumentResult -> Array = + fun result -> + let typ = typeof<'T> + let count = result.Tokens.Count + let elementType = + if typ.GetElementType() = null + then typ.GetGenericArguments()[0] + else typ.GetElementType() + + let dynamicArray = Array.CreateInstance(elementType, count) + for i, token in result.Tokens |> Seq.indexed do + dynamicArray.SetValue(Convert.ChangeType(token.Value, elementType), i) + dynamicArray + + static member protect<'T>(o: Argument<'T>) = + match typeof<'T> with + | typ when typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> -> + o.Arity <- ArgumentArity (0, 100_000) + o.CustomParser <- (SafeInputLists.dynamicParser<'T>() >> fun dynamicArray -> + let modl = typeof>.Assembly.GetType("Microsoft.FSharp.Collections.ListModule") + let meth = modl.GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + meth.MakeGenericMethod(typeof<'T>.GetGenericArguments()[0]).Invoke(null, [| dynamicArray |] ) |> unbox + ) + o.DefaultValueFactory <- (fun _ -> + let emptyProperty = typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + if emptyProperty <> null then emptyProperty.GetValue(null) |> unbox + else failwithf $"Could not find Empty property on type %s{typ.FullName}." + ) + o + | _ -> o + static member protect<'T>(o: Option<'T>) = + match typeof<'T> with + | typ when typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> -> + o.Arity <- ArgumentArity (0, 100_000) + o.CustomParser <- (SafeInputLists.dynamicParser<'T>() >> fun dynamicArray -> + let modl = typeof>.Assembly.GetType("Microsoft.FSharp.Collections.ListModule") + let meth = modl.GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + meth.MakeGenericMethod(typeof<'T>.GetGenericArguments()[0]).Invoke(null, [| dynamicArray |] ) |> unbox + ) + o.DefaultValueFactory <- (fun _ -> + let emptyProperty = typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + if emptyProperty <> null then emptyProperty.GetValue(null) |> unbox + else failwithf $"Could not find Empty property on type %s{typ.FullName}." + ) + o + | _ -> o /// Creates a named option. Example: `option "--file-name"` let option<'T> (name: string) = From f5418e182f4250b367b8739b1d224298aae5aa51 Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Thu, 10 Sep 2026 14:25:53 +0800 Subject: [PATCH 13/15] fix: cleanup of list handling 1. Conversion errors route through AddError 2. List protection routes through SRTP overloads 3. Tests cover option(int list), option(string list), argument(int list), argument(string list) --- src/FSharp.SystemCommandLine/Inputs.fs | 170 ++++++++++--------------- src/Tests/ListOptionTest.fs | 71 ++++++++++- 2 files changed, 136 insertions(+), 105 deletions(-) diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index def9756..4dd6c6e 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -6,63 +6,76 @@ open System.CommandLine module private MaybeParser = /// Parses an argument token value. /// TODO: Ideally, this should use the S.CL Arugment parser. - let parseTokenValue (tokenValue: string) = + let parseTokenValue<'T> (tokenValue: string) = match typeof<'T> with | t when t = typeof -> IO.DirectoryInfo(tokenValue) |> unbox<'T> |> Some | t when t = typeof -> IO.FileInfo(tokenValue) |> unbox<'T> |> Some | t when t = typeof -> Uri(tokenValue) |> unbox<'T> |> Some | t -> Convert.ChangeType(tokenValue, t) :?> 'T |> Some +/// Short alias used in SafeInputLists for constraints and delegate construction. +type private ParseFunc<'T> = Func type private SafeInputLists = - static member private dynamicParser<'T>(): Parsing.ArgumentResult -> Array = - fun result -> - let typ = typeof<'T> + static let ofArrayInfo = + typeof> + .Assembly + .GetType("Microsoft.FSharp.Collections.ListModule") + .GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + static let ofArrayForType (typ: Type) (elements: Array) = + ofArrayInfo.MakeGenericMethod(typ.GetGenericArguments()[0]).Invoke(null, [| elements |]) + static let listElementType (typ: Type) = + // naive tests show more predictable behaviour + // with the presence of this branch + match typ.GetElementType() with + | null -> typ.GetGenericArguments()[0] + | typ -> typ + static let makeEmptyList (typ: Type) = + match typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) with + | null -> Error $"Could not find Empty property on type %s{typ.FullName}." + | prop -> prop.GetValue(null) |> Ok + static let isListGeneric (typ: Type) = + typ.IsGenericType + && typ.GetGenericTypeDefinition() = typedefof> + static member inline private dynamicParser<^T, ^U + when ^U:(member set_DefaultValueFactory: ParseFunc<^T> -> unit) + and ^U:(member set_CustomParser: ParseFunc<^T> -> unit) + and ^U:(member set_Arity: ArgumentArity -> unit)> + (o: ^U) = + let typ = typeof<'T> + if not <| isListGeneric typ then () else + let elementType = listElementType typ + let changeType: Parsing.Token -> obj = + // we cannot use MaybeParser.parseTokenValue here because + // we only have the reflected System.Type object, not the + // actual typar. + match elementType with + | t when t = typeof -> _.Value >> fun s -> IO.DirectoryInfo(s) :> obj + | t when t = typeof -> _.Value >> fun s -> IO.FileInfo(s) :> obj + | t when t = typeof -> _.Value >> fun s -> Uri(s) :> obj + | t -> _.Value >> fun s -> Convert.ChangeType(s, t) + let ofArray = ofArrayForType typ + let empty = makeEmptyList typ + ParseFunc(fun result -> + match empty with + | Error err -> + result.AddError err + Unchecked.defaultof<'T> + | Ok empty -> empty |> unbox<'T>) + |> o.set_DefaultValueFactory + ParseFunc(fun result -> let count = result.Tokens.Count - let elementType = - // if list is empty, then element type will return null - if typ.GetElementType() = null - // use the generic arg passed to the generic type definition - then typ.GetGenericArguments()[0] - // otherwise, we use the element type - else typ.GetElementType() - let dynamicArray = Array.CreateInstance(elementType, count) for i, token in result.Tokens |> Seq.indexed do - dynamicArray.SetValue(Convert.ChangeType(token.Value, elementType), i) - dynamicArray - - static member protect<'T>(o: Argument<'T>) = - match typeof<'T> with - | typ when typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> -> - o.Arity <- ArgumentArity (0, 100_000) - o.CustomParser <- (SafeInputLists.dynamicParser<'T>() >> fun dynamicArray -> - let modl = typeof>.Assembly.GetType("Microsoft.FSharp.Collections.ListModule") - let meth = modl.GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) - meth.MakeGenericMethod(typeof<'T>.GetGenericArguments()[0]).Invoke(null, [| dynamicArray |] ) |> unbox - ) - o.DefaultValueFactory <- (fun _ -> - let emptyProperty = typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) - if emptyProperty <> null then emptyProperty.GetValue(null) |> unbox - else failwithf $"Could not find Empty property on type %s{typ.FullName}." - ) - o - | _ -> o - static member protect<'T>(o: Option<'T>) = - match typeof<'T> with - | typ when typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> -> - o.Arity <- ArgumentArity (0, 100_000) - o.CustomParser <- (SafeInputLists.dynamicParser<'T>() >> fun dynamicArray -> - let modl = typeof>.Assembly.GetType("Microsoft.FSharp.Collections.ListModule") - let meth = modl.GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) - meth.MakeGenericMethod(typeof<'T>.GetGenericArguments()[0]).Invoke(null, [| dynamicArray |] ) |> unbox - ) - o.DefaultValueFactory <- (fun _ -> - let emptyProperty = typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) - if emptyProperty <> null then emptyProperty.GetValue(null) |> unbox - else failwithf $"Could not find Empty property on type %s{typ.FullName}." - ) - o - | _ -> o + try + dynamicArray.SetValue(changeType token, i) + // should this be more permissive? + with :? FormatException as e -> result.AddError e.Message + ofArray dynamicArray |> unbox<'T>) + |> o.set_CustomParser + ArgumentArity(0, 100_000) + |> o.set_Arity + static member protect<'T>(o: Argument<'T>) = SafeInputLists.dynamicParser<'T, _> o; o + static member protect<'T>(o: Option<'T>) = SafeInputLists.dynamicParser<'T, _> o; o /// A custom action context that contains the `ParseResult` and a cancellation token. type ActionContext = @@ -140,7 +153,7 @@ type Arity = | _ -> ArgumentArity (argumentArity.MinimumNumberOfValues, argumentArity.MaximumNumberOfValues) -module Input = +module Input = /// Injects an `ActionContext` into the action which contains the `ParseResult` and a cancellation token. let context = @@ -150,6 +163,11 @@ module Input = let inject<'T> (value: 'T) = ActionInput<'T>(Injection (box value)) + /// Creates a named option. Example: `option "--file-name"` + let option<'T> (name: string) = + Option<'T>(name) + |> SafeInputLists.protect + |> ActionInput.OfOption /// Edits the underlying System.CommandLine.Option<'T>. let editOption (edit: Option<'T> -> unit) (input: ActionInput<'T>) = @@ -224,61 +242,7 @@ module Input = let recursive (input: ActionInput<'T>) = input |> editOption (fun o -> o.Recursive <- true) - - type private SafeInputLists = - static member private dynamicParser<'T>(): Parsing.ArgumentResult -> Array = - fun result -> - let typ = typeof<'T> - let count = result.Tokens.Count - let elementType = - if typ.GetElementType() = null - then typ.GetGenericArguments()[0] - else typ.GetElementType() - - let dynamicArray = Array.CreateInstance(elementType, count) - for i, token in result.Tokens |> Seq.indexed do - dynamicArray.SetValue(Convert.ChangeType(token.Value, elementType), i) - dynamicArray - - static member protect<'T>(o: Argument<'T>) = - match typeof<'T> with - | typ when typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> -> - o.Arity <- ArgumentArity (0, 100_000) - o.CustomParser <- (SafeInputLists.dynamicParser<'T>() >> fun dynamicArray -> - let modl = typeof>.Assembly.GetType("Microsoft.FSharp.Collections.ListModule") - let meth = modl.GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) - meth.MakeGenericMethod(typeof<'T>.GetGenericArguments()[0]).Invoke(null, [| dynamicArray |] ) |> unbox - ) - o.DefaultValueFactory <- (fun _ -> - let emptyProperty = typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) - if emptyProperty <> null then emptyProperty.GetValue(null) |> unbox - else failwithf $"Could not find Empty property on type %s{typ.FullName}." - ) - o - | _ -> o - static member protect<'T>(o: Option<'T>) = - match typeof<'T> with - | typ when typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> -> - o.Arity <- ArgumentArity (0, 100_000) - o.CustomParser <- (SafeInputLists.dynamicParser<'T>() >> fun dynamicArray -> - let modl = typeof>.Assembly.GetType("Microsoft.FSharp.Collections.ListModule") - let meth = modl.GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) - meth.MakeGenericMethod(typeof<'T>.GetGenericArguments()[0]).Invoke(null, [| dynamicArray |] ) |> unbox - ) - o.DefaultValueFactory <- (fun _ -> - let emptyProperty = typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) - if emptyProperty <> null then emptyProperty.GetValue(null) |> unbox - else failwithf $"Could not find Empty property on type %s{typ.FullName}." - ) - o - | _ -> o - /// Creates a named option. Example: `option "--file-name"` - let option<'T> (name: string) = - Option<'T>(name) - |> SafeInputLists.protect<'T> - |> ActionInput.OfOption<'T> - /// Creates a named option of type `Option<'T option>` that defaults to `None`. let optionMaybe<'T> (name: string) = let o = Option<'T option>(name, aliases = [||]) @@ -319,7 +283,7 @@ module Input = /// Creates a named argument. Example: `argument "file-name"` let argument<'T> (name: string) = Argument<'T>(name) - |> SafeInputLists.protect<'T> + |> SafeInputLists.protect |> ActionInput.OfArgument<'T> /// Creates a named argument of type `Argument<'T option>` that defaults to `None`. diff --git a/src/Tests/ListOptionTest.fs b/src/Tests/ListOptionTest.fs index 30f4104..eb442de 100644 --- a/src/Tests/ListOptionTest.fs +++ b/src/Tests/ListOptionTest.fs @@ -13,8 +13,8 @@ let called() = handlerCalled <- true let setup () = handlerCalled <- false [] -let ``01 - No input to list option should be empty list``() = - let input = option "-p" |> arity Arity.ZeroOrMore +let ``01 - No input to string list option should be empty list``() = + let input = option "-p" let commandRunner (shouldSucceed: bool): string -> (string list -> bool) -> unit = fun command comp -> testRootCommand command { description "Test" @@ -33,3 +33,70 @@ let ``01 - No input to list option should be empty list``() = shouldSucceed "" List.isEmpty shouldSucceed "-p a" (List.isEmpty >> not) shouldFail "-p a" List.isEmpty + +[] +let ``02 - No input to int list option should be empty list``() = + let input = option "-p" + let commandRunner (shouldSucceed: bool): string -> (int list -> bool) -> unit = fun command comp -> + testRootCommand command { + description "Test" + inputs input + setAction (function + | values when comp values -> called(); 0 + | _ -> 1 + ) + } + |> if shouldSucceed then (=!) 0 else (<>!) 0 + handlerCalled =! shouldSucceed + handlerCalled <- false + let shouldSucceed = commandRunner true + let shouldFail = commandRunner false + + shouldSucceed "" List.isEmpty + shouldSucceed "-p 3" (List.isEmpty >> not) + shouldFail "-p a" List.isEmpty + + +[] +let ``03 - No input to string list argument should be empty list``() = + let input = argument "p" + let commandRunner (shouldSucceed: bool): string -> (string list -> bool) -> unit = fun command comp -> + testRootCommand command { + description "Test" + inputs input + setAction (function + | values when comp values -> called(); 0 + | _ -> 1 + ) + } + |> if shouldSucceed then (=!) 0 else (<>!) 0 + handlerCalled =! shouldSucceed + handlerCalled <- false + let shouldSucceed = commandRunner true + let shouldFail = commandRunner false + + shouldSucceed "" List.isEmpty + shouldSucceed "a" (List.isEmpty >> not) + shouldFail "a" List.isEmpty + +[] +let ``04 - No input to int list argument should be empty list``() = + let input = argument "p" + let commandRunner (shouldSucceed: bool): string -> (int list -> bool) -> unit = fun command comp -> + testRootCommand command { + description "Test" + inputs input + setAction (function + | values when comp values -> called(); 0 + | _ -> 1 + ) + } + |> if shouldSucceed then (=!) 0 else (<>!) 0 + handlerCalled =! shouldSucceed + handlerCalled <- false + let shouldSucceed = commandRunner true + let shouldFail = commandRunner false + + shouldSucceed "" List.isEmpty + shouldSucceed "3" (List.isEmpty >> not) + shouldFail "a" List.isEmpty From ac314ed9cc482f4751f5ea1569d6f40146b9d346 Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Thu, 10 Sep 2026 14:36:26 +0800 Subject: [PATCH 14/15] fix: compose logic for maybeparser --- src/FSharp.SystemCommandLine/Inputs.fs | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index 4dd6c6e..371d7b2 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -3,15 +3,18 @@ namespace FSharp.SystemCommandLine open System open System.CommandLine -module private MaybeParser = +module private MaybeParser = + let parseTokenValueForType (typ: Type) (tokenValue: string) = + match typ with + | t when t = typeof -> IO.DirectoryInfo(tokenValue) :> obj + | t when t = typeof -> IO.FileInfo(tokenValue) + | t when t = typeof -> Uri(tokenValue) + | t -> Convert.ChangeType(tokenValue, t) + /// Parses an argument token value. /// TODO: Ideally, this should use the S.CL Arugment parser. let parseTokenValue<'T> (tokenValue: string) = - match typeof<'T> with - | t when t = typeof -> IO.DirectoryInfo(tokenValue) |> unbox<'T> |> Some - | t when t = typeof -> IO.FileInfo(tokenValue) |> unbox<'T> |> Some - | t when t = typeof -> Uri(tokenValue) |> unbox<'T> |> Some - | t -> Convert.ChangeType(tokenValue, t) :?> 'T |> Some + parseTokenValueForType typeof<'T> tokenValue :?> 'T |> Some /// Short alias used in SafeInputLists for constraints and delegate construction. type private ParseFunc<'T> = Func @@ -45,14 +48,8 @@ type private SafeInputLists = if not <| isListGeneric typ then () else let elementType = listElementType typ let changeType: Parsing.Token -> obj = - // we cannot use MaybeParser.parseTokenValue here because - // we only have the reflected System.Type object, not the - // actual typar. - match elementType with - | t when t = typeof -> _.Value >> fun s -> IO.DirectoryInfo(s) :> obj - | t when t = typeof -> _.Value >> fun s -> IO.FileInfo(s) :> obj - | t when t = typeof -> _.Value >> fun s -> Uri(s) :> obj - | t -> _.Value >> fun s -> Convert.ChangeType(s, t) + let fn = MaybeParser.parseTokenValueForType elementType + _.Value >> fn let ofArray = ofArrayForType typ let empty = makeEmptyList typ ParseFunc(fun result -> From 9b44a5abfc85415bff4a5117914ecff81202d017 Mon Sep 17 00:00:00 2001 From: shayanhabibi Date: Thu, 10 Sep 2026 14:54:54 +0800 Subject: [PATCH 15/15] chore(docs): describe ops with inline comments --- src/FSharp.SystemCommandLine/Inputs.fs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/FSharp.SystemCommandLine/Inputs.fs b/src/FSharp.SystemCommandLine/Inputs.fs index 371d7b2..6b1f27e 100644 --- a/src/FSharp.SystemCommandLine/Inputs.fs +++ b/src/FSharp.SystemCommandLine/Inputs.fs @@ -4,6 +4,7 @@ open System open System.CommandLine module private MaybeParser = + /// Parses an argument token value to the given type. let parseTokenValueForType (typ: Type) (tokenValue: string) = match typ with | t when t = typeof -> IO.DirectoryInfo(tokenValue) :> obj @@ -19,39 +20,50 @@ module private MaybeParser = /// Short alias used in SafeInputLists for constraints and delegate construction. type private ParseFunc<'T> = Func type private SafeInputLists = + // bound generic `List.OfArray` method static let ofArrayInfo = typeof> .Assembly .GetType("Microsoft.FSharp.Collections.ListModule") .GetMethod("OfArray", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) + // invokes `List.OfArray` with the given array using the provided type as the element type static let ofArrayForType (typ: Type) (elements: Array) = ofArrayInfo.MakeGenericMethod(typ.GetGenericArguments()[0]).Invoke(null, [| elements |]) + // safely retrieves the element type of a list type static let listElementType (typ: Type) = // naive tests show more predictable behaviour // with the presence of this branch match typ.GetElementType() with | null -> typ.GetGenericArguments()[0] | typ -> typ + // retrieves the `List.Empty` property for the given element type generic static let makeEmptyList (typ: Type) = match typ.GetProperty("Empty", System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.Public) with | null -> Error $"Could not find Empty property on type %s{typ.FullName}." | prop -> prop.GetValue(null) |> Ok + // determines whether provided type is a generic `list` type static let isListGeneric (typ: Type) = typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof> static member inline private dynamicParser<^T, ^U + // static binding of Option<_> and Argument<_> + // where T is the typar for U: the generic Option/Argument when ^U:(member set_DefaultValueFactory: ParseFunc<^T> -> unit) and ^U:(member set_CustomParser: ParseFunc<^T> -> unit) and ^U:(member set_Arity: ArgumentArity -> unit)> (o: ^U) = let typ = typeof<'T> + // if not a list, noop if not <| isListGeneric typ then () else let elementType = listElementType typ + // parses token to element type let changeType: Parsing.Token -> obj = let fn = MaybeParser.parseTokenValueForType elementType _.Value >> fn + // converts array to final list type let ofArray = ofArrayForType typ let empty = makeEmptyList typ + // Default Value Factory -> List.Empty ParseFunc(fun result -> match empty with | Error err -> @@ -59,6 +71,7 @@ type private SafeInputLists = Unchecked.defaultof<'T> | Ok empty -> empty |> unbox<'T>) |> o.set_DefaultValueFactory + // Custom Parser -> tokens -> Array -> List.OfArray ParseFunc(fun result -> let count = result.Tokens.Count let dynamicArray = Array.CreateInstance(elementType, count) @@ -71,7 +84,11 @@ type private SafeInputLists = |> o.set_CustomParser ArgumentArity(0, 100_000) |> o.set_Arity + /// Checks `'T` for a `List<_>` generic type. Injects list compatible CustomParser and DefaultValueFactory + /// if `true`; noop if `false` static member protect<'T>(o: Argument<'T>) = SafeInputLists.dynamicParser<'T, _> o; o + /// Checks `'T` for a `List<_>` generic type. Injects list compatible CustomParser and DefaultValueFactory + /// if `true`; noop if `false` static member protect<'T>(o: Option<'T>) = SafeInputLists.dynamicParser<'T, _> o; o /// A custom action context that contains the `ParseResult` and a cancellation token.