From d599485f92ec4c54b1ac627f1ffd68fbac1808bc Mon Sep 17 00:00:00 2001 From: Julien Roncaglia Date: Mon, 12 Mar 2018 00:22:55 +0100 Subject: [PATCH 1/4] Don't recompute UnionCaseInfo attributes --- src/Argu/PreCompute.fs | 67 +++++++++++++++++++++++++++--------------- src/Argu/Utils.fs | 34 --------------------- 2 files changed, 44 insertions(+), 57 deletions(-) diff --git a/src/Argu/PreCompute.fs b/src/Argu/PreCompute.fs index fffeaf6d..f4d5f11b 100644 --- a/src/Argu/PreCompute.fs +++ b/src/Argu/PreCompute.fs @@ -9,6 +9,23 @@ open System.Text.RegularExpressions open FSharp.Reflection +[] +module private FastAttributes = + let inline hasAttribute<'T when 'T :> Attribute> (attributes: obj[]) = + attributes |> Array.tryFindIndex (fun x -> x :? 'T) <> None + + let inline hasAttribute2<'T when 'T :> Attribute> (attributes1: obj[]) (attributes2: Attribute[]) = + (hasAttribute<'T> attributes1) || (attributes2 |> Array.tryFindIndex (fun x -> x :? 'T) <> None) + + let inline tryGetAttribute<'T when 'T :> Attribute> (attributes: obj[]) = + attributes |> Array.tryFind (fun x -> x :? 'T) |> Option.map (fun x -> x :?> 'T) + + let inline tryGetAttribute2<'T when 'T :> Attribute> (attributes: obj[]) (attributes2: Attribute[]) = + match tryGetAttribute<'T> attributes with + | Some _ as attr -> attr + | None -> + attributes2 |> Array.tryFind (fun x -> x :? 'T) |> Option.map (fun x -> x :?> 'T) + let defaultHelpParam = "help" let defaultHelpDescription = "display this list of options." @@ -21,9 +38,9 @@ let getDefaultHelpParam (t : Type) = prefixString + defaultHelpParam /// construct a CLI param from UCI name -let generateOptionName (uci : UnionCaseInfo) = +let generateOptionName (uci : UnionCaseInfo) (attributes1: obj[]) (attributes2: Attribute[])= let prefixString = - match uci.TryGetAttribute(true) with + match tryGetAttribute2 attributes1 attributes2 with | None -> CliPrefix.DoubleDash | Some pf -> pf.Prefix @@ -133,7 +150,7 @@ let tryGetDuEnumerationParser label (t : Type) = let tagReader = lazy(FSharpValue.PreComputeUnionTagReader(t, allBindings)) let extractUciInfo (uci : UnionCaseInfo) = let name = - match uci.TryGetAttribute() with + match tryGetAttribute (uci.GetCustomAttributes()) with | None -> generateEnumName uci.Name | Some attr -> attr.Name @@ -280,18 +297,21 @@ let rec private preComputeUnionCaseArgInfo (stack : Type list) (helpParam : Help let current = ref None let tryGetCurrent = fun () -> !current - let isNoCommandLine = lazy(uci.ContainsAttribute (true)) - let isAppSettingsCSV = lazy(uci.ContainsAttribute ()) - let isExactlyOnce = lazy(uci.ContainsAttribute (true)) - let isMandatory = lazy(isExactlyOnce.Value || uci.ContainsAttribute (true)) - let isUnique = lazy(isExactlyOnce.Value || uci.ContainsAttribute (true)) - let isInherited = lazy(uci.ContainsAttribute ()) - let isGatherAll = lazy(uci.ContainsAttribute ()) - let isRest = lazy(uci.ContainsAttribute ()) - let isHidden = lazy(uci.ContainsAttribute ()) + let attributes = lazy(uci.GetCustomAttributes()) + let declaringTypeAttributes = lazy(uci.DeclaringType.GetCustomAttributes() |> Array.ofSeq) + + let isNoCommandLine = lazy(hasAttribute2 attributes.Value declaringTypeAttributes.Value) + let isAppSettingsCSV = lazy(hasAttribute attributes.Value) + let isExactlyOnce = lazy(hasAttribute2 attributes.Value declaringTypeAttributes.Value) + let isMandatory = lazy(isExactlyOnce.Value || hasAttribute2 attributes.Value declaringTypeAttributes.Value) + let isUnique = lazy(isExactlyOnce.Value || hasAttribute2 attributes.Value declaringTypeAttributes.Value) + let isInherited = lazy(hasAttribute attributes.Value) + let isGatherAll = lazy(hasAttribute attributes.Value) + let isRest = lazy(hasAttribute attributes.Value) + let isHidden = lazy(hasAttribute attributes.Value) let mainCommandName = lazy( - match uci.TryGetAttribute () with + match tryGetAttribute attributes.Value with | None -> None | Some _ when isNoCommandLine.Value -> arguExn "parameter '%O' contains conflicting attributes 'MainCommand' and 'NoCommandLine'." uci | Some _ when types.Length = 0 -> arguExn "parameter '%O' contains MainCommand attribute but has unsupported arity 0." uci @@ -304,7 +324,7 @@ let rec private preComputeUnionCaseArgInfo (stack : Type list) (helpParam : Help let isMainCommand = lazy(Option.isSome mainCommandName.Value) let cliPosition = lazy( - match uci.TryGetAttribute () with + match tryGetAttribute attributes.Value with | Some attr -> match attr.Position with | CliPosition.Unspecified @@ -314,7 +334,7 @@ let rec private preComputeUnionCaseArgInfo (stack : Type list) (helpParam : Help | None -> CliPosition.Unspecified) let customAssignmentSeparator = lazy( - match uci.TryGetAttribute (true) with + match tryGetAttribute2 attributes.Value declaringTypeAttributes.Value with | Some attr -> if isMainCommand.Value && types.Length = 1 then arguExn "parameter '%O' of arity 1 contains incompatible attributes 'CustomAssignment' and 'MainCommand'." uci @@ -329,7 +349,7 @@ let rec private preComputeUnionCaseArgInfo (stack : Type list) (helpParam : Help | None -> None) let isGatherUnrecognized = lazy( - if uci.ContainsAttribute() then + if hasAttribute attributes.Value then match types with | _ when isMainCommand.Value -> arguExn "parameter '%O' contains incompatible combination of attributes 'MainCommand' and 'GatherUnrecognized'." uci | [|t|] when t = typeof -> true @@ -338,7 +358,7 @@ let rec private preComputeUnionCaseArgInfo (stack : Type list) (helpParam : Help false) let appSettingsSeparators, appSettingsSplitOptions = - match uci.TryGetAttribute (true) with + match tryGetAttribute2 attributes.Value declaringTypeAttributes.Value with | None -> [|","|], StringSplitOptions.None | Some attr when attr.Separators.Length = 0 -> arguExn "parameter '%O' specifies a null or empty AppSettings separator." uci @@ -408,13 +428,14 @@ let rec private preComputeUnionCaseArgInfo (stack : Type list) (helpParam : Help if isMainCommand.Value || isNoCommandLine.Value then [] else let cliNames = [ - match uci.TryGetAttribute () with - | None -> yield generateOptionName uci + match tryGetAttribute attributes.Value with + | None -> yield generateOptionName uci attributes.Value declaringTypeAttributes.Value | Some attr -> yield attr.Name ; yield! attr.AltNames yield! - uci.GetAttributes() - |> Seq.collect (fun attr -> attr.Names) + attributes.Value + |> Array.filter (fun x -> x :? AltCommandLineAttribute) + |> Array.collect(fun x -> (x :?> AltCommandLineAttribute).Names) ] for name in cliNames do validateCliParam name @@ -422,9 +443,9 @@ let rec private preComputeUnionCaseArgInfo (stack : Type list) (helpParam : Help cliNames) let appSettingsName = lazy( - if uci.ContainsAttribute (true) then None + if hasAttribute2 attributes.Value declaringTypeAttributes.Value then None else - match uci.TryGetAttribute () with + match tryGetAttribute attributes.Value with | None -> Some <| generateAppSettingsName uci | Some _ when parsers.Value.Type = ArgumentType.SubCommand -> arguExn "CustomAppSettings in %O not supported in subcommands." uci | Some attr when not <| String.IsNullOrWhiteSpace attr.Name -> Some attr.Name diff --git a/src/Argu/Utils.fs b/src/Argu/Utils.fs index ee29185d..d6d999ea 100644 --- a/src/Argu/Utils.fs +++ b/src/Argu/Utils.fs @@ -137,40 +137,6 @@ type IDictionary<'K,'V> with let currentProgramName = lazy(System.Diagnostics.Process.GetCurrentProcess().MainModule.ModuleName) -type UnionCaseInfo with - member uci.GetAttributes<'T when 'T :> Attribute> (?includeDeclaringTypeAttrs : bool) = - let includeDeclaringTypeAttrs = defaultArg includeDeclaringTypeAttrs false - - let caseAttrs = uci.GetCustomAttributes typeof<'T> |> Seq.cast - let attrs = - if includeDeclaringTypeAttrs then - uci.DeclaringType.GetCustomAttributes(typeof<'T>, false) - |> Seq.cast - |> Seq.append caseAttrs - else - caseAttrs - - attrs |> Seq.map (fun o -> o :?> 'T) - - member uci.TryGetAttribute<'T when 'T :> Attribute> (?includeDeclaringTypeAttrs : bool) = - let includeDeclaringTypeAttrs = defaultArg includeDeclaringTypeAttrs false - - match uci.GetCustomAttributes typeof<'T> with - | [||] when includeDeclaringTypeAttrs -> - match uci.DeclaringType.GetCustomAttributes(typeof<'T>, false) |> Seq.toArray with - | [||] -> None - | attrs -> Some (attrs.[0] :?> 'T) - | [||] -> None - | attrs -> Some (attrs.[0] :?> 'T) - - member uci.ContainsAttribute<'T when 'T :> Attribute> (?includeDeclaringTypeAttrs : bool) = - let includeDeclaringTypeAttrs = defaultArg includeDeclaringTypeAttrs false - if uci.GetCustomAttributes typeof<'T> |> Array.isEmpty |> not then true - elif includeDeclaringTypeAttrs then - uci.DeclaringType.GetCustomAttributes(typeof<'T>, false) |> Seq.isEmpty |> not - else - false - /// recognize exprs that strictly contain DU constructors /// e.g. <@ Case @> is valid but <@ fun x y -> Case y x @> is invalid let expr2Uci (e : Expr) = From 82a3189d2803b8c497127853485e5dde234a273b Mon Sep 17 00:00:00 2001 From: Julien Roncaglia Date: Mon, 12 Mar 2018 00:34:11 +0100 Subject: [PATCH 2/4] Remove some printf usages --- src/Argu/PreCompute.fs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Argu/PreCompute.fs b/src/Argu/PreCompute.fs index f4d5f11b..74780373 100644 --- a/src/Argu/PreCompute.fs +++ b/src/Argu/PreCompute.fs @@ -458,12 +458,12 @@ let rec private preComputeUnionCaseArgInfo (stack : Type list) (helpParam : Help | [] when isMainCommand.Value -> match parsers.Value with | Primitives ps -> - let name = ps |> Seq.map (fun p -> sprintf "<%s>" p.Description) |> String.concat " " + let name = ps |> Seq.map (fun p -> "<" + p.Description + ">" ) |> String.concat " " if isRest.Value then name + "..." else name - | ListParam(_,p) -> sprintf "<%s>..." p.Description - | _ -> arguExn "internal error in argu parser representation %O." uci + | ListParam(_,p) -> "<" + p.Description + ">..." + | _ -> raise <| new ArguException("internal error in argu parser representation " + (uci.ToString()) + ".") | _ when Option.isSome appSettingsName.Value -> appSettingsName.Value.Value - | _ -> arguExn "parameter '%O' needs to have at least one parse source." uci) + | _ -> raise <| new ArguException("parameter '" + (uci.ToString()) + "' needs to have at least one parse source.")) let fieldReader = Helpers.fieldReader uci let fieldCtor = Helpers.tupleConstructor types From c9d5d4bfc84089fc1043d296b17fdc156d58ba2e Mon Sep 17 00:00:00 2001 From: Julien Roncaglia Date: Mon, 12 Mar 2018 21:25:17 +0100 Subject: [PATCH 3/4] Fix review comments --- src/Argu/PreCompute.fs | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/src/Argu/PreCompute.fs b/src/Argu/PreCompute.fs index 74780373..b4a9a1ca 100644 --- a/src/Argu/PreCompute.fs +++ b/src/Argu/PreCompute.fs @@ -12,19 +12,18 @@ open FSharp.Reflection [] module private FastAttributes = let inline hasAttribute<'T when 'T :> Attribute> (attributes: obj[]) = - attributes |> Array.tryFindIndex (fun x -> x :? 'T) <> None + attributes |> Array.exists (fun x -> x :? 'T) - let inline hasAttribute2<'T when 'T :> Attribute> (attributes1: obj[]) (attributes2: Attribute[]) = - (hasAttribute<'T> attributes1) || (attributes2 |> Array.tryFindIndex (fun x -> x :? 'T) <> None) + let inline hasAttribute2<'T when 'T :> Attribute> (attributes: obj[]) (declaringTypeAttributes: obj[]) = + (hasAttribute<'T> attributes) || (hasAttribute<'T> declaringTypeAttributes) let inline tryGetAttribute<'T when 'T :> Attribute> (attributes: obj[]) = - attributes |> Array.tryFind (fun x -> x :? 'T) |> Option.map (fun x -> x :?> 'T) + attributes |> Array.tryPick (function :? 'T as t -> Some t | _ -> None) - let inline tryGetAttribute2<'T when 'T :> Attribute> (attributes: obj[]) (attributes2: Attribute[]) = + let inline tryGetAttribute2<'T when 'T :> Attribute> (attributes: obj[]) (declaringTypeAttributes: obj[]) = match tryGetAttribute<'T> attributes with | Some _ as attr -> attr - | None -> - attributes2 |> Array.tryFind (fun x -> x :? 'T) |> Option.map (fun x -> x :?> 'T) + | None -> tryGetAttribute<'T> declaringTypeAttributes let defaultHelpParam = "help" let defaultHelpDescription = "display this list of options." @@ -38,9 +37,9 @@ let getDefaultHelpParam (t : Type) = prefixString + defaultHelpParam /// construct a CLI param from UCI name -let generateOptionName (uci : UnionCaseInfo) (attributes1: obj[]) (attributes2: Attribute[])= +let generateOptionName (uci : UnionCaseInfo) (attributes: obj[]) (declaringTypeAttributes: obj[])= let prefixString = - match tryGetAttribute2 attributes1 attributes2 with + match tryGetAttribute2 attributes declaringTypeAttributes with | None -> CliPrefix.DoubleDash | Some pf -> pf.Prefix @@ -298,7 +297,7 @@ let rec private preComputeUnionCaseArgInfo (stack : Type list) (helpParam : Help let tryGetCurrent = fun () -> !current let attributes = lazy(uci.GetCustomAttributes()) - let declaringTypeAttributes = lazy(uci.DeclaringType.GetCustomAttributes() |> Array.ofSeq) + let declaringTypeAttributes = lazy(uci.DeclaringType.GetCustomAttributes(true)) let isNoCommandLine = lazy(hasAttribute2 attributes.Value declaringTypeAttributes.Value) let isAppSettingsCSV = lazy(hasAttribute attributes.Value) @@ -461,9 +460,9 @@ let rec private preComputeUnionCaseArgInfo (stack : Type list) (helpParam : Help let name = ps |> Seq.map (fun p -> "<" + p.Description + ">" ) |> String.concat " " if isRest.Value then name + "..." else name | ListParam(_,p) -> "<" + p.Description + ">..." - | _ -> raise <| new ArguException("internal error in argu parser representation " + (uci.ToString()) + ".") + | _ -> arguExn "internal error in argu parser representation %O." uci | _ when Option.isSome appSettingsName.Value -> appSettingsName.Value.Value - | _ -> raise <| new ArguException("parameter '" + (uci.ToString()) + "' needs to have at least one parse source.")) + | _ -> arguExn "parameter '%O' needs to have at least one parse source." uci) let fieldReader = Helpers.fieldReader uci let fieldCtor = Helpers.tupleConstructor types From 35a8a9edcbaa67157a755a5e74498c2254b47c23 Mon Sep 17 00:00:00 2001 From: Julien Roncaglia Date: Mon, 12 Mar 2018 21:27:54 +0100 Subject: [PATCH 4/4] Apply more comments from review --- src/Argu/PreCompute.fs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Argu/PreCompute.fs b/src/Argu/PreCompute.fs index b4a9a1ca..89f5cce2 100644 --- a/src/Argu/PreCompute.fs +++ b/src/Argu/PreCompute.fs @@ -433,8 +433,7 @@ let rec private preComputeUnionCaseArgInfo (stack : Type list) (helpParam : Help yield! attributes.Value - |> Array.filter (fun x -> x :? AltCommandLineAttribute) - |> Array.collect(fun x -> (x :?> AltCommandLineAttribute).Names) + |> Array.collect(function | :? AltCommandLineAttribute as a -> a.Names | _ -> [||]) ] for name in cliNames do validateCliParam name