Automatization of SyntaxInformation and argx?

Question

Does anybody have a good way to automate the setting of SyntaxInformation for any custom function? I have a ton of functions for which I want to set SyntaxInformation, and doing it by hand seems a little pointless. Here's what I've come up with so far:

SetSyntaxInformation[symbol_Symbol] := 
  Module[{argcounts, transposecounts, argpatt},
   argcounts = With[{sym = symbol},
     Cases[
      DownValues[sym],
      HoldPattern[Verbatim[HoldPattern][sym[args___]] :> _] :> CountArguments[args]
      ]
     ];
   transposecounts = Transpose@PadRight[argcounts];
   argpatt = ArgumentCountToPattern@Union[#] & /@ transposecounts;
   SyntaxInformation[symbol] = {"ArgumentsPattern" -> argpatt}
  ];

ArgumentCountToPattern[{1}]=_;
ArgumentCountToPattern[{0,1}]=_.;
ArgumentCountToPattern[{0,Infinity}]=___;

CountArguments[args___] := CountArgument /@ {args};
CountArgument[Verbatim[PatternTest][pat_, _]] := CountArgument[pat];
CountArgument[Verbatim[Pattern][_,(Verbatim[Blank] | _)[___]]] = 1;
CountArgument[Verbatim[Pattern][_,Verbatim[BlankSequence][___]]] = Sequence[1,Infinity];
CountArgument[Verbatim[Pattern][_,Verbatim[BlankNullSequence][___]]]=Sequence[Infinity];

This attempts to count the number of arguments for each downvalue of a given symbol, and turns this into a "ArgumentsPattern" type list which is subsequently set. Here's an example:

F[x_] := x^2
F[x_, y_] := x^2 + y^2

SetSyntaxInformation[F]
(* {"ArgumentsPattern" -> {_, _.}} *)

Although this seems to get the job done, the code seems a little bit unwieldy and might not be that robust, as it's certainly missing a few cases (like e.g. options).

So my question is: is there any better way to tackle this problem? (And does anybody have something similar for setting argx messages?)

Answer 1

Here is my implementation of auto SyntaxInformation.

ClearAll[optionNames];
optionNames[optionsPatternContent_List] := Module[{},
   getOptionName[x_] := Module[{},
     If[Head@x === Rule, {x[[1]]}, Options[x][[;; , 1]]]];
   If[optionsPatternContent === {}, {},
    ToString /@ 
     DeleteDuplicates@
      Flatten[getOptionName /@ optionsPatternContent]]];

ClearAll[autoSetSynaxInfomation];
autoSetSynaxInfomation[symbol_] := Module[{},
  funcForm = 
   FullForm[
    Cases[DownValues[symbol] /. Verbatim[symbol][x___] :> nullHead[x], nullHead[___], 
      Infinity][[1]]];
  argumentPatternReplaced = funcForm /. {
     Verbatim[Pattern][_, Verbatim[Blank][]] -> _,
     Verbatim[Pattern][_, Verbatim[BlankSequence][]] -> __,
     Verbatim[Pattern][_, Verbatim[BlankNullSequence][]] -> ___,
     Verbatim[Optional][___] -> _.,
     Verbatim[OptionsPattern][___] -> OptionsPattern[],
     Verbatim[Pattern][_, Verbatim[OptionsPattern][___]] -> 
      OptionsPattern[]
     };
  argumentPattern = List @@ argumentPatternReplaced[[1]];
  optionsPatternContent = 
   DeleteDuplicates@Prepend[Flatten@Cases[funcForm, Verbatim[OptionsPattern][x_] :> x, 
     Infinity],symbol];
  SyntaxInformation[symbol] = {"ArgumentsPattern" -> argumentPattern, 
    "OptionNames" -> optionNames@optionsPatternContent}
  ]

Usage :

ClearAll[g]; 
g[{x_, y__}, k_: 1, l_: 9, 
  opts : OptionsPattern[{Area, Volume, pop -> 1, bob -> 2}]] := p

autoSetSynaxInfomation[g]

will set the syntax of function g as

{"ArgumentsPattern" -> {{_, __}, _., _., OptionsPattern[]}, 
 "OptionNames" -> {"Assumptions", "Method", "WorkingPrecision", "pop",
    "bob"}}

Note that my version used undocumented "OptionNames" that can deal with OptionsPattern[] issue discussed here