Skip to content
Browse files

More sub introspection fiddles, add MAIN_HELPER to setting

  • Loading branch information...
1 parent 6dab8a6 commit 7f9a5148bea8dccdbdc9c2742e87274917baa8ab @sorear committed
Showing with 120 additions and 104 deletions.
  1. +19 −0 lib/Builtins.cs
  2. +98 −0 lib/CORE.setting
  3. +3 −104 main.pl
View
19 lib/Builtins.cs
@@ -2770,10 +2770,29 @@ public class Blackhole : Variable {
return Kernel.AnyMO.typeObject;
}
+ public static Variable param_value_constraints(P6any param) {
+ var p = param as Parameter;
+ VarDeque items = new VarDeque();
+ if (p.post_constraints != null) {
+ foreach (object o in p.post_constraints) {
+ if (o is Variable)
+ items.Push((Variable)o);
+ }
+ }
+ return Kernel.NewRWListVar(MakeList(items, new VarDeque()));
+ }
+
public static string param_name(P6any param) {
return ((Parameter)param).name;
}
+ public static Frame code_accepts_capture(Frame th, P6any code, P6any cap) {
+ return Kernel.GetInfo(code).SetupCall(th, Kernel.GetOuter(code), code,
+ (Variable[])cap.GetSlot(Kernel.CaptureMO, "$!positionals"),
+ (VarHash)cap.GetSlot(Kernel.CaptureMO, "$!named"),
+ true, null);
+ }
+
public static System.IO.TextReader treader_stdin() {
return new System.IO.StreamReader(Console.OpenStandardInput(), Console.InputEncoding);
}
View
98 lib/CORE.setting
@@ -918,6 +918,7 @@ my class Code does Callable {
method outer() { Q:CgOp { (ns (getslot Code $!outer frame (@ {self}))) } }
method perl() { defined(self) ?? '{ ... }' !! self.typename }
+ method accepts_capture($cap) { Q:CgOp { (code_accepts_capture (@ {self}) (@ {$cap})) } }
method candidates(Code:D:) { Q:CgOp { (code_candidates (@ {self})) } }
method signature(Code:D:) { Q:CgOp { (ns (code_signature (@ {self}))) } }
method candidates_matching(|$cap) { grep *.accepts_capture($cap), self.candidates }
@@ -992,6 +993,7 @@ my class Parameter {
method slurpy() { ?( self.flags +& (SLURPY_CAP + SLURPY_NAM + SLURPY_POS) ) }
# no constraint_list! niecza's SubInfo constraints don't reflect well :|
+ method value_constraint_list(Parameter:D:) { Q:CgOp { (param_value_constraints (@ {self})) } }
method parcel() { ?( self.flags +& RWTRANS ) }
method capture() { ?( self.flags +& SLURPY_CAP ) }
method rw() { ?( self.flags +& READWRITE ) }
@@ -3307,6 +3309,102 @@ sub roll($num, *@values) { @values.roll($num) }
sub rotate(@array, $n = 1) { @array.rotate($n) }
sub reduce($expression, *@values) { @values.reduce($expression) }
+my sub MAIN_HELPER() {
+ # Do we have a MAIN at all?
+ my $m = CALLER::<&MAIN>;
+ return unless $m;
+
+ # Convert raw command line args into positional and named args for MAIN
+ my sub process-cmd-args (@args is copy) {
+ my (@positional-arguments, %named-arguments);
+ while (@args) {
+ my $passed-value = @args.shift;
+ if $passed-value ~~ /^ ( '--' | '-' | ':' ) ('/'?) (<-[0..9\.]> .*) $/ {
+ my ($switch, $negate, $arg) = (~$0, ?((~$1).chars), ~$2); #OK not used
+
+ if $arg.index('=').defined {
+ my ($name, $value) = $arg.split('=', 2);
+ $value = val($value);
+ $value = $value but False if $negate;
+ %named-arguments.push: $name => $value;
+ } else {
+ %named-arguments.push: $arg => !$negate;
+ }
+ } else {
+ @args.unshift($passed-value) unless $passed-value eq '--';
+ @positional-arguments.push: @args.map: &val;
+ last;
+ }
+ }
+
+ return \(|@positional-arguments, |%named-arguments);
+ }
+
+ # Generate $?USAGE string (default usage info for MAIN)
+ my sub gen-usage () {
+ my @help-msgs;
+ my $prog-name = $*PROGRAM_NAME eq '-e' ?? "-e '...'" !! $*PROGRAM_NAME;
+ for $m.candidates -> $sub {
+ my (@required-named, @optional-named, @positional);
+ for $sub.signature.params -> $param {
+ my $argument;
+ if $param.named {
+ my @names = $param.named_names.reverse;
+ $argument = @names.map({($^n.chars == 1 ?? '-' !! '--') ~ $^n}).join('|');
+ $argument ~= "=<{$param.type.^name}>" unless $param.type === Bool;
+ if $param.optional {
+ @optional-named.push("[$argument]");
+ }
+ else {
+ @required-named.push($argument);
+ }
+ }
+ else {
+ my $constraints = $param.value_constraint_list;
+ $argument = $constraints ?? $constraints !!
+ $param.name ?? '<' ~ $param.name.substr(1) ~ '>' !!
+ '<' ~ $param.type.^name ~ '>' ;
+
+ $argument = "[$argument ...]" if $param.slurpy;
+ $argument = "[$argument]" if $param.optional;
+ @positional.push($argument);
+ }
+ }
+ my $msg = join(' ', $prog-name, @required-named, @optional-named, @positional);
+ @help-msgs.push($msg);
+ }
+ my $usage = "Usage:\n" ~ @help-msgs.map(' ' ~ *).join("\n");
+ return $usage;
+ }
+
+ # Process command line arguments
+ my $cap = process-cmd-args(@*ARGS);
+
+ # Generate default $?USAGE message
+ my $USAGE = gen-usage();
+
+ # If dispatch to MAIN is possible, do so
+ if $m.candidates_matching(|$cap).elems {
+ return $m(|$cap);
+ }
+
+ # We could not find the correct MAIN to dispatch to!
+ # Let's try to run a user defined USAGE sub
+ my $h = CALLER::<&USAGE>;
+ return $h() if $h;
+
+ # We could not find a user defined USAGE sub!
+ # Let's display the default USAGE message
+ if ($cap.hash<help>) {
+ $*OUT.say($USAGE);
+ exit 1;
+ }
+ else {
+ $*ERR.say($USAGE);
+ exit 2;
+ }
+}
+
INIT {
$PROCESS::IN ::= Q:CgOp { (box TextReader (treader_stdin)) };
$PROCESS::OUT ::= Q:CgOp { (box TextWriter (twriter_stdout)) };
View
107 main.pl
@@ -11,108 +11,7 @@
# TODO (sorear): add True, False to val(); (eval) becomes -e; change param
# names to be name-of-var or ""; Str.perl escaping
-use MONKEY_TYPING;
-augment class Code {
-## method accepts_capture($cap) { Q:CgOp { (code_accepts_capture (@ {self}) (@ {$cap})) } }
-}
+multi MAIN('foo', :$sam) { say "A" }
+multi MAIN('bar', $quux) { say "B", $quux };
-for &die.candidates { say .signature.perl }
-for &splice.candidates { say .signature.perl }
-
-#`〈
-my sub MAIN_HELPER() {
- # Do we have a MAIN at all?
- my $m = CALLER::<&MAIN>;
- return unless $m;
-
- # Convert raw command line args into positional and named args for MAIN
- my sub process-cmd-args (@args is copy) {
- my (@positional-arguments, %named-arguments);
- while (@args) {
- my $passed-value = @args.shift;
- if $passed-value ~~ /^ ( '--' | '-' | ':' ) ('/'?) (<-[0..9\.]> .*) $/ {
- my ($switch, $negate, $arg) = (~$0, ?((~$1).chars), ~$2);
-
- if $arg.index('=').defined {
- my ($name, $value) = $arg.split('=', 2);
- $value = val($value);
- $value = $value but False if $negate;
- %named-arguments.push: $name => $value;
- } else {
- %named-arguments.push: $arg => !$negate;
- }
- } else {
- @args.unshift($passed-value) unless $passed-value eq '--';
- @positional-arguments.push: @args.map: &val;
- last;
- }
- }
-
- return @positional-arguments, %named-arguments;
- }
-
- # Generate $?USAGE string (default usage info for MAIN)
- my sub gen-usage () {
- my @help-msgs;
- my $prog-name = $*PROGRAM_NAME eq '-e' ?? "-e '...'" !! $*PROGRAM_NAME;
- for $m.candidates -> $sub {
- my (@required-named, @optional-named, @positional);
- for $sub.signature.params -> $param {
- my $argument;
- if $param.named {
- my @names = $param.named_names.reverse;
- $argument = @names.map({($^n.chars == 1 ?? '-' !! '--') ~ $^n}).join('|');
- $argument ~= "=<{$param.type.^name}>" unless $param.type === Bool;
- if $param.optional {
- @optional-named.push("[$argument]");
- }
- else {
- @required-named.push($argument);
- }
- }
- else {
- my $constraints = $param.value_constraint_list;
- $argument = $constraints ?? $constraints !!
- $param.name ?? '<' ~ $param.name.substr(1) ~ '>' !!
- '<' ~ $param.type.^name ~ '>' ;
-
- $argument = "[$argument ...]" if $param.slurpy;
- $argument = "[$argument]" if $param.optional;
- @positional.push($argument);
- }
- }
- my $msg = join(' ', $prog-name, @required-named, @optional-named, @positional);
- @help-msgs.push($msg);
- }
- my $usage = "Usage:\n" ~ @help-msgs.map(' ' ~ *).join("\n");
- return $usage;
- }
-
- # Process command line arguments
- my ($p, $n) = process-cmd-args(@*ARGS).lol;
-
- # Generate default $?USAGE message
- my $USAGE = gen-usage();
-
- # If dispatch to MAIN is possible, do so
- if $m.candidates_matching(|@($p), |%($n)).elems {
- return $m(|@($p), |%($n));
- }
-
- # We could not find the correct MAIN to dispatch to!
- # Let's try to run a user defined USAGE sub
- my $h = CALLER::<&USAGE>;
- return $h() if $h;
-
- # We could not find a user defined USAGE sub!
- # Let's display the default USAGE message
- if ($n<help>) {
- $*OUT.say($USAGE);
- exit 1;
- }
- else {
- $*ERR.say($USAGE);
- exit 2;
- }
-}
-〉
+MAIN_HELPER;

0 comments on commit 7f9a514

Please sign in to comment.
Something went wrong with that request. Please try again.