diff --git a/ConsumePlugin/Args.fs b/ConsumePlugin/Args.fs new file mode 100644 index 0000000..0b68947 --- /dev/null +++ b/ConsumePlugin/Args.fs @@ -0,0 +1,95 @@ +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +[] +type BasicNoPositionals = + { + Foo : int + Bar : string + Baz : bool + Rest : int list + } + +[] +type Basic = + { + [] + Foo : int + Bar : string + Baz : bool + [] + [] + Rest : string list + } + +[] +type BasicWithIntPositionals = + { + Foo : int + Bar : string + Baz : bool + [] + Rest : int list + } + +[] +type LoadsOfTypes = + { + Foo : int + Bar : string + Baz : bool + SomeFile : FileInfo + SomeDirectory : DirectoryInfo + SomeList : DirectoryInfo list + OptionalThingWithNoDefault : int option + [] + Positionals : int list + [] + OptionalThing : Choice + [] + AnotherOptionalThing : Choice + [] + YetAnotherOptionalThing : Choice + } + + static member DefaultOptionalThing () = true + + static member DefaultAnotherOptionalThing () = 3 + +[] +type LoadsOfTypesNoPositionals = + { + Foo : int + Bar : string + Baz : bool + SomeFile : FileInfo + SomeDirectory : DirectoryInfo + SomeList : DirectoryInfo list + OptionalThingWithNoDefault : int option + [] + OptionalThing : Choice + [] + AnotherOptionalThing : Choice + [] + YetAnotherOptionalThing : Choice + } + + static member DefaultOptionalThing () = false + + static member DefaultAnotherOptionalThing () = 3 + +[] +type DatesAndTimes = + { + Plain : TimeSpan + [] + Invariant : TimeSpan + [] + [] + Exact : TimeSpan + [] + InvariantExact : TimeSpan + } diff --git a/ConsumePlugin/ConsumePlugin.fsproj b/ConsumePlugin/ConsumePlugin.fsproj index b7efaeb..32f118a 100644 --- a/ConsumePlugin/ConsumePlugin.fsproj +++ b/ConsumePlugin/ConsumePlugin.fsproj @@ -52,6 +52,10 @@ List.fs + + + Args.fs + diff --git a/ConsumePlugin/GeneratedArgs.fs b/ConsumePlugin/GeneratedArgs.fs new file mode 100644 index 0000000..f8e02ef --- /dev/null +++ b/ConsumePlugin/GeneratedArgs.fs @@ -0,0 +1,1579 @@ +//------------------------------------------------------------------------------ +// This code was generated by myriad. +// Changes to this file will be lost when the code is regenerated. +//------------------------------------------------------------------------------ + + + + + + +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type BasicNoPositionals +[] +module BasicNoPositionals = + type private ParseState_BasicNoPositionals = + | AwaitingKey + | AwaitingValue of key : string + + let parse' (getEnvironmentVariable : string -> string) (args : string list) : BasicNoPositionals = + let ArgParser_errors = ResizeArray () + + let helpText () = + [ + (sprintf "--foo int32%s%s" "" "") + (sprintf "--bar string%s%s" "" "") + (sprintf "--baz bool%s%s" "" "") + (sprintf "--rest int32%s%s" " (can be repeated)" "") + ] + |> String.concat "\n" + + let parser_LeftoverArgs : string ResizeArray = ResizeArray () + let mutable Foo : int option = None + let mutable Bar : string option = None + let mutable Baz : bool option = None + let Rest : int ResizeArray = ResizeArray () + + /// Processes the key-value pair, returning Error if no key was matched. + /// If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(). + /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. + let processKeyValue (key : string) (value : string) : Result = + if System.String.Equals (key, "--rest", System.StringComparison.OrdinalIgnoreCase) then + (fun x -> System.Int32.Parse x) value |> Rest.Add + () |> Ok + else if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then + match Baz with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--baz" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Baz <- value |> (fun x -> System.Boolean.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--bar", System.StringComparison.OrdinalIgnoreCase) then + match Bar with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--bar" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Bar <- value |> (fun x -> x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--foo", System.StringComparison.OrdinalIgnoreCase) then + match Foo with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--foo" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Foo <- value |> (fun x -> System.Int32.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else + Error None + + /// Returns false if we didn't set a value. + let setFlagValue (key : string) : bool = + if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then + match Baz with + | Some x -> + sprintf "Flag '%s' was supplied multiple times" "--baz" |> ArgParser_errors.Add + true + | None -> + Baz <- Some true + true + else + false + + let rec go (state : ParseState_BasicNoPositionals) (args : string list) = + match args with + | [] -> + match state with + | ParseState_BasicNoPositionals.AwaitingKey -> () + | ParseState_BasicNoPositionals.AwaitingValue key -> + if setFlagValue key then + () + else + sprintf + "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." + key + |> ArgParser_errors.Add + | "--" :: rest -> parser_LeftoverArgs.AddRange (rest |> Seq.map (fun x -> x)) + | arg :: args -> + match state with + | ParseState_BasicNoPositionals.AwaitingKey -> + if arg.StartsWith ("--", System.StringComparison.Ordinal) then + if arg = "--help" then + helpText () |> failwithf "Help text requested.\n%s" + else + let equals = arg.IndexOf (char 61) + + if equals < 0 then + args |> go (ParseState_BasicNoPositionals.AwaitingValue arg) + else + let key = arg.[0 .. equals - 1] + let value = arg.[equals + 1 ..] + + match processKeyValue key value with + | Ok () -> go ParseState_BasicNoPositionals.AwaitingKey args + | Error None -> + failwithf "Unable to process argument %s as key %s and value %s" arg key value + | Error (Some msg) -> + sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add + go ParseState_BasicNoPositionals.AwaitingKey args + else + arg |> (fun x -> x) |> parser_LeftoverArgs.Add + go ParseState_BasicNoPositionals.AwaitingKey args + | ParseState_BasicNoPositionals.AwaitingValue key -> + match processKeyValue key arg with + | Ok () -> go ParseState_BasicNoPositionals.AwaitingKey args + | Error exc -> + if setFlagValue key then + go ParseState_BasicNoPositionals.AwaitingKey (arg :: args) + else + match exc with + | None -> + failwithf "Unable to process supplied arg %s. Help text follows.\n%s" key (helpText ()) + | Some msg -> msg |> ArgParser_errors.Add + + go ParseState_BasicNoPositionals.AwaitingKey args + + let parser_LeftoverArgs = + if 0 = parser_LeftoverArgs.Count then + () + else + parser_LeftoverArgs + |> String.concat " " + |> sprintf "There were leftover args: %s" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + + let Foo = + match Foo with + | None -> + sprintf "Required argument '%s' received no value" "--foo" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Bar = + match Bar with + | None -> + sprintf "Required argument '%s' received no value" "--bar" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Baz = + match Baz with + | None -> + sprintf "Required argument '%s' received no value" "--baz" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Rest = Rest |> Seq.toList + + if 0 = ArgParser_errors.Count then + { + Foo = Foo + Bar = Bar + Baz = Baz + Rest = Rest + } + else + ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + let parse (args : string list) : BasicNoPositionals = + parse' System.Environment.GetEnvironmentVariable args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type Basic +[] +module Basic = + type private ParseState_Basic = + | AwaitingKey + | AwaitingValue of key : string + + let parse' (getEnvironmentVariable : string -> string) (args : string list) : Basic = + let ArgParser_errors = ResizeArray () + + let helpText () = + [ + (sprintf "--foo int32%s%s" "" (sprintf " : %s" ("This is a foo!"))) + (sprintf "--bar string%s%s" "" "") + (sprintf "--baz bool%s%s" "" "") + (sprintf + "--rest string (positional args)%s%s" + " (can be repeated)" + (sprintf " : %s" ("Here's where the rest of the args go"))) + ] + |> String.concat "\n" + + let Rest : string ResizeArray = ResizeArray () + let mutable Foo : int option = None + let mutable Bar : string option = None + let mutable Baz : bool option = None + + /// Processes the key-value pair, returning Error if no key was matched. + /// If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(). + /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. + let processKeyValue (key : string) (value : string) : Result = + if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then + match Baz with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--baz" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Baz <- value |> (fun x -> System.Boolean.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--bar", System.StringComparison.OrdinalIgnoreCase) then + match Bar with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--bar" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Bar <- value |> (fun x -> x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--foo", System.StringComparison.OrdinalIgnoreCase) then + match Foo with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--foo" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Foo <- value |> (fun x -> System.Int32.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--rest", System.StringComparison.OrdinalIgnoreCase) then + (fun x -> x) value |> Rest.Add + () |> Ok + else + Error None + + /// Returns false if we didn't set a value. + let setFlagValue (key : string) : bool = + if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then + match Baz with + | Some x -> + sprintf "Flag '%s' was supplied multiple times" "--baz" |> ArgParser_errors.Add + true + | None -> + Baz <- Some true + true + else + false + + let rec go (state : ParseState_Basic) (args : string list) = + match args with + | [] -> + match state with + | ParseState_Basic.AwaitingKey -> () + | ParseState_Basic.AwaitingValue key -> + if setFlagValue key then + () + else + sprintf + "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." + key + |> ArgParser_errors.Add + | "--" :: rest -> Rest.AddRange (rest |> Seq.map (fun x -> x)) + | arg :: args -> + match state with + | ParseState_Basic.AwaitingKey -> + if arg.StartsWith ("--", System.StringComparison.Ordinal) then + if arg = "--help" then + helpText () |> failwithf "Help text requested.\n%s" + else + let equals = arg.IndexOf (char 61) + + if equals < 0 then + args |> go (ParseState_Basic.AwaitingValue arg) + else + let key = arg.[0 .. equals - 1] + let value = arg.[equals + 1 ..] + + match processKeyValue key value with + | Ok () -> go ParseState_Basic.AwaitingKey args + | Error None -> + failwithf "Unable to process argument %s as key %s and value %s" arg key value + | Error (Some msg) -> + sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add + go ParseState_Basic.AwaitingKey args + else + arg |> (fun x -> x) |> Rest.Add + go ParseState_Basic.AwaitingKey args + | ParseState_Basic.AwaitingValue key -> + match processKeyValue key arg with + | Ok () -> go ParseState_Basic.AwaitingKey args + | Error exc -> + if setFlagValue key then + go ParseState_Basic.AwaitingKey (arg :: args) + else + match exc with + | None -> + failwithf "Unable to process supplied arg %s. Help text follows.\n%s" key (helpText ()) + | Some msg -> msg |> ArgParser_errors.Add + + go ParseState_Basic.AwaitingKey args + let Rest = Rest |> Seq.toList + + let Foo = + match Foo with + | None -> + sprintf "Required argument '%s' received no value" "--foo" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Bar = + match Bar with + | None -> + sprintf "Required argument '%s' received no value" "--bar" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Baz = + match Baz with + | None -> + sprintf "Required argument '%s' received no value" "--baz" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + if 0 = ArgParser_errors.Count then + { + Rest = Rest + Foo = Foo + Bar = Bar + Baz = Baz + } + else + ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + let parse (args : string list) : Basic = + parse' System.Environment.GetEnvironmentVariable args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type BasicWithIntPositionals +[] +module BasicWithIntPositionals = + type private ParseState_BasicWithIntPositionals = + | AwaitingKey + | AwaitingValue of key : string + + let parse' (getEnvironmentVariable : string -> string) (args : string list) : BasicWithIntPositionals = + let ArgParser_errors = ResizeArray () + + let helpText () = + [ + (sprintf "--foo int32%s%s" "" "") + (sprintf "--bar string%s%s" "" "") + (sprintf "--baz bool%s%s" "" "") + (sprintf "--rest int32 (positional args)%s%s" " (can be repeated)" "") + ] + |> String.concat "\n" + + let Rest : int ResizeArray = ResizeArray () + let mutable Foo : int option = None + let mutable Bar : string option = None + let mutable Baz : bool option = None + + /// Processes the key-value pair, returning Error if no key was matched. + /// If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(). + /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. + let processKeyValue (key : string) (value : string) : Result = + if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then + match Baz with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--baz" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Baz <- value |> (fun x -> System.Boolean.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--bar", System.StringComparison.OrdinalIgnoreCase) then + match Bar with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--bar" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Bar <- value |> (fun x -> x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--foo", System.StringComparison.OrdinalIgnoreCase) then + match Foo with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--foo" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Foo <- value |> (fun x -> System.Int32.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--rest", System.StringComparison.OrdinalIgnoreCase) then + (fun x -> System.Int32.Parse x) value |> Rest.Add + () |> Ok + else + Error None + + /// Returns false if we didn't set a value. + let setFlagValue (key : string) : bool = + if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then + match Baz with + | Some x -> + sprintf "Flag '%s' was supplied multiple times" "--baz" |> ArgParser_errors.Add + true + | None -> + Baz <- Some true + true + else + false + + let rec go (state : ParseState_BasicWithIntPositionals) (args : string list) = + match args with + | [] -> + match state with + | ParseState_BasicWithIntPositionals.AwaitingKey -> () + | ParseState_BasicWithIntPositionals.AwaitingValue key -> + if setFlagValue key then + () + else + sprintf + "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." + key + |> ArgParser_errors.Add + | "--" :: rest -> Rest.AddRange (rest |> Seq.map (fun x -> System.Int32.Parse x)) + | arg :: args -> + match state with + | ParseState_BasicWithIntPositionals.AwaitingKey -> + if arg.StartsWith ("--", System.StringComparison.Ordinal) then + if arg = "--help" then + helpText () |> failwithf "Help text requested.\n%s" + else + let equals = arg.IndexOf (char 61) + + if equals < 0 then + args |> go (ParseState_BasicWithIntPositionals.AwaitingValue arg) + else + let key = arg.[0 .. equals - 1] + let value = arg.[equals + 1 ..] + + match processKeyValue key value with + | Ok () -> go ParseState_BasicWithIntPositionals.AwaitingKey args + | Error None -> + failwithf "Unable to process argument %s as key %s and value %s" arg key value + | Error (Some msg) -> + sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add + go ParseState_BasicWithIntPositionals.AwaitingKey args + else + arg |> (fun x -> System.Int32.Parse x) |> Rest.Add + go ParseState_BasicWithIntPositionals.AwaitingKey args + | ParseState_BasicWithIntPositionals.AwaitingValue key -> + match processKeyValue key arg with + | Ok () -> go ParseState_BasicWithIntPositionals.AwaitingKey args + | Error exc -> + if setFlagValue key then + go ParseState_BasicWithIntPositionals.AwaitingKey (arg :: args) + else + match exc with + | None -> + failwithf "Unable to process supplied arg %s. Help text follows.\n%s" key (helpText ()) + | Some msg -> msg |> ArgParser_errors.Add + + go ParseState_BasicWithIntPositionals.AwaitingKey args + let Rest = Rest |> Seq.toList + + let Foo = + match Foo with + | None -> + sprintf "Required argument '%s' received no value" "--foo" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Bar = + match Bar with + | None -> + sprintf "Required argument '%s' received no value" "--bar" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Baz = + match Baz with + | None -> + sprintf "Required argument '%s' received no value" "--baz" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + if 0 = ArgParser_errors.Count then + { + Rest = Rest + Foo = Foo + Bar = Bar + Baz = Baz + } + else + ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + let parse (args : string list) : BasicWithIntPositionals = + parse' System.Environment.GetEnvironmentVariable args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type LoadsOfTypes +[] +module LoadsOfTypes = + type private ParseState_LoadsOfTypes = + | AwaitingKey + | AwaitingValue of key : string + + let parse' (getEnvironmentVariable : string -> string) (args : string list) : LoadsOfTypes = + let ArgParser_errors = ResizeArray () + + let helpText () = + [ + (sprintf "--foo int32%s%s" "" "") + (sprintf "--bar string%s%s" "" "") + (sprintf "--baz bool%s%s" "" "") + (sprintf "--some-file FileInfo%s%s" "" "") + (sprintf "--some-directory DirectoryInfo%s%s" "" "") + (sprintf "--some-list DirectoryInfo%s%s" " (can be repeated)" "") + (sprintf "--optional-thing-with-no-default int32%s%s" " (optional)" "") + + (sprintf + "--optional-thing bool%s%s" + (LoadsOfTypes.DefaultOptionalThing () |> sprintf " (default value: %O)") + "") + + (sprintf + "--another-optional-thing int32%s%s" + (LoadsOfTypes.DefaultAnotherOptionalThing () |> sprintf " (default value: %O)") + "") + + (sprintf + "--yet-another-optional-thing string%s%s" + ("CONSUMEPLUGIN_THINGS" |> sprintf " (default value populated from env var %s)") + "") + (sprintf "--positionals int32 (positional args)%s%s" " (can be repeated)" "") + ] + |> String.concat "\n" + + let Positionals : int ResizeArray = ResizeArray () + let mutable Foo : int option = None + let mutable Bar : string option = None + let mutable Baz : bool option = None + let mutable SomeFile : FileInfo option = None + let mutable SomeDirectory : DirectoryInfo option = None + let SomeList : DirectoryInfo ResizeArray = ResizeArray () + let mutable OptionalThingWithNoDefault : int option = None + let mutable OptionalThing : bool option = None + let mutable AnotherOptionalThing : int option = None + let mutable YetAnotherOptionalThing : string option = None + + /// Processes the key-value pair, returning Error if no key was matched. + /// If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(). + /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. + let processKeyValue (key : string) (value : string) : Result = + if + System.String.Equals (key, "--yet-another-optional-thing", System.StringComparison.OrdinalIgnoreCase) + then + match YetAnotherOptionalThing with + | Some x -> + sprintf + "Argument '%s' was supplied multiple times: %O and %O" + "--yet-another-optional-thing" + x + value + |> ArgParser_errors.Add + + Ok () + | None -> + try + YetAnotherOptionalThing <- value |> (fun x -> x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if + System.String.Equals (key, "--another-optional-thing", System.StringComparison.OrdinalIgnoreCase) + then + match AnotherOptionalThing with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--another-optional-thing" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + AnotherOptionalThing <- value |> (fun x -> System.Int32.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--optional-thing", System.StringComparison.OrdinalIgnoreCase) then + match OptionalThing with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--optional-thing" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + OptionalThing <- value |> (fun x -> System.Boolean.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if + System.String.Equals ( + key, + "--optional-thing-with-no-default", + System.StringComparison.OrdinalIgnoreCase + ) + then + match OptionalThingWithNoDefault with + | Some x -> + sprintf + "Argument '%s' was supplied multiple times: %O and %O" + "--optional-thing-with-no-default" + x + value + |> ArgParser_errors.Add + + Ok () + | None -> + try + OptionalThingWithNoDefault <- value |> (fun x -> System.Int32.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--some-list", System.StringComparison.OrdinalIgnoreCase) then + (fun x -> System.IO.DirectoryInfo x) value |> SomeList.Add + () |> Ok + else if System.String.Equals (key, "--some-directory", System.StringComparison.OrdinalIgnoreCase) then + match SomeDirectory with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--some-directory" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + SomeDirectory <- value |> (fun x -> System.IO.DirectoryInfo x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--some-file", System.StringComparison.OrdinalIgnoreCase) then + match SomeFile with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--some-file" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + SomeFile <- value |> (fun x -> System.IO.FileInfo x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then + match Baz with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--baz" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Baz <- value |> (fun x -> System.Boolean.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--bar", System.StringComparison.OrdinalIgnoreCase) then + match Bar with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--bar" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Bar <- value |> (fun x -> x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--foo", System.StringComparison.OrdinalIgnoreCase) then + match Foo with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--foo" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Foo <- value |> (fun x -> System.Int32.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--positionals", System.StringComparison.OrdinalIgnoreCase) then + (fun x -> System.Int32.Parse x) value |> Positionals.Add + () |> Ok + else + Error None + + /// Returns false if we didn't set a value. + let setFlagValue (key : string) : bool = + if System.String.Equals (key, "--optional-thing", System.StringComparison.OrdinalIgnoreCase) then + match OptionalThing with + | Some x -> + sprintf "Flag '%s' was supplied multiple times" "--optional-thing" + |> ArgParser_errors.Add + + true + | None -> + OptionalThing <- Some true + true + else if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then + match Baz with + | Some x -> + sprintf "Flag '%s' was supplied multiple times" "--baz" |> ArgParser_errors.Add + true + | None -> + Baz <- Some true + true + else + false + + let rec go (state : ParseState_LoadsOfTypes) (args : string list) = + match args with + | [] -> + match state with + | ParseState_LoadsOfTypes.AwaitingKey -> () + | ParseState_LoadsOfTypes.AwaitingValue key -> + if setFlagValue key then + () + else + sprintf + "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." + key + |> ArgParser_errors.Add + | "--" :: rest -> Positionals.AddRange (rest |> Seq.map (fun x -> System.Int32.Parse x)) + | arg :: args -> + match state with + | ParseState_LoadsOfTypes.AwaitingKey -> + if arg.StartsWith ("--", System.StringComparison.Ordinal) then + if arg = "--help" then + helpText () |> failwithf "Help text requested.\n%s" + else + let equals = arg.IndexOf (char 61) + + if equals < 0 then + args |> go (ParseState_LoadsOfTypes.AwaitingValue arg) + else + let key = arg.[0 .. equals - 1] + let value = arg.[equals + 1 ..] + + match processKeyValue key value with + | Ok () -> go ParseState_LoadsOfTypes.AwaitingKey args + | Error None -> + failwithf "Unable to process argument %s as key %s and value %s" arg key value + | Error (Some msg) -> + sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add + go ParseState_LoadsOfTypes.AwaitingKey args + else + arg |> (fun x -> System.Int32.Parse x) |> Positionals.Add + go ParseState_LoadsOfTypes.AwaitingKey args + | ParseState_LoadsOfTypes.AwaitingValue key -> + match processKeyValue key arg with + | Ok () -> go ParseState_LoadsOfTypes.AwaitingKey args + | Error exc -> + if setFlagValue key then + go ParseState_LoadsOfTypes.AwaitingKey (arg :: args) + else + match exc with + | None -> + failwithf "Unable to process supplied arg %s. Help text follows.\n%s" key (helpText ()) + | Some msg -> msg |> ArgParser_errors.Add + + go ParseState_LoadsOfTypes.AwaitingKey args + let Positionals = Positionals |> Seq.toList + + let Foo = + match Foo with + | None -> + sprintf "Required argument '%s' received no value" "--foo" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Bar = + match Bar with + | None -> + sprintf "Required argument '%s' received no value" "--bar" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Baz = + match Baz with + | None -> + sprintf "Required argument '%s' received no value" "--baz" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let SomeFile = + match SomeFile with + | None -> + sprintf "Required argument '%s' received no value" "--some-file" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let SomeDirectory = + match SomeDirectory with + | None -> + sprintf "Required argument '%s' received no value" "--some-directory" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let SomeList = SomeList |> Seq.toList + let OptionalThingWithNoDefault = OptionalThingWithNoDefault + + let OptionalThing = + match OptionalThing with + | None -> LoadsOfTypes.DefaultOptionalThing () |> Choice2Of2 + | Some x -> Choice1Of2 x + + let AnotherOptionalThing = + match AnotherOptionalThing with + | None -> LoadsOfTypes.DefaultAnotherOptionalThing () |> Choice2Of2 + | Some x -> Choice1Of2 x + + let YetAnotherOptionalThing = + match YetAnotherOptionalThing with + | None -> + match "CONSUMEPLUGIN_THINGS" |> getEnvironmentVariable with + | null -> + sprintf + "No value was supplied for %s, nor was environment variable %s set" + "--yet-another-optional-thing" + "CONSUMEPLUGIN_THINGS" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | x -> x |> (fun x -> x) + |> Choice2Of2 + | Some x -> Choice1Of2 x + + if 0 = ArgParser_errors.Count then + { + Positionals = Positionals + Foo = Foo + Bar = Bar + Baz = Baz + SomeFile = SomeFile + SomeDirectory = SomeDirectory + SomeList = SomeList + OptionalThingWithNoDefault = OptionalThingWithNoDefault + OptionalThing = OptionalThing + AnotherOptionalThing = AnotherOptionalThing + YetAnotherOptionalThing = YetAnotherOptionalThing + } + else + ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + let parse (args : string list) : LoadsOfTypes = + parse' System.Environment.GetEnvironmentVariable args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type LoadsOfTypesNoPositionals +[] +module LoadsOfTypesNoPositionals = + type private ParseState_LoadsOfTypesNoPositionals = + | AwaitingKey + | AwaitingValue of key : string + + let parse' (getEnvironmentVariable : string -> string) (args : string list) : LoadsOfTypesNoPositionals = + let ArgParser_errors = ResizeArray () + + let helpText () = + [ + (sprintf "--foo int32%s%s" "" "") + (sprintf "--bar string%s%s" "" "") + (sprintf "--baz bool%s%s" "" "") + (sprintf "--some-file FileInfo%s%s" "" "") + (sprintf "--some-directory DirectoryInfo%s%s" "" "") + (sprintf "--some-list DirectoryInfo%s%s" " (can be repeated)" "") + (sprintf "--optional-thing-with-no-default int32%s%s" " (optional)" "") + + (sprintf + "--optional-thing bool%s%s" + (LoadsOfTypesNoPositionals.DefaultOptionalThing () + |> sprintf " (default value: %O)") + "") + + (sprintf + "--another-optional-thing int32%s%s" + (LoadsOfTypesNoPositionals.DefaultAnotherOptionalThing () + |> sprintf " (default value: %O)") + "") + (sprintf + "--yet-another-optional-thing string%s%s" + ("CONSUMEPLUGIN_THINGS" |> sprintf " (default value populated from env var %s)") + "") + ] + |> String.concat "\n" + + let parser_LeftoverArgs : string ResizeArray = ResizeArray () + let mutable Foo : int option = None + let mutable Bar : string option = None + let mutable Baz : bool option = None + let mutable SomeFile : FileInfo option = None + let mutable SomeDirectory : DirectoryInfo option = None + let SomeList : DirectoryInfo ResizeArray = ResizeArray () + let mutable OptionalThingWithNoDefault : int option = None + let mutable OptionalThing : bool option = None + let mutable AnotherOptionalThing : int option = None + let mutable YetAnotherOptionalThing : string option = None + + /// Processes the key-value pair, returning Error if no key was matched. + /// If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(). + /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. + let processKeyValue (key : string) (value : string) : Result = + if + System.String.Equals (key, "--yet-another-optional-thing", System.StringComparison.OrdinalIgnoreCase) + then + match YetAnotherOptionalThing with + | Some x -> + sprintf + "Argument '%s' was supplied multiple times: %O and %O" + "--yet-another-optional-thing" + x + value + |> ArgParser_errors.Add + + Ok () + | None -> + try + YetAnotherOptionalThing <- value |> (fun x -> x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if + System.String.Equals (key, "--another-optional-thing", System.StringComparison.OrdinalIgnoreCase) + then + match AnotherOptionalThing with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--another-optional-thing" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + AnotherOptionalThing <- value |> (fun x -> System.Int32.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--optional-thing", System.StringComparison.OrdinalIgnoreCase) then + match OptionalThing with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--optional-thing" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + OptionalThing <- value |> (fun x -> System.Boolean.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if + System.String.Equals ( + key, + "--optional-thing-with-no-default", + System.StringComparison.OrdinalIgnoreCase + ) + then + match OptionalThingWithNoDefault with + | Some x -> + sprintf + "Argument '%s' was supplied multiple times: %O and %O" + "--optional-thing-with-no-default" + x + value + |> ArgParser_errors.Add + + Ok () + | None -> + try + OptionalThingWithNoDefault <- value |> (fun x -> System.Int32.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--some-list", System.StringComparison.OrdinalIgnoreCase) then + (fun x -> System.IO.DirectoryInfo x) value |> SomeList.Add + () |> Ok + else if System.String.Equals (key, "--some-directory", System.StringComparison.OrdinalIgnoreCase) then + match SomeDirectory with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--some-directory" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + SomeDirectory <- value |> (fun x -> System.IO.DirectoryInfo x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--some-file", System.StringComparison.OrdinalIgnoreCase) then + match SomeFile with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--some-file" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + SomeFile <- value |> (fun x -> System.IO.FileInfo x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then + match Baz with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--baz" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Baz <- value |> (fun x -> System.Boolean.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--bar", System.StringComparison.OrdinalIgnoreCase) then + match Bar with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--bar" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Bar <- value |> (fun x -> x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--foo", System.StringComparison.OrdinalIgnoreCase) then + match Foo with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--foo" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Foo <- value |> (fun x -> System.Int32.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else + Error None + + /// Returns false if we didn't set a value. + let setFlagValue (key : string) : bool = + if System.String.Equals (key, "--optional-thing", System.StringComparison.OrdinalIgnoreCase) then + match OptionalThing with + | Some x -> + sprintf "Flag '%s' was supplied multiple times" "--optional-thing" + |> ArgParser_errors.Add + + true + | None -> + OptionalThing <- Some true + true + else if System.String.Equals (key, "--baz", System.StringComparison.OrdinalIgnoreCase) then + match Baz with + | Some x -> + sprintf "Flag '%s' was supplied multiple times" "--baz" |> ArgParser_errors.Add + true + | None -> + Baz <- Some true + true + else + false + + let rec go (state : ParseState_LoadsOfTypesNoPositionals) (args : string list) = + match args with + | [] -> + match state with + | ParseState_LoadsOfTypesNoPositionals.AwaitingKey -> () + | ParseState_LoadsOfTypesNoPositionals.AwaitingValue key -> + if setFlagValue key then + () + else + sprintf + "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." + key + |> ArgParser_errors.Add + | "--" :: rest -> parser_LeftoverArgs.AddRange (rest |> Seq.map (fun x -> x)) + | arg :: args -> + match state with + | ParseState_LoadsOfTypesNoPositionals.AwaitingKey -> + if arg.StartsWith ("--", System.StringComparison.Ordinal) then + if arg = "--help" then + helpText () |> failwithf "Help text requested.\n%s" + else + let equals = arg.IndexOf (char 61) + + if equals < 0 then + args |> go (ParseState_LoadsOfTypesNoPositionals.AwaitingValue arg) + else + let key = arg.[0 .. equals - 1] + let value = arg.[equals + 1 ..] + + match processKeyValue key value with + | Ok () -> go ParseState_LoadsOfTypesNoPositionals.AwaitingKey args + | Error None -> + failwithf "Unable to process argument %s as key %s and value %s" arg key value + | Error (Some msg) -> + sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add + go ParseState_LoadsOfTypesNoPositionals.AwaitingKey args + else + arg |> (fun x -> x) |> parser_LeftoverArgs.Add + go ParseState_LoadsOfTypesNoPositionals.AwaitingKey args + | ParseState_LoadsOfTypesNoPositionals.AwaitingValue key -> + match processKeyValue key arg with + | Ok () -> go ParseState_LoadsOfTypesNoPositionals.AwaitingKey args + | Error exc -> + if setFlagValue key then + go ParseState_LoadsOfTypesNoPositionals.AwaitingKey (arg :: args) + else + match exc with + | None -> + failwithf "Unable to process supplied arg %s. Help text follows.\n%s" key (helpText ()) + | Some msg -> msg |> ArgParser_errors.Add + + go ParseState_LoadsOfTypesNoPositionals.AwaitingKey args + + let parser_LeftoverArgs = + if 0 = parser_LeftoverArgs.Count then + () + else + parser_LeftoverArgs + |> String.concat " " + |> sprintf "There were leftover args: %s" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + + let Foo = + match Foo with + | None -> + sprintf "Required argument '%s' received no value" "--foo" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Bar = + match Bar with + | None -> + sprintf "Required argument '%s' received no value" "--bar" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Baz = + match Baz with + | None -> + sprintf "Required argument '%s' received no value" "--baz" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let SomeFile = + match SomeFile with + | None -> + sprintf "Required argument '%s' received no value" "--some-file" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let SomeDirectory = + match SomeDirectory with + | None -> + sprintf "Required argument '%s' received no value" "--some-directory" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let SomeList = SomeList |> Seq.toList + let OptionalThingWithNoDefault = OptionalThingWithNoDefault + + let OptionalThing = + match OptionalThing with + | None -> LoadsOfTypesNoPositionals.DefaultOptionalThing () |> Choice2Of2 + | Some x -> Choice1Of2 x + + let AnotherOptionalThing = + match AnotherOptionalThing with + | None -> LoadsOfTypesNoPositionals.DefaultAnotherOptionalThing () |> Choice2Of2 + | Some x -> Choice1Of2 x + + let YetAnotherOptionalThing = + match YetAnotherOptionalThing with + | None -> + match "CONSUMEPLUGIN_THINGS" |> getEnvironmentVariable with + | null -> + sprintf + "No value was supplied for %s, nor was environment variable %s set" + "--yet-another-optional-thing" + "CONSUMEPLUGIN_THINGS" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | x -> x |> (fun x -> x) + |> Choice2Of2 + | Some x -> Choice1Of2 x + + if 0 = ArgParser_errors.Count then + { + Foo = Foo + Bar = Bar + Baz = Baz + SomeFile = SomeFile + SomeDirectory = SomeDirectory + SomeList = SomeList + OptionalThingWithNoDefault = OptionalThingWithNoDefault + OptionalThing = OptionalThing + AnotherOptionalThing = AnotherOptionalThing + YetAnotherOptionalThing = YetAnotherOptionalThing + } + else + ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + let parse (args : string list) : LoadsOfTypesNoPositionals = + parse' System.Environment.GetEnvironmentVariable args +namespace ConsumePlugin + +open System +open System.IO +open WoofWare.Myriad.Plugins + +/// Methods to parse arguments for the type DatesAndTimes +[] +module DatesAndTimesArgParse = + type private ParseState_DatesAndTimes = + | AwaitingKey + | AwaitingValue of key : string + + /// Extension methods for argument parsing + type DatesAndTimes with + + static member parse' (getEnvironmentVariable : string -> string) (args : string list) : DatesAndTimes = + let ArgParser_errors = ResizeArray () + + let helpText () = + [ + (sprintf "--plain TimeSpan%s%s" "" "") + (sprintf "--invariant TimeSpan%s%s" "" "") + + (sprintf + "--exact TimeSpan%s%s" + "" + (sprintf " : %s" (sprintf "%s [Parse format (.NET): %s]" "An exact time please" @"hh\:mm\:ss"))) + (sprintf + "--invariant-exact TimeSpan%s%s" + "" + (sprintf " : %s" (sprintf "[Parse format (.NET): %s]" @"hh\:mm\:ss"))) + ] + |> String.concat "\n" + + let parser_LeftoverArgs : string ResizeArray = ResizeArray () + let mutable Plain : TimeSpan option = None + let mutable Invariant : TimeSpan option = None + let mutable Exact : TimeSpan option = None + let mutable InvariantExact : TimeSpan option = None + + /// Processes the key-value pair, returning Error if no key was matched. + /// If the key is an arg which can arity 1, but throws when consuming that arg, we return Error(). + /// This can nevertheless be a successful parse, e.g. when the key may have arity 0. + let processKeyValue (key : string) (value : string) : Result = + if System.String.Equals (key, "--invariant-exact", System.StringComparison.OrdinalIgnoreCase) then + match InvariantExact with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--invariant-exact" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + InvariantExact <- + value + |> (fun x -> + System.TimeSpan.ParseExact ( + x, + @"hh\:mm\:ss", + System.Globalization.CultureInfo.InvariantCulture + ) + ) + |> Some + + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--exact", System.StringComparison.OrdinalIgnoreCase) then + match Exact with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--exact" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Exact <- + value + |> (fun x -> + System.TimeSpan.ParseExact ( + x, + @"hh\:mm\:ss", + System.Globalization.CultureInfo.CurrentCulture + ) + ) + |> Some + + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--invariant", System.StringComparison.OrdinalIgnoreCase) then + match Invariant with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--invariant" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Invariant <- + value + |> (fun x -> + System.TimeSpan.Parse (x, System.Globalization.CultureInfo.InvariantCulture) + ) + |> Some + + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else if System.String.Equals (key, "--plain", System.StringComparison.OrdinalIgnoreCase) then + match Plain with + | Some x -> + sprintf "Argument '%s' was supplied multiple times: %O and %O" "--plain" x value + |> ArgParser_errors.Add + + Ok () + | None -> + try + Plain <- value |> (fun x -> System.TimeSpan.Parse x) |> Some + Ok () + with _ as exc -> + exc.Message |> Some |> Error + else + Error None + + /// Returns false if we didn't set a value. + let setFlagValue (key : string) : bool = false + + let rec go (state : ParseState_DatesAndTimes) (args : string list) = + match args with + | [] -> + match state with + | ParseState_DatesAndTimes.AwaitingKey -> () + | ParseState_DatesAndTimes.AwaitingValue key -> + if setFlagValue key then + () + else + sprintf + "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." + key + |> ArgParser_errors.Add + | "--" :: rest -> parser_LeftoverArgs.AddRange (rest |> Seq.map (fun x -> x)) + | arg :: args -> + match state with + | ParseState_DatesAndTimes.AwaitingKey -> + if arg.StartsWith ("--", System.StringComparison.Ordinal) then + if arg = "--help" then + helpText () |> failwithf "Help text requested.\n%s" + else + let equals = arg.IndexOf (char 61) + + if equals < 0 then + args |> go (ParseState_DatesAndTimes.AwaitingValue arg) + else + let key = arg.[0 .. equals - 1] + let value = arg.[equals + 1 ..] + + match processKeyValue key value with + | Ok () -> go ParseState_DatesAndTimes.AwaitingKey args + | Error None -> + failwithf "Unable to process argument %s as key %s and value %s" arg key value + | Error (Some msg) -> + sprintf "%s (at arg %s)" msg arg |> ArgParser_errors.Add + go ParseState_DatesAndTimes.AwaitingKey args + else + arg |> (fun x -> x) |> parser_LeftoverArgs.Add + go ParseState_DatesAndTimes.AwaitingKey args + | ParseState_DatesAndTimes.AwaitingValue key -> + match processKeyValue key arg with + | Ok () -> go ParseState_DatesAndTimes.AwaitingKey args + | Error exc -> + if setFlagValue key then + go ParseState_DatesAndTimes.AwaitingKey (arg :: args) + else + match exc with + | None -> + failwithf + "Unable to process supplied arg %s. Help text follows.\n%s" + key + (helpText ()) + | Some msg -> msg |> ArgParser_errors.Add + + go ParseState_DatesAndTimes.AwaitingKey args + + let parser_LeftoverArgs = + if 0 = parser_LeftoverArgs.Count then + () + else + parser_LeftoverArgs + |> String.concat " " + |> sprintf "There were leftover args: %s" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + + let Plain = + match Plain with + | None -> + sprintf "Required argument '%s' received no value" "--plain" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Invariant = + match Invariant with + | None -> + sprintf "Required argument '%s' received no value" "--invariant" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let Exact = + match Exact with + | None -> + sprintf "Required argument '%s' received no value" "--exact" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + let InvariantExact = + match InvariantExact with + | None -> + sprintf "Required argument '%s' received no value" "--invariant-exact" + |> ArgParser_errors.Add + + Unchecked.defaultof<_> + | Some x -> x + + if 0 = ArgParser_errors.Count then + { + Plain = Plain + Invariant = Invariant + Exact = Exact + InvariantExact = InvariantExact + } + else + ArgParser_errors |> String.concat "\n" |> failwithf "Errors during parse!\n%s" + + static member parse (args : string list) : DatesAndTimes = + DatesAndTimes.parse' System.Environment.GetEnvironmentVariable args diff --git a/README.md b/README.md index 6a1d9a4..cb45e29 100644 --- a/README.md +++ b/README.md @@ -14,6 +14,7 @@ Currently implemented: * `JsonSerialize` (to stamp out `toJsonNode : 'T -> JsonNode` methods). * `HttpClient` (to stamp out a [RestEase](https://github.com/canton7/RestEase)-style HTTP client). * `GenerateMock` (to stamp out a record type corresponding to an interface, like a compile-time [Foq](https://github.com/fsprojects/Foq)). +* `ArgParser` (to stamp out a basic argument parser) * `CreateCatamorphism` (to stamp out a non-stack-overflowing [catamorphism](https://fsharpforfunandprofit.com/posts/recursive-types-and-folds/) for a discriminated union). * `RemoveOptions` (to strip `option` modifiers from a type) - this one is particularly half-baked! @@ -150,6 +151,73 @@ The same limitations generally apply to `JsonSerialize` as do to `JsonParse`. For an example of using both `JsonParse` and `JsonSerialize` together with complex types, see [the type definitions](./ConsumePlugin/SerializationAndDeserialization.fs) and [tests](./WoofWare.Myriad.Plugins.Test/TestJsonSerialize/TestJsonSerde.fs). +## `ArgParser` + +Takes a record like this: + +```fsharp +[] +type Foo = + { + [] + SomeFlag : bool + A : int option + [] + B : Choice + [] + BWithEnv : Choice + C : float list + // optionally: + [] + Rest : string list // or e.g. `int list` if you want them parsed into a type too + } + static member DefaultB () = 4 +``` + +and stamps out a basic `parse` method of this signature: + +```fsharp +[] +module Foo = + // in case you want to test it + let parse' (getEnvVar : string -> string) (args : string list) : Foo = ... + // the one we expect you actually want to use + let parse (args : string list) : Foo = ... +``` + +Default arguments are handled as `Choice<'a, 'a>`: +you get a `Choice1Of2` if the user provided the input, or a `Choice2Of2` if the parser filled in your specified default value. + +You can control `TimeSpan` and friends with the `[]` and `[]` attributes. + +You can generate extension methods for the type, instead of a module with the type's name, using `[]`. + +If `--help` appears in a position where the parser is expecting a key (e.g. in the first position, or after a `--foo=bar`), the parser fails with help text. +The parser also makes a limited effort to supply help text when encountering an invalid parse. + +### What's the point? + +I got fed up of waiting for us to find time to rewrite the in-house one at work. +That one has a bunch of nice compositional properties, which my version lacks: +I can basically only deal with primitive types, and e.g. you can't stack records and discriminated unions inside each other. + +But I *do* want an F#-native argument parser suitable for AOT-compilation. + +Why not [Argu](https://fsprojects.github.io/Argu/)? +Answer: I got annoyed with having to construct my records by hand even after Argu returned and said the parsing was all "done". + +### Limitations + +This is very bare-bones, but do raise GitHub issues if you like (or if you find cases where the parser does the wrong thing). + +* Help is signalled by throwing an exception, so you'll get an unsightly stack trace and a nonzero exit code. +* Help doesn't take into account any arguments the user has entered. Ideally you'd get contextual information like an identification of which args the user has supplied at the point where the parse failed or help was requested. +* I don't handle very many types, and in particular a real arg parser would handle DUs and records with nesting. +* I don't try very hard to find a valid parse. It may well be possible to find a case where I fail to parse despite there existing a valid parse. +* There's no subcommand support (you'll have to do that yourself). + +It should work fine if you just want to compose a few primitive types, though. + ## `RemoveOptions` Takes a record like this: diff --git a/WoofWare.Myriad.Plugins.Attributes/ArgParserAttributes.fs b/WoofWare.Myriad.Plugins.Attributes/ArgParserAttributes.fs new file mode 100644 index 0000000..0ccd611 --- /dev/null +++ b/WoofWare.Myriad.Plugins.Attributes/ArgParserAttributes.fs @@ -0,0 +1,63 @@ +namespace WoofWare.Myriad.Plugins + +open System + +/// Attribute indicating a record type to which the "build arg parser" Myriad +/// generator should apply during build. +/// +/// If you supply isExtensionMethod = true, you will get extension methods. +/// These can only be consumed from F#, but the benefit is that they don't use up the module name +/// (since by default we create a module called "{TypeName}"). +type ArgParserAttribute (isExtensionMethod : bool) = + inherit Attribute () + + /// The default value of `isExtensionMethod`, the optional argument to the ArgParserAttribute constructor. + static member DefaultIsExtensionMethod = false + + /// Shorthand for the "isExtensionMethod = false" constructor; see documentation there for details. + new () = ArgParserAttribute ArgParserAttribute.DefaultIsExtensionMethod + +/// Attribute indicating that this field shall accumulate all unmatched args, +/// as well as any that appear after a bare `--`. +type PositionalArgsAttribute () = + inherit Attribute () + +/// Attribute indicating that this field shall have a default value derived +/// from calling an appropriately named static method on the type. +/// +/// This attribute can only be placed on fields of type `Choice<_, _>` where both type parameters +/// are the same. +/// After a successful parse, the value is Choice1Of2 if the user supplied an input, +/// or Choice2Of2 if the input was obtained by calling the default function. +/// +/// The static method we call for field `FieldName : 'a` is `DefaultFieldName : unit -> 'a`. +type ArgumentDefaultFunctionAttribute () = + inherit Attribute () + +/// Attribute indicating that this field shall have a default value derived +/// from an environment variable (whose name you give in the attribute constructor). +/// +/// This attribute can only be placed on fields of type `Choice<_, _>` where both type parameters +/// are the same. +/// After a successful parse, the value is Choice1Of2 if the user supplied an input, +/// or Choice2Of2 if the input was obtained by pulling a value from `Environment.GetEnvironmentVariable`. +type ArgumentDefaultEnvironmentVariableAttribute (envVar : string) = + inherit Attribute () + +/// Attribute indicating that this field shall have the given help text, when `--help` is invoked +/// or when a parse error causes us to print help text. +type ArgumentHelpTextAttribute (helpText : string) = + inherit Attribute () + +/// Attribute indicating that this field should be parsed with a ParseExact method on its type. +/// For example, on a TimeSpan field, with [], we will call +/// `TimeSpan.ParseExact (s, @"hh\:mm\:ss", CultureInfo.CurrentCulture). +type ParseExactAttribute (format : string) = + inherit Attribute () + +/// Attribute indicating that this field should be parsed in the invariant culture, rather than the +/// default current culture. +/// For example, on a TimeSpan field, with [] and [], we will call +/// `TimeSpan.ParseExact (s, @"hh\:mm\:ss", CultureInfo.InvariantCulture). +type InvariantCultureAttribute () = + inherit Attribute () diff --git a/WoofWare.Myriad.Plugins.Attributes/SurfaceBaseline.txt b/WoofWare.Myriad.Plugins.Attributes/SurfaceBaseline.txt index 58d4b8f..3cb4760 100644 --- a/WoofWare.Myriad.Plugins.Attributes/SurfaceBaseline.txt +++ b/WoofWare.Myriad.Plugins.Attributes/SurfaceBaseline.txt @@ -1,3 +1,14 @@ +WoofWare.Myriad.Plugins.ArgParserAttribute inherit System.Attribute +WoofWare.Myriad.Plugins.ArgParserAttribute..ctor [constructor]: bool +WoofWare.Myriad.Plugins.ArgParserAttribute..ctor [constructor]: unit +WoofWare.Myriad.Plugins.ArgParserAttribute.DefaultIsExtensionMethod [static property]: [read-only] bool +WoofWare.Myriad.Plugins.ArgParserAttribute.get_DefaultIsExtensionMethod [static method]: unit -> bool +WoofWare.Myriad.Plugins.ArgumentDefaultEnvironmentVariableAttribute inherit System.Attribute +WoofWare.Myriad.Plugins.ArgumentDefaultEnvironmentVariableAttribute..ctor [constructor]: string +WoofWare.Myriad.Plugins.ArgumentDefaultFunctionAttribute inherit System.Attribute +WoofWare.Myriad.Plugins.ArgumentDefaultFunctionAttribute..ctor [constructor]: unit +WoofWare.Myriad.Plugins.ArgumentHelpTextAttribute inherit System.Attribute +WoofWare.Myriad.Plugins.ArgumentHelpTextAttribute..ctor [constructor]: string WoofWare.Myriad.Plugins.CreateCatamorphismAttribute inherit System.Attribute WoofWare.Myriad.Plugins.CreateCatamorphismAttribute..ctor [constructor]: string WoofWare.Myriad.Plugins.GenerateMockAttribute inherit System.Attribute @@ -10,6 +21,8 @@ WoofWare.Myriad.Plugins.HttpClientAttribute..ctor [constructor]: bool WoofWare.Myriad.Plugins.HttpClientAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.HttpClientAttribute.DefaultIsExtensionMethod [static property]: [read-only] bool WoofWare.Myriad.Plugins.HttpClientAttribute.get_DefaultIsExtensionMethod [static method]: unit -> bool +WoofWare.Myriad.Plugins.InvariantCultureAttribute inherit System.Attribute +WoofWare.Myriad.Plugins.InvariantCultureAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.JsonParseAttribute inherit System.Attribute WoofWare.Myriad.Plugins.JsonParseAttribute..ctor [constructor]: bool WoofWare.Myriad.Plugins.JsonParseAttribute..ctor [constructor]: unit @@ -20,6 +33,10 @@ WoofWare.Myriad.Plugins.JsonSerializeAttribute..ctor [constructor]: bool WoofWare.Myriad.Plugins.JsonSerializeAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.JsonSerializeAttribute.DefaultIsExtensionMethod [static property]: [read-only] bool WoofWare.Myriad.Plugins.JsonSerializeAttribute.get_DefaultIsExtensionMethod [static method]: unit -> bool +WoofWare.Myriad.Plugins.ParseExactAttribute inherit System.Attribute +WoofWare.Myriad.Plugins.ParseExactAttribute..ctor [constructor]: string +WoofWare.Myriad.Plugins.PositionalArgsAttribute inherit System.Attribute +WoofWare.Myriad.Plugins.PositionalArgsAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.RemoveOptionsAttribute inherit System.Attribute WoofWare.Myriad.Plugins.RemoveOptionsAttribute..ctor [constructor]: unit WoofWare.Myriad.Plugins.RestEase inherit obj diff --git a/WoofWare.Myriad.Plugins.Attributes/WoofWare.Myriad.Plugins.Attributes.fsproj b/WoofWare.Myriad.Plugins.Attributes/WoofWare.Myriad.Plugins.Attributes.fsproj index eb8a789..b36b499 100644 --- a/WoofWare.Myriad.Plugins.Attributes/WoofWare.Myriad.Plugins.Attributes.fsproj +++ b/WoofWare.Myriad.Plugins.Attributes/WoofWare.Myriad.Plugins.Attributes.fsproj @@ -19,6 +19,7 @@ + diff --git a/WoofWare.Myriad.Plugins.Attributes/version.json b/WoofWare.Myriad.Plugins.Attributes/version.json index 89741bf..833c3b8 100644 --- a/WoofWare.Myriad.Plugins.Attributes/version.json +++ b/WoofWare.Myriad.Plugins.Attributes/version.json @@ -1,5 +1,5 @@ { - "version": "3.1", + "version": "3.2", "publicReleaseRefSpec": [ "^refs/heads/main$" ], diff --git a/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParser.fs b/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParser.fs new file mode 100644 index 0000000..4f35486 --- /dev/null +++ b/WoofWare.Myriad.Plugins.Test/TestArgParser/TestArgParser.fs @@ -0,0 +1,343 @@ +namespace WoofWare.Myriad.Plugins.Test + +open System +open System.Threading +open NUnit.Framework +open FsUnitTyped +open ConsumePlugin +open FsCheck + +[] +module TestArgParser = + + [] + [] + let ``Positionals get parsed: they don't have to be strings`` (sep : bool) = + let getEnvVar (_ : string) = failwith "should not call" + + let property + (fooSep : bool) + (barSep : bool) + (bazSep : bool) + (pos0 : int list) + (pos1 : int list) + (pos2 : int list) + (pos3 : int list) + (pos4 : int list) + = + let args = + [ + yield! pos0 |> List.map string + if fooSep then + yield "--foo=3" + else + yield "--foo" + yield "3" + yield! pos1 |> List.map string + if barSep then + yield "--bar=4" + else + yield "--bar" + yield "4" + yield! pos2 |> List.map string + if bazSep then + yield "--baz=true" + else + yield "--baz" + yield "true" + yield! pos3 |> List.map string + if sep then + yield "--" + yield! pos4 |> List.map string + ] + + BasicWithIntPositionals.parse' getEnvVar args + |> shouldEqual + { + Foo = 3 + Bar = "4" + Baz = true + Rest = pos0 @ pos1 @ pos2 @ pos3 @ pos4 + } + + Check.QuickThrowOnFailure property + + [] + let ``Arg-like thing appearing before double dash`` () = + let envCalls = ref 0 + + let getEnvVar (_ : string) = + Interlocked.Increment envCalls |> ignore + "" + + let args = [ "--foo=3" ; "--non-existent" ; "--bar=4" ; "--baz=true" ] + + let exc = + Assert.Throws (fun () -> Basic.parse' getEnvVar args |> ignore) + + envCalls.Value |> shouldEqual 0 + + exc.Message + |> shouldEqual + """Unable to process supplied arg --non-existent. Help text follows. +--foo int32 : This is a foo! +--bar string +--baz bool +--rest string (positional args) (can be repeated) : Here's where the rest of the args go""" + + [] + let ``Can supply positional args with key`` () = + let envCalls = ref 0 + + let getEnvVar (_ : string) = + Interlocked.Increment envCalls |> ignore + "" + + let property (args : (int * bool) list) (afterDoubleDash : int list option) = + let flatArgs = + args + |> List.collect (fun (value, sep) -> + if sep then + [ $"--rest=%i{value}" ] + else + [ "--rest" ; string value ] + ) + |> fun l -> l @ [ "--foo=3" ; "--bar=4" ; "--baz=true" ] + + let flatArgs, expected = + match afterDoubleDash with + | None -> flatArgs, List.map fst args + | Some rest -> flatArgs @ [ "--" ] @ (List.map string rest), List.map fst args @ rest + + BasicWithIntPositionals.parse' getEnvVar flatArgs + |> shouldEqual + { + Foo = 3 + Bar = "4" + Baz = true + Rest = expected + } + + Check.QuickThrowOnFailure property + envCalls.Value |> shouldEqual 0 + + [] + let ``Consume multiple occurrences of required arg`` () = + let envCalls = ref 0 + + let getEnvVar (_ : string) = + Interlocked.Increment envCalls |> ignore + "" + + let args = [ "--foo=3" ; "--rest" ; "7" ; "--bar=4" ; "--baz=true" ; "--rest=8" ] + + let result = BasicNoPositionals.parse' getEnvVar args + + envCalls.Value |> shouldEqual 0 + + result + |> shouldEqual + { + Foo = 3 + Bar = "4" + Baz = true + Rest = [ 7 ; 8 ] + } + + [] + let ``Gracefully handle invalid multiple occurrences of required arg`` () = + let envCalls = ref 0 + + let getEnvVar (_ : string) = + Interlocked.Increment envCalls |> ignore + "" + + let args = [ "--foo=3" ; "--foo" ; "9" ; "--bar=4" ; "--baz=true" ; "--baz=false" ] + + let exc = + Assert.Throws (fun () -> Basic.parse' getEnvVar args |> ignore) + + envCalls.Value |> shouldEqual 0 + + exc.Message + |> shouldEqual + """Errors during parse! +Argument '--foo' was supplied multiple times: 3 and 9 +Argument '--baz' was supplied multiple times: True and false""" + + [] + let ``Args appearing after double dash are positional`` () = + let envCalls = ref 0 + + let getEnvVar (_ : string) = + Interlocked.Increment envCalls |> ignore + "" + + let args = [ "--" ; "--foo=3" ; "--bar=4" ; "--baz=true" ] + + let exc = + Assert.Throws (fun () -> Basic.parse' getEnvVar args |> ignore) + + exc.Message + |> shouldEqual + """Errors during parse! +Required argument '--foo' received no value +Required argument '--bar' received no value +Required argument '--baz' received no value""" + + envCalls.Value |> shouldEqual 0 + + [] + let ``Help text`` () = + let getEnvVar (s : string) = + s |> shouldEqual "CONSUMEPLUGIN_THINGS" + "hi!" + + let exc = + Assert.Throws (fun () -> Basic.parse' getEnvVar [ "--help" ] |> ignore) + + exc.Message + |> shouldEqual + """Help text requested. +--foo int32 : This is a foo! +--bar string +--baz bool +--rest string (positional args) (can be repeated) : Here's where the rest of the args go""" + + [] + let ``Help text, with default values`` () = + let envVars = ref 0 + + let getEnvVar (_ : string) = + Interlocked.Increment envVars |> ignore + "" + + let exc = + Assert.Throws (fun () -> LoadsOfTypes.parse' getEnvVar [ "--help" ] |> ignore) + + exc.Message + |> shouldEqual + """Help text requested. +--foo int32 +--bar string +--baz bool +--some-file FileInfo +--some-directory DirectoryInfo +--some-list DirectoryInfo (can be repeated) +--optional-thing-with-no-default int32 (optional) +--optional-thing bool (default value: True) +--another-optional-thing int32 (default value: 3) +--yet-another-optional-thing string (default value populated from env var CONSUMEPLUGIN_THINGS) +--positionals int32 (positional args) (can be repeated)""" + + envVars.Value |> shouldEqual 0 + + [] + let ``Default values`` () = + let getEnvVar (s : string) = + s |> shouldEqual "CONSUMEPLUGIN_THINGS" + "hi!" + + let args = + [ + "--foo" + "3" + "--bar=some string" + "--baz" + "--some-file=/path/to/file" + "--some-directory" + "/a/dir" + "--another-optional-thing" + "3000" + ] + + let result = LoadsOfTypes.parse' getEnvVar args + + result.OptionalThing |> shouldEqual (Choice2Of2 true) + result.OptionalThingWithNoDefault |> shouldEqual None + result.AnotherOptionalThing |> shouldEqual (Choice1Of2 3000) + result.YetAnotherOptionalThing |> shouldEqual (Choice2Of2 "hi!") + + [] + let ``ParseExact and help`` () = + let count = ref 0 + + let getEnvVar (_ : string) = + Interlocked.Increment count |> ignore + "" + + let exc = + Assert.Throws (fun () -> DatesAndTimes.parse' getEnvVar [ "--help" ] |> ignore) + + exc.Message + |> shouldEqual + @"Help text requested. +--plain TimeSpan +--invariant TimeSpan +--exact TimeSpan : An exact time please [Parse format (.NET): hh\:mm\:ss] +--invariant-exact TimeSpan : [Parse format (.NET): hh\:mm\:ss]" + + count.Value |> shouldEqual 0 + + [] + let rec ``TimeSpans and their attributes`` () = + let count = ref 0 + + let getEnvVar (_ : string) = + Interlocked.Increment count |> ignore + "" + + let parsed = + DatesAndTimes.parse' + getEnvVar + [ + "--exact=11:34:00" + "--plain=1" + "--invariant=23:59" + "--invariant-exact=23:59:00" + ] + + parsed.Plain |> shouldEqual (TimeSpan (1, 0, 0, 0)) + parsed.Invariant |> shouldEqual (TimeSpan (23, 59, 00)) + parsed.Exact |> shouldEqual (TimeSpan (11, 34, 00)) + parsed.InvariantExact |> shouldEqual (TimeSpan (23, 59, 00)) + + let exc = + Assert.Throws (fun () -> + DatesAndTimes.parse' + getEnvVar + [ + "--exact=11:34:00" + "--plain=1" + "--invariant=23:59" + "--invariant-exact=23:59" + ] + |> ignore + ) + + exc.Message + |> shouldEqual + """Errors during parse! +Input string was not in a correct format. (at arg --invariant-exact=23:59) +Required argument '--invariant-exact' received no value""" + + let exc = + Assert.Throws (fun () -> + DatesAndTimes.parse' + getEnvVar + [ + "--exact=11:34" + "--plain=1" + "--invariant=23:59" + "--invariant-exact=23:59:00" + ] + |> ignore + ) + + exc.Message + |> shouldEqual + """Errors during parse! +Input string was not in a correct format. (at arg --exact=11:34) +Required argument '--exact' received no value""" + + count.Value |> shouldEqual 0 diff --git a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj index efec414..3d84c37 100644 --- a/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj +++ b/WoofWare.Myriad.Plugins.Test/WoofWare.Myriad.Plugins.Test.fsproj @@ -27,6 +27,7 @@ + diff --git a/WoofWare.Myriad.Plugins/ArgParserGenerator.fs b/WoofWare.Myriad.Plugins/ArgParserGenerator.fs new file mode 100644 index 0000000..7358589 --- /dev/null +++ b/WoofWare.Myriad.Plugins/ArgParserGenerator.fs @@ -0,0 +1,1214 @@ +namespace WoofWare.Myriad.Plugins + +open System +open System.Text +open Fantomas.FCS.Syntax +open Fantomas.FCS.Text.Range +open Fantomas.FCS.Xml +open Myriad.Core + +type internal ArgParserOutputSpec = + { + ExtensionMethods : bool + } + +/// 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 }`, then + /// we would use `MyArgs.DefaultThing () : int`. + | FunctionCall of name : Ident + +type private Accumulation = + | Required + | Optional + | Choice of ArgumentDefaultSpec + | List + +type private ParseFunction = + { + FieldName : Ident + TargetVariable : Ident + ArgForm : string + 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 : Accumulation + } + +type private ParserSpec = + { + NonPositionals : ParseFunction list + /// The variable into which positional arguments will be accumulated. + /// In this case, the TargetVariable is a `ResizeArray` rather than the usual `option`. + Positionals : ParseFunction option + } + +type private ArgToParse = + | Positional of ParseFunction + | NonPositional of ParseFunction + +[] +module internal ArgParserGenerator = + + /// Convert e.g. "Foo" into "--foo". + let argify (ident : Ident) : string = + let result = StringBuilder () + result.Append "-" |> ignore + + for c in ident.idText do + if Char.IsUpper c then + result.Append('-').Append (Char.ToLowerInvariant c) |> ignore + else + result.Append c |> ignore + + result.ToString () + + /// Builds a function or lambda of one string argument, which returns a `ty` (as modified by the `Accumulation`; + /// for example, maybe it returns a `ty option` or a `ty list`). + /// The resulting SynType is the type of the *element* being parsed; so if the Accumulation is List, the SynType + /// is the list element. + let rec private createParseFunction + (fieldName : Ident) + (attrs : SynAttribute list) + (ty : SynType) + : SynExpr * Accumulation * SynType + = + match ty with + | String -> SynExpr.createLambda "x" (SynExpr.createIdent "x"), Accumulation.Required, SynType.string + | PrimitiveType pt -> + SynExpr.createLambda + "x" + (SynExpr.applyFunction + (SynExpr.createLongIdent' (pt @ [ Ident.create "Parse" ])) + (SynExpr.createIdent "x")), + Accumulation.Required, + ty + | TimeSpan -> + let parseExact = + attrs + |> List.tryPick (fun attr -> + match attr.TypeName with + | SynLongIdent.SynLongIdent (idents, _, _) -> + match idents |> List.map (fun i -> i.idText) |> List.tryLast with + | Some "ParseExactAttribute" + | Some "ParseExact" -> Some attr.ArgExpr + | _ -> None + ) + + let culture = + attrs + |> List.tryPick (fun attr -> + match attr.TypeName with + | SynLongIdent.SynLongIdent (idents, _, _) -> + match idents |> List.map (fun i -> i.idText) |> List.tryLast with + | Some "InvariantCultureAttribute" + | Some "InvariantCulture" -> Some () + | _ -> None + ) + + let parser = + match parseExact, culture with + | None, None -> + SynExpr.createIdent "x" + |> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "TimeSpan" ; "Parse" ]) + | Some format, None -> + [ + SynExpr.createIdent "x" + format + SynExpr.createLongIdent [ "System" ; "Globalization" ; "CultureInfo" ; "CurrentCulture" ] + ] + |> SynExpr.tuple + |> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "TimeSpan" ; "ParseExact" ]) + | None, Some () -> + [ + SynExpr.createIdent "x" + SynExpr.createLongIdent [ "System" ; "Globalization" ; "CultureInfo" ; "InvariantCulture" ] + ] + |> SynExpr.tuple + |> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "TimeSpan" ; "Parse" ]) + | Some format, Some () -> + [ + SynExpr.createIdent "x" + format + SynExpr.createLongIdent [ "System" ; "Globalization" ; "CultureInfo" ; "InvariantCulture" ] + ] + |> SynExpr.tuple + |> SynExpr.applyFunction (SynExpr.createLongIdent [ "System" ; "TimeSpan" ; "ParseExact" ]) + |> SynExpr.createLambda "x" + + parser, Accumulation.Required, ty + | FileInfo -> + SynExpr.createLambda + "x" + (SynExpr.applyFunction + (SynExpr.createLongIdent [ "System" ; "IO" ; "FileInfo" ]) + (SynExpr.createIdent "x")), + Accumulation.Required, + ty + | DirectoryInfo -> + SynExpr.createLambda + "x" + (SynExpr.applyFunction + (SynExpr.createLongIdent [ "System" ; "IO" ; "DirectoryInfo" ]) + (SynExpr.createIdent "x")), + Accumulation.Required, + ty + | OptionType eltTy -> + let parseElt, acc, childTy = createParseFunction fieldName attrs eltTy + + match acc with + | Accumulation.Optional -> + failwith + $"ArgParser does not support optionals containing options at field %s{fieldName.idText}: %O{ty}" + | Accumulation.Choice _ -> + failwith + $"ArgParser does not support optionals containing choices at field %s{fieldName.idText}: %O{ty}" + | Accumulation.List -> + failwith $"ArgParser does not support optional lists at field %s{fieldName.idText}: %O{ty}" + | Accumulation.Required -> parseElt, Accumulation.Optional, childTy + | ChoiceType elts -> + match elts with + | [ elt1 ; elt2 ] -> + if not (SynType.provablyEqual elt1 elt2) then + failwith + $"ArgParser was unable to prove types %O{elt1} and %O{elt2} to be equal in a Choice. We require them to be equal." + + let parseElt, acc, childTy = createParseFunction fieldName attrs elt1 + + match acc with + | Accumulation.Optional -> + failwith + $"ArgParser does not support choices containing options at field %s{fieldName.idText}: %O{ty}" + | Accumulation.List -> + failwith + $"ArgParser does not support choices containing lists at field %s{fieldName.idText}: %O{ty}" + | Accumulation.Choice _ -> + failwith + $"ArgParser does not support choices containing choices at field %s{fieldName.idText}: %O{ty}" + | Accumulation.Required -> + + let relevantAttrs = + attrs + |> List.choose (fun attr -> + let (SynLongIdent.SynLongIdent (name, _, _)) = attr.TypeName + + match name |> List.map _.idText with + | [ "ArgumentDefaultFunction" ] + | [ "ArgumentDefaultFunctionAttribute" ] + | [ "Plugins" ; "ArgumentDefaultFunction" ] + | [ "Plugins" ; "ArgumentDefaultFunctionAttribute" ] + | [ "Myriad" ; "Plugins" ; "ArgumentDefaultFunction" ] + | [ "Myriad" ; "Plugins" ; "ArgumentDefaultFunctionAttribute" ] + | [ "WoofWare" ; "Myriad" ; "Plugins" ; "ArgumentDefaultFunction" ] + | [ "WoofWare" ; "Myriad" ; "Plugins" ; "ArgumentDefaultFunctionAttribute" ] -> + ArgumentDefaultSpec.FunctionCall (Ident.create ("Default" + fieldName.idText)) + |> Some + | [ "ArgumentDefaultEnvironmentVariable" ] + | [ "ArgumentDefaultEnvironmentVariableAttribute" ] + | [ "Plugins" ; "ArgumentDefaultEnvironmentVariable" ] + | [ "Plugins" ; "ArgumentDefaultEnvironmentVariableAttribute" ] + | [ "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariable" ] + | [ "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariableAttribute" ] + | [ "WoofWare" ; "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariable" ] + | [ "WoofWare" ; "Myriad" ; "Plugins" ; "ArgumentDefaultEnvironmentVariableAttribute" ] -> + ArgumentDefaultSpec.EnvironmentVariable attr.ArgExpr |> Some + | _ -> None + ) + + let relevantAttr = + match relevantAttrs with + | [] -> + failwith + $"Expected Choice to be annotated with ArgumentDefaultFunction or similar, but it was not. Field: %s{fieldName.idText}" + | [ x ] -> x + | _ -> + failwith + $"Expected Choice to be annotated with exactly one ArgumentDefaultFunction or similar, but it was annotated with multiple. Field: %s{fieldName.idText}" + + parseElt, Accumulation.Choice relevantAttr, childTy + | elts -> + let elts = elts |> List.map string |> String.concat ", " + + failwith + $"ArgParser requires Choice to be of the form Choice<'a, 'a>; that is, two arguments, both the same. For field %s{fieldName.idText}, got: %s{elts}" + | ListType eltTy -> + let parseElt, acc, childTy = createParseFunction fieldName attrs eltTy + + match acc with + | Accumulation.List -> + failwith $"ArgParser does not support nested lists at field %s{fieldName.idText}: %O{ty}" + | Accumulation.Choice _ -> + failwith $"ArgParser does not support lists containing choices at field %s{fieldName.idText}: %O{ty}" + | Accumulation.Optional -> + failwith $"ArgParser does not support lists of options at field %s{fieldName.idText}: %O{ty}" + | Accumulation.Required -> parseElt, Accumulation.List, childTy + | _ -> failwith $"Could not decide how to parse arguments for field %s{fieldName.idText} of type %O{ty}" + + let private toParseSpec (finalRecord : RecordType) : ParserSpec = + finalRecord.Fields + |> List.iter (fun (SynField.SynField (isStatic = isStatic)) -> + if isStatic then + failwith "No static record fields allowed in ArgParserGenerator" + ) + + let args : ArgToParse list = + finalRecord.Fields + |> List.map (fun (SynField.SynField (attrs, _, identOption, fieldType, _, _, _, _, _)) -> + let attrs = attrs |> List.collect (fun a -> a.Attributes) + + let positionalArgAttr = + attrs + |> List.tryFind (fun a -> + match (List.last a.TypeName.LongIdent).idText with + | "PositionalArgsAttribute" + | "PositionalArgs" -> true + | _ -> false + ) + + let parseExactModifier = + attrs + |> List.tryPick (fun a -> + match (List.last a.TypeName.LongIdent).idText with + | "ParseExactAttribute" + | "ParseExact" -> Some a.ArgExpr + | _ -> None + ) + + let helpText = + attrs + |> List.tryPick (fun a -> + match (List.last a.TypeName.LongIdent).idText with + | "ArgumentHelpTextAttribute" + | "ArgumentHelpText" -> Some a.ArgExpr + | _ -> None + ) + + let helpText = + match parseExactModifier, helpText with + | None, ht -> ht + | Some pe, None -> + SynExpr.createIdent "sprintf" + |> SynExpr.applyTo (SynExpr.CreateConst "[Parse format (.NET): %s]") + |> SynExpr.applyTo pe + |> Some + | Some pe, Some ht -> + SynExpr.createIdent "sprintf" + |> SynExpr.applyTo (SynExpr.CreateConst "%s [Parse format (.NET): %s]") + |> SynExpr.applyTo ht + |> SynExpr.applyTo pe + |> Some + + let ident = + match identOption with + | None -> failwith "expected args field to have a name, but it did not" + | Some i -> i + + let parser, accumulation, parseTy = createParseFunction ident attrs fieldType + + match positionalArgAttr with + | Some _ -> + match accumulation with + | Accumulation.List -> + { + FieldName = ident + Parser = parser + TargetVariable = ident + Accumulation = accumulation + TargetType = parseTy + ArgForm = argify ident + Help = helpText + } + |> ArgToParse.Positional + | _ -> failwith $"Expected positional arg accumulation type to be List, but it was %O{fieldType}" + | None -> + { + FieldName = ident + Parser = parser + TargetVariable = ident + Accumulation = accumulation + TargetType = parseTy + ArgForm = argify ident + Help = helpText + } + |> ArgToParse.NonPositional + ) + + let positional, nonPositionals = + let mutable p = None + let n = ResizeArray () + + for arg in args do + match arg with + | ArgToParse.Positional arg -> + match p with + | None -> p <- Some arg + | Some existing -> + failwith + $"Multiple args were tagged with `Positional`: %s{existing.TargetVariable.idText}, %s{arg.TargetVariable.idText}" + | ArgToParse.NonPositional arg -> n.Add arg + + p, List.ofSeq n + + { + NonPositionals = nonPositionals + Positionals = positional + } + + /// let helpText : string = ... + let private helpText + (typeName : Ident) + (positional : ParseFunction option) + (args : ParseFunction list) + : SynBinding + = + let toPrintable (prefix : string) (arg : ParseFunction) : SynExpr = + let ty = arg.TargetType |> SynType.toHumanReadableString + + let helpText = + match arg.Help with + | None -> SynExpr.CreateConst "" + | Some helpText -> + SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst " : %s") + |> SynExpr.applyTo (SynExpr.paren helpText) + |> SynExpr.paren + + let descriptor = + match arg.Accumulation with + | Accumulation.Required -> SynExpr.CreateConst "" + | Accumulation.Optional -> SynExpr.CreateConst " (optional)" + | Accumulation.Choice (ArgumentDefaultSpec.EnvironmentVariable var) -> + // We don't print out the default value in case it's a secret. People often pass secrets + // through env vars! + var + |> SynExpr.pipeThroughFunction ( + SynExpr.applyFunction + (SynExpr.createIdent "sprintf") + (SynExpr.CreateConst " (default value populated from env var %s)") + ) + |> SynExpr.paren + | Accumulation.Choice (ArgumentDefaultSpec.FunctionCall var) -> + SynExpr.callMethod var.idText (SynExpr.createIdent' typeName) + |> SynExpr.pipeThroughFunction ( + SynExpr.applyFunction + (SynExpr.createIdent "sprintf") + (SynExpr.CreateConst " (default value: %O)") + ) + |> SynExpr.paren + | Accumulation.List -> SynExpr.CreateConst " (can be repeated)" + + let prefix = $"%s{arg.ArgForm} %s{ty}%s{prefix}" + + SynExpr.applyFunction (SynExpr.createIdent "sprintf") (SynExpr.CreateConst (prefix + "%s%s")) + |> SynExpr.applyTo descriptor + |> SynExpr.applyTo helpText + |> SynExpr.paren + + args + |> List.map (toPrintable "") + |> fun l -> + match positional with + | None -> l + | Some pos -> l @ [ toPrintable " (positional args)" pos ] + |> SynExpr.listLiteral + |> SynExpr.pipeThroughFunction ( + SynExpr.applyFunction (SynExpr.createLongIdent [ "String" ; "concat" ]) (SynExpr.CreateConst @"\n") + ) + |> SynBinding.basic [ Ident.create "helpText" ] [ SynPat.unit ] + + /// `let processKeyValue (key : string) (value : string) : Result = ...` + /// Returns a possible error. + /// A parse failure might not be fatal (e.g. maybe the input was optionally of arity 0, and we failed to do + /// the parse because in fact the key decided not to take this argument); in that case we return Error None. + let private processKeyValue (argParseErrors : Ident) (args : ParseFunction list) : SynBinding = + (SynExpr.applyFunction (SynExpr.createIdent "Error") (SynExpr.createIdent "None"), args) + ||> List.fold (fun finalBranch arg -> + match arg.Accumulation with + | Accumulation.Required + | Accumulation.Choice _ + | Accumulation.Optional -> + let multipleErrorMessage = + SynExpr.createIdent "sprintf" + |> SynExpr.applyTo (SynExpr.CreateConst "Argument '%s' was supplied multiple times: %O and %O") + |> SynExpr.applyTo (SynExpr.CreateConst arg.ArgForm) + |> SynExpr.applyTo (SynExpr.createIdent "x") + |> SynExpr.applyTo (SynExpr.createIdent "value") + + let performAssignment = + [ + SynExpr.createIdent "value" + |> SynExpr.pipeThroughFunction arg.Parser + |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Some") + |> SynExpr.assign (SynLongIdent.createI arg.TargetVariable) + + SynExpr.applyFunction (SynExpr.createIdent "Ok") (SynExpr.CreateConst ()) + ] + |> SynExpr.sequential + + [ + SynMatchClause.create + (SynPat.nameWithArgs "Some" [ SynPat.named "x" ]) + (SynExpr.sequential + [ + multipleErrorMessage + |> SynExpr.pipeThroughFunction ( + SynExpr.dotGet "Add" (SynExpr.createIdent' argParseErrors) + ) + SynExpr.applyFunction (SynExpr.createIdent "Ok") (SynExpr.CreateConst ()) + ]) + SynMatchClause.create + (SynPat.named "None") + (SynExpr.pipeThroughTryWith + SynPat.anon + (SynExpr.createLongIdent [ "exc" ; "Message" ] + |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Some") + |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Error")) + performAssignment) + ] + |> SynExpr.createMatch (SynExpr.createIdent' arg.TargetVariable) + | Accumulation.List -> + [ + SynExpr.createIdent "value" + |> SynExpr.pipeThroughFunction ( + SynExpr.createLongIdent' [ arg.TargetVariable ; Ident.create "Add" ] + ) + |> SynExpr.applyFunction arg.Parser + SynExpr.CreateConst () |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Ok") + ] + |> SynExpr.sequential + |> SynExpr.ifThenElse + (SynExpr.applyFunction + (SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ]) + (SynExpr.tuple + [ + SynExpr.createIdent "key" + SynExpr.CreateConst arg.ArgForm + SynExpr.createLongIdent [ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ] + ])) + finalBranch + ) + |> SynBinding.basic + [ Ident.create "processKeyValue" ] + [ + SynPat.annotateType SynType.string (SynPat.named "key") + SynPat.annotateType SynType.string (SynPat.named "value") + ] + |> SynBinding.withReturnAnnotation ( + SynType.app "Result" [ SynType.unit ; SynType.appPostfix "option" SynType.string ] + ) + |> SynBinding.withXmlDoc ( + [ + " Processes the key-value pair, returning Error if no key was matched." + " If the key is an arg which can arity 1, but throws when consuming that arg, we return Error()." + " This can nevertheless be a successful parse, e.g. when the key may have arity 0." + ] + |> PreXmlDoc.create' + ) + + /// `let setFlagValue (key : string) : bool = ...` + let private setFlagValue (parseState : Ident) (argParseErrors : Ident) (flags : ParseFunction list) : SynBinding = + (SynExpr.CreateConst false, flags) + ||> List.fold (fun finalExpr flag -> + let multipleErrorMessage = + SynExpr.createIdent "sprintf" + |> SynExpr.applyTo (SynExpr.CreateConst "Flag '%s' was supplied multiple times") + |> SynExpr.applyTo (SynExpr.CreateConst flag.ArgForm) + + [ + SynMatchClause.create + (SynPat.nameWithArgs "Some" [ SynPat.named "x" ]) + // This is an error, but it's one we can gracefully report at the end. + (SynExpr.sequential + [ + multipleErrorMessage + |> SynExpr.pipeThroughFunction (SynExpr.dotGet "Add" (SynExpr.createIdent' argParseErrors)) + SynExpr.CreateConst true + ]) + + SynMatchClause.create + (SynPat.named "None") + ([ + SynExpr.assign + (SynLongIdent.createI flag.TargetVariable) + (SynExpr.applyFunction (SynExpr.createIdent "Some") (SynExpr.CreateConst true)) + SynExpr.CreateConst true + ] + |> SynExpr.sequential) + ] + |> SynExpr.createMatch (SynExpr.createIdent' flag.TargetVariable) + |> SynExpr.ifThenElse + (SynExpr.applyFunction + (SynExpr.createLongIdent [ "System" ; "String" ; "Equals" ]) + (SynExpr.tuple + [ + SynExpr.createIdent "key" + SynExpr.CreateConst flag.ArgForm + SynExpr.createLongIdent [ "System" ; "StringComparison" ; "OrdinalIgnoreCase" ] + ])) + finalExpr + ) + |> SynBinding.basic [ Ident.create "setFlagValue" ] [ SynPat.annotateType SynType.string (SynPat.named "key") ] + |> SynBinding.withReturnAnnotation (SynType.named "bool") + |> SynBinding.withXmlDoc (PreXmlDoc.create "Returns false if we didn't set a value.") + + /// `let rec go (state : %ParseState%) (args : string list) : unit = ...` + let private mainLoop + (parseState : Ident) + (errorAcc : Ident) + (leftoverArgs : Ident) + (leftoverArgParser : SynExpr) + : SynBinding + = + /// `go (AwaitingValue arg) args + let recurseValue = + SynExpr.createIdent "go" + |> SynExpr.applyTo ( + SynExpr.paren ( + SynExpr.applyFunction + (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingValue" ]) + (SynExpr.createIdent "arg") + ) + ) + + /// `go AwaitingKey args` + let recurseKey = + (SynExpr.createIdent "go") + |> SynExpr.applyTo (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingKey" ]) + |> SynExpr.applyTo (SynExpr.createIdent "args") + + /// `failwithf "Unable to process argument ..."` + let fail = + SynExpr.createIdent "failwithf" + |> SynExpr.applyTo (SynExpr.CreateConst "Unable to process argument %s as key %s and value %s") + |> SynExpr.applyTo (SynExpr.createIdent "arg") + |> SynExpr.applyTo (SynExpr.createIdent "key") + |> SynExpr.applyTo (SynExpr.createIdent "value") + + let argStartsWithDashes = + SynExpr.createIdent "arg" + |> SynExpr.callMethodArg + "StartsWith" + (SynExpr.tuple + [ + SynExpr.CreateConst "--" + SynExpr.createLongIdent [ "System" ; "StringComparison" ; "Ordinal" ] + ]) + + let processKey = + SynExpr.ifThenElse + argStartsWithDashes + (SynExpr.sequential + [ + (SynExpr.createIdent "arg" + |> SynExpr.pipeThroughFunction leftoverArgParser + |> SynExpr.pipeThroughFunction (SynExpr.createLongIdent' [ leftoverArgs ; Ident.create "Add" ])) + + recurseKey + ]) + (SynExpr.ifThenElse + (SynExpr.equals (SynExpr.createIdent "arg") (SynExpr.CreateConst "--help")) + (SynExpr.createLet + [ + SynBinding.basic + [ Ident.create "equals" ] + [] + (SynExpr.callMethodArg "IndexOf" (SynExpr.CreateConst '=') (SynExpr.createIdent "arg")) + ] + (SynExpr.ifThenElse + (SynExpr.lessThan (SynExpr.CreateConst 0) (SynExpr.createIdent "equals")) + (SynExpr.createLet + [ + SynBinding.basic + [ Ident.create "key" ] + [] + (SynExpr.arrayIndexRange + (Some (SynExpr.CreateConst 0)) + (Some (SynExpr.minusN (SynLongIdent.createS "equals") 1)) + (SynExpr.createIdent "arg")) + SynBinding.basic + [ Ident.create "value" ] + [] + (SynExpr.arrayIndexRange + (Some (SynExpr.plus (SynExpr.createIdent "equals") (SynExpr.CreateConst 1))) + None + (SynExpr.createIdent "arg")) + ] + (SynExpr.createMatch + (SynExpr.createIdent "processKeyValue" + |> SynExpr.applyTo (SynExpr.createIdent "key") + |> SynExpr.applyTo (SynExpr.createIdent "value")) + [ + SynMatchClause.create (SynPat.nameWithArgs "Ok" [ SynPat.unit ]) recurseKey + + SynMatchClause.create (SynPat.nameWithArgs "Error" [ SynPat.named "None" ]) fail + SynMatchClause.create + (SynPat.nameWithArgs + "Error" + [ SynPat.nameWithArgs "Some" [ SynPat.named "msg" ] |> SynPat.paren ]) + (SynExpr.sequential + [ + SynExpr.createIdent "sprintf" + |> SynExpr.applyTo (SynExpr.CreateConst "%s (at arg %s)") + |> SynExpr.applyTo (SynExpr.createIdent "msg") + |> SynExpr.applyTo (SynExpr.createIdent "arg") + |> SynExpr.pipeThroughFunction ( + SynExpr.dotGet "Add" (SynExpr.createIdent' errorAcc) + ) + + recurseKey + ]) + ])) + (SynExpr.createIdent "args" |> SynExpr.pipeThroughFunction recurseValue))) + (SynExpr.createIdent "helpText" + |> SynExpr.applyTo (SynExpr.CreateConst ()) + |> SynExpr.pipeThroughFunction ( + SynExpr.applyFunction + (SynExpr.createIdent "failwithf") + (SynExpr.CreateConst @"Help text requested.\n%s") + ))) + + let processValue = + // During failure, we've received an optional exception message that happened when we tried to parse + // the value; it's in the variable `exc`. + let fail = + [ + SynExpr.createIdent "failwithf" + |> SynExpr.applyTo ( + SynExpr.CreateConst @"Unable to process supplied arg %s. Help text follows.\n%s" + ) + |> SynExpr.applyTo (SynExpr.createIdent "key") + |> SynExpr.applyTo ( + SynExpr.applyFunction (SynExpr.createIdent "helpText") (SynExpr.CreateConst ()) + |> SynExpr.paren + ) + |> SynMatchClause.create (SynPat.named "None") + + SynExpr.createIdent "msg" + |> SynExpr.pipeThroughFunction (SynExpr.dotGet "Add" (SynExpr.createIdent' errorAcc)) + |> SynMatchClause.create (SynPat.nameWithArgs "Some" [ SynPat.named "msg" ]) + ] + |> SynExpr.createMatch (SynExpr.createIdent "exc") + + [ + SynMatchClause.create + (SynPat.nameWithArgs "Ok" [ SynPat.unit ]) + (SynExpr.applyFunction + (SynExpr.applyFunction + (SynExpr.createIdent "go") + (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingKey" ])) + (SynExpr.createIdent "args")) + SynMatchClause.create + (SynPat.nameWithArgs "Error" [ SynPat.named "exc" ]) + (SynExpr.ifThenElse + (SynExpr.applyFunction (SynExpr.createIdent "setFlagValue") (SynExpr.createIdent "key")) + fail + (SynExpr.createIdent "go" + |> SynExpr.applyTo (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingKey" ]) + |> SynExpr.applyTo (SynExpr.listCons (SynExpr.createIdent "arg") (SynExpr.createIdent "args")))) + ] + |> SynExpr.createMatch ( + SynExpr.applyFunction + (SynExpr.applyFunction (SynExpr.createIdent "processKeyValue") (SynExpr.createIdent "key")) + (SynExpr.createIdent "arg") + ) + + let argBody = + [ + SynMatchClause.create + (SynPat.identWithArgs [ parseState ; Ident.create "AwaitingKey" ] (SynArgPats.create [])) + processKey + SynMatchClause.create + (SynPat.identWithArgs + [ parseState ; Ident.create "AwaitingValue" ] + (SynArgPats.createNamed [ "key" ])) + processValue + ] + |> SynExpr.createMatch (SynExpr.createIdent "state") + + let body = + let trailingArgMessage = + SynExpr.createIdent "sprintf" + |> SynExpr.applyTo ( + SynExpr.CreateConst + "Trailing argument %s had no value. Use a double-dash to separate positional args from key-value args." + ) + |> SynExpr.applyTo (SynExpr.createIdent "key") + + [ + SynMatchClause.create + SynPat.emptyList + (SynExpr.createMatch + (SynExpr.createIdent "state") + [ + SynMatchClause.create + (SynPat.identWithArgs [ parseState ; Ident.create "AwaitingKey" ] (SynArgPats.create [])) + (SynExpr.CreateConst ()) + SynMatchClause.create + (SynPat.identWithArgs + [ parseState ; Ident.create "AwaitingValue" ] + (SynArgPats.createNamed [ "key" ])) + (SynExpr.ifThenElse + (SynExpr.applyFunction + (SynExpr.createIdent "setFlagValue") + (SynExpr.createIdent "key")) + (trailingArgMessage + |> SynExpr.pipeThroughFunction ( + SynExpr.dotGet "Add" (SynExpr.createIdent' errorAcc) + )) + (SynExpr.CreateConst ())) + ]) + SynMatchClause.create + (SynPat.listCons (SynPat.createConst (SynConst.CreateString "--")) (SynPat.named "rest")) + (SynExpr.callMethodArg + "AddRange" + (SynExpr.paren ( + SynExpr.createIdent "rest" + |> SynExpr.pipeThroughFunction ( + SynExpr.applyFunction (SynExpr.createLongIdent [ "Seq" ; "map" ]) leftoverArgParser + ) + )) + (SynExpr.createIdent' leftoverArgs)) + SynMatchClause.create (SynPat.listCons (SynPat.named "arg") (SynPat.named "args")) argBody + ] + |> SynExpr.createMatch (SynExpr.createIdent "args") + + let args = + [ + SynPat.named "state" + |> SynPat.annotateType (SynType.createLongIdent [ parseState ]) + SynPat.named "args" + |> SynPat.annotateType (SynType.appPostfix "list" (SynType.string)) + ] + + SynBinding.basic [ Ident.create "go" ] args body + |> SynBinding.withRecursion true + + /// Takes a single argument, `args : string list`, and returns something of the type indicated by `recordType`. + let createRecordParse (parseState : Ident) (recordType : RecordType) : SynExpr = + let spec = toParseSpec recordType + // For each argument (positional and non-positional), create an accumulator for it. + let bindings = + spec.NonPositionals + |> List.map (fun pf -> + match pf.Accumulation with + | Accumulation.Required + | Accumulation.Choice _ + | Accumulation.Optional -> + SynExpr.createIdent "None" + |> SynBinding.basic [ pf.TargetVariable ] [] + |> SynBinding.withMutability true + |> SynBinding.withReturnAnnotation (SynType.appPostfix "option" pf.TargetType) + | Accumulation.List -> + SynExpr.createIdent "ResizeArray" + |> SynExpr.applyTo (SynExpr.CreateConst ()) + |> SynBinding.basic [ pf.TargetVariable ] [] + |> SynBinding.withReturnAnnotation (SynType.appPostfix "ResizeArray" pf.TargetType) + ) + + let bindings, leftoverArgsName, leftoverArgsParser = + let bindingName, leftoverArgsParser, leftoverArgsType = + match spec.Positionals with + | None -> + Ident.create "parser_LeftoverArgs", + (SynExpr.createLambda "x" (SynExpr.createIdent "x")), + SynType.string + | Some pf -> pf.TargetVariable, pf.Parser, pf.TargetType + + let bindings = + SynExpr.createIdent "ResizeArray" + |> SynExpr.applyTo (SynExpr.CreateConst ()) + |> SynBinding.basic [ bindingName ] [] + |> SynBinding.withReturnAnnotation (SynType.appPostfix "ResizeArray" leftoverArgsType) + |> fun b -> b :: bindings + + bindings, bindingName, leftoverArgsParser + + let argParseErrors = Ident.create "ArgParser_errors" + + let errorCollection : SynBinding = + SynExpr.createIdent "ResizeArray" + |> SynExpr.applyTo (SynExpr.CreateConst ()) + |> SynBinding.basic [ argParseErrors ] [] + + let helpText = helpText recordType.Name spec.Positionals spec.NonPositionals + + let bindings = errorCollection :: helpText :: bindings + + let unchecked = + SynExpr.createLongIdent [ "Unchecked" ; "defaultof" ] + |> SynExpr.typeApp [ SynType.anon ] + + // Determine whether any required arg is missing, and freeze args into immutable form. + let freezeNonPositionalArgs = + spec.NonPositionals + |> List.map (fun pf -> + match pf.Accumulation with + | Accumulation.Choice spec -> + let getDefaultValue = + match spec with + | ArgumentDefaultSpec.EnvironmentVariable name -> + let result = + name + |> SynExpr.pipeThroughFunction (SynExpr.createIdent "getEnvironmentVariable") + + let errorMessage = + SynExpr.createIdent "sprintf" + |> SynExpr.applyTo ( + SynExpr.CreateConst + "No value was supplied for %s, nor was environment variable %s set" + ) + |> SynExpr.applyTo (SynExpr.CreateConst pf.ArgForm) + |> SynExpr.applyTo name + + [ + SynMatchClause.create + SynPat.createNull + (SynExpr.sequential + [ + errorMessage + |> SynExpr.pipeThroughFunction ( + SynExpr.dotGet "Add" (SynExpr.createIdent' argParseErrors) + ) + unchecked + ]) + + SynMatchClause.create + (SynPat.named "x") + (SynExpr.createIdent "x" |> SynExpr.pipeThroughFunction pf.Parser) + ] + |> SynExpr.createMatch result + | ArgumentDefaultSpec.FunctionCall name -> + SynExpr.callMethod name.idText (SynExpr.createIdent' recordType.Name) + + [ + SynMatchClause.create + (SynPat.named "None") + (getDefaultValue + |> SynExpr.pipeThroughFunction (SynExpr.createIdent "Choice2Of2")) + SynMatchClause.create + (SynPat.nameWithArgs "Some" [ SynPat.named "x" ]) + (SynExpr.applyFunction (SynExpr.createIdent "Choice1Of2") (SynExpr.createIdent "x")) + ] + |> SynExpr.createMatch (SynExpr.createIdent' pf.TargetVariable) + |> SynBinding.basic [ pf.TargetVariable ] [] + | Accumulation.Optional -> + SynBinding.basic [ pf.TargetVariable ] [] (SynExpr.createIdent' pf.TargetVariable) + | Accumulation.List -> + SynBinding.basic + [ pf.TargetVariable ] + [] + (SynExpr.createIdent' pf.TargetVariable + |> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "Seq" ; "toList" ])) + | Accumulation.Required -> + let errorMessage = + SynExpr.createIdent "sprintf" + |> SynExpr.applyTo (SynExpr.CreateConst "Required argument '%s' received no value") + |> SynExpr.applyTo (SynExpr.CreateConst (argify pf.TargetVariable)) + + [ + SynMatchClause.create + (SynPat.named "None") + (SynExpr.sequential + [ + errorMessage + |> SynExpr.pipeThroughFunction ( + SynExpr.dotGet "Add" (SynExpr.createIdent' argParseErrors) + ) + unchecked + ]) + + SynMatchClause.create + (SynPat.nameWithArgs "Some" [ SynPat.named "x" ]) + (SynExpr.createIdent "x") + ] + |> SynExpr.createMatch (SynExpr.createIdent' pf.TargetVariable) + |> SynBinding.basic [ pf.TargetVariable ] [] + ) + + let freezePositional = + match spec.Positionals with + | None -> + // Check if there are leftover args. If there are, throw. + let errorMessage = + SynExpr.createIdent' leftoverArgsName + |> SynExpr.pipeThroughFunction ( + SynExpr.applyFunction + (SynExpr.createLongIdent [ "String" ; "concat" ]) + (SynExpr.CreateConst " ") + ) + |> SynExpr.pipeThroughFunction ( + SynExpr.applyFunction + (SynExpr.createIdent "sprintf") + (SynExpr.CreateConst "There were leftover args: %s") + ) + + SynExpr.ifThenElse + (SynExpr.dotGet "Count" (SynExpr.createIdent' leftoverArgsName) + |> SynExpr.equals (SynExpr.CreateConst 0)) + (SynExpr.sequential + [ + errorMessage + |> SynExpr.pipeThroughFunction (SynExpr.dotGet "Add" (SynExpr.createIdent' argParseErrors)) + unchecked + ]) + (SynExpr.CreateConst ()) + | Some _ -> + SynExpr.createIdent' leftoverArgsName + |> SynExpr.pipeThroughFunction (SynExpr.createLongIdent [ "Seq" ; "toList" ]) + |> SynBinding.basic [ leftoverArgsName ] [] + |> List.singleton + + let freezeArgs = freezePositional @ freezeNonPositionalArgs + + let retPositional = + match spec.Positionals with + | None -> [] + | Some pf -> + [ + SynLongIdent.createI pf.TargetVariable, SynExpr.createIdent' pf.TargetVariable + ] + + let retValue = + let happyPath = + spec.NonPositionals + |> List.map (fun pf -> SynLongIdent.createI pf.TargetVariable, SynExpr.createIdent' pf.TargetVariable) + |> fun np -> retPositional @ np + |> AstHelper.instantiateRecord + + let sadPath = + SynExpr.createIdent' argParseErrors + |> SynExpr.pipeThroughFunction ( + SynExpr.applyFunction (SynExpr.createLongIdent [ "String" ; "concat" ]) (SynExpr.CreateConst @"\n") + ) + |> SynExpr.pipeThroughFunction ( + SynExpr.createIdent "failwithf" + |> SynExpr.applyTo (SynExpr.CreateConst @"Errors during parse!\n%s") + ) + + let areErrors = + SynExpr.dotGet "Count" (SynExpr.createIdent' argParseErrors) + |> SynExpr.equals (SynExpr.CreateConst 0) + + SynExpr.ifThenElse areErrors sadPath happyPath + + let flags = + spec.NonPositionals + |> List.filter (fun pf -> + match pf.TargetType with + | PrimitiveType pt -> (pt |> List.map _.idText) = [ "System" ; "Boolean" ] + | _ -> false + ) + + [ + SynExpr.createIdent "go" + |> SynExpr.applyTo (SynExpr.createLongIdent' [ parseState ; Ident.create "AwaitingKey" ]) + |> SynExpr.applyTo (SynExpr.createIdent "args") + + SynExpr.createLet freezeArgs retValue + ] + |> SynExpr.sequential + |> SynExpr.createLet ( + bindings + @ [ + processKeyValue argParseErrors (Option.toList spec.Positionals @ spec.NonPositionals) + setFlagValue parseState argParseErrors flags + mainLoop parseState argParseErrors leftoverArgsName leftoverArgsParser + ] + ) + + let createModule + (opens : SynOpenDeclTarget list) + (ns : LongIdent) + ((taggedType : SynTypeDefn, spec : ArgParserOutputSpec)) + (_allUnionTypesTODO : SynTypeDefn list) + (allRecordTypes : SynTypeDefn list) + : SynModuleOrNamespace + = + let taggedType = RecordType.OfRecord taggedType + + let modAttrs, modName = + if spec.ExtensionMethods then + [ SynAttribute.autoOpen ], Ident.create (taggedType.Name.idText + "ArgParse") + else + [ SynAttribute.requireQualifiedAccess ; SynAttribute.compilationRepresentation ], taggedType.Name + + let modInfo = + SynComponentInfo.create modName + |> SynComponentInfo.withDocString ( + PreXmlDoc.Create $" Methods to parse arguments for the type %s{taggedType.Name.idText}" + ) + |> SynComponentInfo.addAttributes modAttrs + + let parseStateIdent = Ident.create $"ParseState_%s{taggedType.Name.idText}" + + let parseStateType = + [ + SynUnionCase.create + { + Attrs = [] + Fields = [] + Ident = Ident.create "AwaitingKey" + } + SynUnionCase.create + { + Attrs = [] + Fields = + [ + { + Attrs = [] + Ident = Ident.create "key" + Type = SynType.string + } + ] + Ident = Ident.create "AwaitingValue" + } + ] + |> SynTypeDefnRepr.union + |> SynTypeDefn.create ( + SynComponentInfo.create parseStateIdent + |> SynComponentInfo.setAccessibility (Some (SynAccess.Private range0)) + ) + |> List.singleton + |> SynModuleDecl.createTypes + + let taggedMod = + let argsParam = + SynPat.named "args" + |> SynPat.annotateType (SynType.appPostfix "list" SynType.string) + + let parsePrime = + createRecordParse parseStateIdent taggedType + |> SynBinding.basic + [ Ident.create "parse'" ] + [ + SynPat.named "getEnvironmentVariable" + |> SynPat.annotateType (SynType.funFromDomain SynType.string SynType.string) + argsParam + ] + |> SynBinding.withReturnAnnotation (SynType.createLongIdent [ taggedType.Name ]) + + let parsePrimeCall = + if spec.ExtensionMethods then + // need to fully qualify + [ taggedType.Name ; Ident.create "parse'" ] + else + [ Ident.create "parse'" ] + + let parse = + SynExpr.createLongIdent' parsePrimeCall + |> SynExpr.applyTo (SynExpr.createLongIdent [ "System" ; "Environment" ; "GetEnvironmentVariable" ]) + |> SynExpr.applyTo (SynExpr.createIdent "args") + |> SynBinding.basic [ Ident.create "parse" ] [ argsParam ] + |> SynBinding.withReturnAnnotation (SynType.createLongIdent [ taggedType.Name ]) + + [ + yield parseStateType + + if spec.ExtensionMethods then + let bindingPrime = parsePrime |> SynMemberDefn.staticMember + + let binding = parse |> SynMemberDefn.staticMember + + let componentInfo = + SynComponentInfo.create taggedType.Name + |> SynComponentInfo.withDocString (PreXmlDoc.create "Extension methods for argument parsing") + + let containingType = + SynTypeDefnRepr.augmentation () + |> SynTypeDefn.create componentInfo + |> SynTypeDefn.withMemberDefns [ bindingPrime ; binding ] + + yield SynModuleDecl.createTypes [ containingType ] + else + yield SynModuleDecl.createLet parsePrime + + yield SynModuleDecl.createLet parse + ] + |> SynModuleDecl.nestedModule modInfo + + [ + for openStatement in opens do + yield SynModuleDecl.CreateOpen openStatement + yield taggedMod + ] + |> SynModuleOrNamespace.createNamespace ns + + let generate (context : GeneratorContext) : Output = + let ast, _ = + Ast.fromFilename context.InputFilename |> Async.RunSynchronously |> Array.head + + let types = Ast.extractTypeDefn ast + + let opens = AstHelper.extractOpens ast + + let namespaceAndTypes = + types + |> List.choose (fun (ns, types) -> + let typeWithAttr = + types + |> List.tryPick (fun ty -> + match Ast.getAttribute ty with + | None -> None + | Some attr -> + let arg = + match SynExpr.stripOptionalParen attr.ArgExpr with + | SynExpr.Const (SynConst.Bool value, _) -> value + | SynExpr.Const (SynConst.Unit, _) -> ArgParserAttribute.DefaultIsExtensionMethod + | arg -> + failwith + $"Unrecognised argument %+A{arg} to [<%s{nameof ArgParserAttribute}>]. Literals are not supported. Use `true` or `false` (or unit) only." + + let spec = + { + ExtensionMethods = arg + } + + Some (ty, spec) + ) + + match typeWithAttr with + | Some taggedType -> + let unions, records, others = + (([], [], []), types) + ||> List.fold (fun + (unions, records, others) + (SynTypeDefn.SynTypeDefn (_, repr, _, _, _, _) as ty) -> + match repr with + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Union _, _) -> + ty :: unions, records, others + | SynTypeDefnRepr.Simple (SynTypeDefnSimpleRepr.Record _, _) -> + unions, ty :: records, others + | _ -> unions, records, ty :: others + ) + + if not others.IsEmpty then + failwith + $"Error: all types recursively defined together with an ArgParserGenerator type must be discriminated unions or records. %+A{others}" + + Some (ns, taggedType, unions, records) + | _ -> None + ) + + let modules = + namespaceAndTypes + |> List.map (fun (ns, taggedType, unions, records) -> createModule opens ns taggedType unions records) + + Output.Ast modules + +/// Myriad generator that provides a catamorphism for an algebraic data type. +[] +type ArgParserGenerator () = + + interface IMyriadGenerator with + member _.ValidInputExtensions = [ ".fs" ] + + member _.Generate (context : GeneratorContext) = ArgParserGenerator.generate context diff --git a/WoofWare.Myriad.Plugins/CataGenerator.fs b/WoofWare.Myriad.Plugins/CataGenerator.fs index c09a5da..3d540e1 100644 --- a/WoofWare.Myriad.Plugins/CataGenerator.fs +++ b/WoofWare.Myriad.Plugins/CataGenerator.fs @@ -858,7 +858,7 @@ module internal CataGenerator = SynExpr.createMatch (SynExpr.createIdent "x") matchCases |> SynMatchClause.create ( - SynPat.identWithArgs analysis.AssociatedProcessInstruction (SynArgPats.create [ Ident.create "x" ]) + SynPat.identWithArgs analysis.AssociatedProcessInstruction (SynArgPats.createNamed [ "x" ]) ) /// Create the state-machine matches which deal with receiving the instruction @@ -896,8 +896,8 @@ module internal CataGenerator = |> Seq.mapi (fun i x -> (i, x)) |> Seq.choose (fun (i, case) -> match case.Description with - | FieldDescription.NonRecursive _ -> case.ArgName |> Some - | FieldDescription.ListSelf _ -> case.ArgName |> Some + | FieldDescription.NonRecursive _ -> case.ArgName |> SynPat.namedI |> Some + | FieldDescription.ListSelf _ -> case.ArgName |> SynPat.namedI |> Some | FieldDescription.Self _ -> None ) |> Seq.toList diff --git a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs index dbd3a79..7e005cd 100644 --- a/WoofWare.Myriad.Plugins/HttpClientGenerator.fs +++ b/WoofWare.Myriad.Plugins/HttpClientGenerator.fs @@ -833,7 +833,7 @@ module internal HttpClientGenerator = |> SynTypeDefn.create componentInfo |> SynTypeDefn.withMemberDefns [ binding ] - SynModuleDecl.Types ([ containingType ], range0) + SynModuleDecl.createTypes [ containingType ] else SynBinding.basic [ Ident.create "make" ] (headerArgs @ [ clientCreationArg ]) interfaceImpl diff --git a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs index 32a4ca6..440c893 100644 --- a/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs +++ b/WoofWare.Myriad.Plugins/JsonSerializeGenerator.fs @@ -72,9 +72,7 @@ module internal JsonSerializeGenerator = target |> SynExpr.paren |> SynExpr.upcast' (SynType.createLongIdent' [ "System" ; "Text" ; "Json" ; "Nodes" ; "JsonNode" ]) - |> SynMatchClause.create ( - SynPat.identWithArgs [ Ident.create "Some" ] (SynArgPats.create [ Ident.create "field" ]) - ) + |> SynMatchClause.create (SynPat.nameWithArgs "Some" [ SynPat.named "field" ]) [ noneClause ; someClause ] |> SynExpr.createMatch (SynExpr.createIdent "field") @@ -125,11 +123,7 @@ module internal JsonSerializeGenerator = DebugPointAtInOrTo.Yes range0, SeqExprOnly.SeqExprOnly false, true, - SynPat.paren ( - SynPat.identWithArgs - [ Ident.create "KeyValue" ] - (SynArgPats.create [ Ident.create "key" ; Ident.create "value" ]) - ), + SynPat.paren (SynPat.nameWithArgs "KeyValue" [ SynPat.named "key" ; SynPat.named "value" ]), SynExpr.createIdent "field", SynExpr.applyFunction (SynExpr.createLongIdent [ "ret" ; "Add" ]) @@ -275,9 +269,9 @@ module internal JsonSerializeGenerator = |> List.map (fun unionCase -> let propertyName = getPropertyName unionCase.Ident unionCase.Attrs - let caseNames = unionCase.Fields |> List.mapi (fun i _ -> Ident.create $"arg%i{i}") + let caseNames = unionCase.Fields |> List.mapi (fun i _ -> $"arg%i{i}") - let argPats = SynArgPats.create caseNames + let argPats = SynArgPats.createNamed caseNames let pattern = SynPat.LongIdent ( @@ -311,7 +305,7 @@ module internal JsonSerializeGenerator = let propertyName = getPropertyName (Option.get fieldData.Ident) fieldData.Attrs let node = - SynExpr.applyFunction (fst (serializeNode fieldData.Type)) (SynExpr.createIdent' caseName) + SynExpr.applyFunction (fst (serializeNode fieldData.Type)) (SynExpr.createIdent caseName) [ propertyName ; node ] |> SynExpr.tuple diff --git a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt index dd41183..0d55ba3 100644 --- a/WoofWare.Myriad.Plugins/SurfaceBaseline.txt +++ b/WoofWare.Myriad.Plugins/SurfaceBaseline.txt @@ -1,3 +1,5 @@ +WoofWare.Myriad.Plugins.ArgParserGenerator inherit obj, implements Myriad.Core.IMyriadGenerator +WoofWare.Myriad.Plugins.ArgParserGenerator..ctor [constructor]: unit WoofWare.Myriad.Plugins.CreateCatamorphismGenerator inherit obj, implements Myriad.Core.IMyriadGenerator WoofWare.Myriad.Plugins.CreateCatamorphismGenerator..ctor [constructor]: unit WoofWare.Myriad.Plugins.HttpClientGenerator inherit obj, implements Myriad.Core.IMyriadGenerator diff --git a/WoofWare.Myriad.Plugins/SynExpr/PreXmlDoc.fs b/WoofWare.Myriad.Plugins/SynExpr/PreXmlDoc.fs index 54ac2f4..abb6b11 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/PreXmlDoc.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/PreXmlDoc.fs @@ -7,3 +7,6 @@ open Fantomas.FCS.Text.Range module internal PreXmlDoc = let create (s : string) : PreXmlDoc = PreXmlDoc.Create ([| " " + s |], range0) + + let create' (s : string seq) : PreXmlDoc = + PreXmlDoc.Create (Array.ofSeq s, range0) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs b/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs index 0bf66a4..35e9f97 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynArgPats.fs @@ -1,16 +1,30 @@ namespace WoofWare.Myriad.Plugins open Fantomas.FCS.Syntax +open Fantomas.FCS.Text.Range [] module internal SynArgPats = - let create (caseNames : Ident list) : SynArgPats = + let createNamed (caseNames : string list) : SynArgPats = match caseNames.Length with | 0 -> SynArgPats.Pats [] - | 1 -> [ SynPat.named caseNames.[0].idText ] |> SynArgPats.Pats - | _ -> - caseNames - |> List.map (fun i -> SynPat.named i.idText) - |> SynPat.tuple + | 1 -> + SynPat.Named (SynIdent.SynIdent (Ident.create caseNames.[0], None), false, None, range0) + |> List.singleton + |> SynArgPats.Pats + | len -> + caseNames + |> List.map (fun name -> SynPat.Named (SynIdent.SynIdent (Ident.create name, None), false, None, range0)) + |> fun t -> SynPat.Tuple (false, t, List.replicate (len - 1) range0, range0) + |> fun t -> SynPat.Paren (t, range0) + |> List.singleton + |> SynArgPats.Pats + + let create (pats : SynPat list) : SynArgPats = + match pats.Length with + | 0 -> SynArgPats.Pats [] + | 1 -> [ pats.[0] ] |> SynArgPats.Pats + | len -> + SynPat.Paren (SynPat.Tuple (false, pats, List.replicate (len - 1) range0, range0), range0) |> List.singleton |> SynArgPats.Pats diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs b/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs index f724d6f..7a3bf3c 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynExpr.fs @@ -260,6 +260,12 @@ module internal SynExpr = exprs |> List.reduce (fun a b -> SynExpr.Sequential (DebugPointAtSequential.SuppressNeither, false, a, b, range0)) + let listLiteral (elts : SynExpr list) : SynExpr = + SynExpr.ArrayOrListComputed (false, sequential elts, range0) + + let arrayLiteral (elts : SynExpr list) : SynExpr = + SynExpr.ArrayOrListComputed (true, sequential elts, range0) + /// {compExpr} { {lets} ; return {ret} } let createCompExpr (compExpr : string) (retBody : SynExpr) (lets : CompExprBinding list) : SynExpr = let retStatement = SynExpr.YieldOrReturn ((false, true), retBody, range0) diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynPat.fs b/WoofWare.Myriad.Plugins/SynExpr/SynPat.fs index 0241bd1..282ad91 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynPat.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynPat.fs @@ -7,6 +7,8 @@ open Fantomas.FCS.Text.Range module internal SynPat = let inline paren (pat : SynPat) : SynPat = SynPat.Paren (pat, range0) + let anon : SynPat = SynPat.Wild range0 + let inline annotateTypeNoParen (ty : SynType) (pat : SynPat) = SynPat.Typed (pat, ty, range0) let inline annotateType (ty : SynType) (pat : SynPat) = paren (annotateTypeNoParen ty pat) @@ -20,6 +22,9 @@ module internal SynPat = let inline identWithArgs (i : LongIdent) (args : SynArgPats) : SynPat = SynPat.LongIdent (SynLongIdent.create i, None, None, args, None, range0) + let inline nameWithArgs (i : string) (args : SynPat list) : SynPat = + identWithArgs [ Ident.create i ] (SynArgPats.create args) + let inline tupleNoParen (elements : SynPat list) : SynPat = match elements with | [] -> failwith "Can't tuple no elements in a pattern" diff --git a/WoofWare.Myriad.Plugins/SynExpr/SynType.fs b/WoofWare.Myriad.Plugins/SynExpr/SynType.fs index 5e796f2..2bfee6c 100644 --- a/WoofWare.Myriad.Plugins/SynExpr/SynType.fs +++ b/WoofWare.Myriad.Plugins/SynExpr/SynType.fs @@ -251,6 +251,15 @@ module internal SynTypePatterns = | _ -> None | _ -> None + let (|TimeSpan|_|) (fieldType : SynType) = + match fieldType with + | SynType.LongIdent (SynLongIdent.SynLongIdent (ident, _, _)) -> + match ident |> List.map (fun i -> i.idText) with + | [ "System" ; "TimeSpan" ] + | [ "TimeSpan" ] -> Some () + | _ -> None + | _ -> None + [] module internal SynType = let rec stripOptionalParen (ty : SynType) : SynType = @@ -306,6 +315,56 @@ module internal SynType = let toFun (inputs : SynType list) (ret : SynType) : SynType = (ret, List.rev inputs) ||> List.fold (fun ty input -> funFromDomain input ty) + let primitiveToHumanReadableString (name : LongIdent) : string = + match name |> List.map _.idText with + | [ "System" ; "Single" ] -> "single" + | [ "System" ; "Double" ] -> "double" + | [ "System" ; "Byte" ] -> "byte" + | [ "System" ; "SByte" ] -> "signed byte" + | [ "System" ; "Int16" ] -> "int16" + | [ "System" ; "Int32" ] -> "int32" + | [ "System" ; "Int64" ] -> "int64" + | [ "System" ; "UInt16" ] -> "uint16" + | [ "System" ; "UInt32" ] -> "uint32" + | [ "System" ; "UInt64" ] -> "uint64" + | [ "System" ; "Char" ] -> "char" + | [ "System" ; "Decimal" ] -> "decimal" + | [ "System" ; "String" ] -> "string" + | [ "System" ; "Boolean" ] -> "bool" + | ty -> + ty + |> String.concat "." + |> failwithf "could not create human-readable string for primitive type %s" + + let rec toHumanReadableString (ty : SynType) : string = + match ty with + | PrimitiveType t1 -> primitiveToHumanReadableString t1 + | OptionType t1 -> toHumanReadableString t1 + " option" + | NullableType t1 -> toHumanReadableString t1 + " Nullable" + | ChoiceType ts -> + ts + |> List.map toHumanReadableString + |> String.concat ", " + |> sprintf "Choice<%s>" + | MapType (k, v) + | DictionaryType (k, v) + | IDictionaryType (k, v) + | IReadOnlyDictionaryType (k, v) -> sprintf "map<%s, %s>" (toHumanReadableString k) (toHumanReadableString v) + | ListType t1 -> toHumanReadableString t1 + " list" + | ArrayType t1 -> toHumanReadableString t1 + " array" + | Task t1 -> toHumanReadableString t1 + " Task" + | UnitType -> "unit" + | FileInfo -> "FileInfo" + | DirectoryInfo -> "DirectoryInfo" + | Uri -> "URI" + | Stream -> "Stream" + | Guid -> "GUID" + | BigInt -> "bigint" + | DateTimeOffset -> "DateTimeOffset" + | DateOnly -> "DateOnly" + | TimeSpan -> "TimeSpan" + | ty -> failwithf "could not compute human-readable string for type: %O" ty + /// Guess whether the types are equal. We err on the side of saying "no, they're different". let rec provablyEqual (ty1 : SynType) (ty2 : SynType) : bool = if Object.ReferenceEquals (ty1, ty2) then diff --git a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj index d756b8e..43bfedb 100644 --- a/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj +++ b/WoofWare.Myriad.Plugins/WoofWare.Myriad.Plugins.fsproj @@ -31,13 +31,13 @@ + - @@ -55,6 +55,7 @@ + diff --git a/WoofWare.Myriad.Plugins/version.json b/WoofWare.Myriad.Plugins/version.json index 35d1803..ca0004c 100644 --- a/WoofWare.Myriad.Plugins/version.json +++ b/WoofWare.Myriad.Plugins/version.json @@ -1,5 +1,5 @@ { - "version": "2.1", + "version": "2.2", "publicReleaseRefSpec": [ "^refs/heads/main$" ],