Skip to content
Newer
Older
100644 247 lines (228 sloc) 8.29 KB
41df027 @sorear Start drafting port of Sub introspection, MAIN_HELPER
authored Jan 22, 2012
1 # the following was adapted from Geoffrey Broadwell's code in Rakudo nom
2 # * $?USAGE
3 # * Create $?USAGE at compile time
4 # * Make $?USAGE available globally
5 # * Command-line parsing
6 # * Allow both = and space before argument of double-dash args
7 # * Comma-separated list values
8 # * Allow exact Perl 6 forms, quoted away from shell
9 # * Fix remaining XXXX
10
566fb13 @sorear Fix "\r\n".perl
authored Jan 23, 2012
11 # TODO (sorear): add True, False to val(); (eval) becomes -e; change param
12 # names to be name-of-var or ""; Str.perl escaping
41df027 @sorear Start drafting port of Sub introspection, MAIN_HELPER
authored Jan 22, 2012
13
14 use MONKEY_TYPING;
15 augment class Code {
16 method candidates() { Q:CgOp { (code_candidates (@ {self})) } }
17 method signature() { Q:CgOp { (code_signature (@ {self})) } }
18 method candidates_matching(|$cap) { grep *.accepts_capture($cap), self.candidates }
19 method accepts_capture($cap) { Q:CgOp { (code_accepts_capture (@ {self}) (@ {$cap})) } }
20 method name() { Q:CgOp { (code_name (@ {self})) } }
21 }
22 augment class Routine {
23 method perl() {
24 self // nextsame;
25 my $perl = self.^name.lc();
26 if self.name() -> $n {
27 $perl ~= " $n";
28 }
29 $perl ~= self.signature().perl.substr(1);
30 $perl ~= ' { ... }';
31 $perl
32 }
33 }
34 augment class Signature {
35 method params() { Q:CgOp { (sig_params (@ {self})) } }
36 method arity() { Q:CgOp { (box Int (sig_arity (@ {self}))) } }
37 method count() { Q:CgOp { (box Int (sig_count (@ {self}))) } }
38 # XXX TODO: Parameter separators.
39 method perl() {
40 self // nextsame;
41 ':(' ~ join(', ', self.params».perl) ~ ')';
42 }
43 }
44 augment class Parameter {
45 # Value processing
46 our constant HASTYPE = 1;
47 our constant MULTI_IGNORED = 16384;
48 our constant ANY_DEF = 0x40000;
49 our constant UNDEF_ONLY = 0x80000;
50 our constant DEF_ONLY = 0xC0000;
51 our constant TYPE_ONLY = 0x100000;
52 our constant DEF_MASK = 0x1C0000;
53
54 # Value binding
55 our constant READWRITE = 2;
56 our constant RWTRANS = 8;
57 our constant INVOCANT = 8192;
58 our constant IS_COPY = 32768;
59 our constant IS_LIST = 65536;
60 our constant IS_HASH = 131072;
61 our constant CALLABLE = 0x20_0000;
62
63 # Value source
64 our constant HASDEFAULT = 32;
65 our constant OPTIONAL = 64;
66 our constant DEFOUTER = 4096;
67 our constant POSITIONAL = 128;
68 our constant SLURPY_POS = 256;
69 our constant SLURPY_NAM = 512;
70 our constant SLURPY_CAP = 1024;
71 our constant SLURPY_PCL = 2048;
72
73 method named() { !!! }
74 method named_names() { !!! }
75 method type() { !!! }
76 method optional() { !!! }
566fb13 @sorear Fix "\r\n".perl
authored Jan 24, 2012
77 method positional() { !!! }
41df027 @sorear Start drafting port of Sub introspection, MAIN_HELPER
authored Jan 22, 2012
78 method value_constraint_list() { !!! }
79 method name() { !!! }
80 method slurpy() { !!! }
81
566fb13 @sorear Fix "\r\n".perl
authored Jan 24, 2012
82 # no constraint_list! niecza's SubInfo constraints don't reflect well :|
83 method parcel() { !!! }
84 method capture() { !!! }
85 method rw() { !!! }
86 method copy() { !!! }
87 method readonly() { !!! }
88 method invocant() { !!! }
89 method default() { !!! }
41df027 @sorear Start drafting port of Sub introspection, MAIN_HELPER
authored Jan 22, 2012
90
91 # XXX TODO: A few more bits :-)
92 multi method perl(Parameter:D:) {
93 my $perl = '';
94 my $flags = self.flags;
95 my $type = self.type.^name;
96 if $flags +& IS_LIST {
97 # XXX Need inner type
98 }
99 elsif $flags +& IS_HASH {
100 # XXX Need inner type
101 }
102 else {
103 $perl = $type;
104 if $flags +& DEF_ONLY {
105 $perl ~= ':D';
106 } elsif $flags +& UNDEF_ONLY {
107 $perl ~= ':U';
108 } elsif $flags +& TYPE_ONLY {
109 $perl ~= ':T';
110 }
111 $perl ~= ' ';
112 }
113 if self.name -> $name {
114 if $flags +& SLURPY_CAP {
115 $perl ~= '|' ~ $name;
116 } elsif $flags +& RWTRANS {
117 $perl ~= '\\' ~ $name;
118 } else {
119 my $default = self.default();
120 if self.named_names -> @names {
121 my $short = $name.substr(1);
122 $name = ':' ~ $name if $short eq any @names;
123 for @names {
124 next if $_ eq $short;
125 $name = ':' ~ $_ ~ '(' ~ $name ~ ')';
126 }
127 $name ~= '!' unless self.optional;
128 } elsif self.optional && !$default {
129 $name ~= '?';
130 } elsif self.slurpy {
131 $name = '*' ~ $name;
132 }
133 $perl ~= $name;
134 if $!flags +& READWRITE {
135 $perl ~= ' is rw';
136 } elsif $!flags +& IS_COPY {
137 $perl ~= ' is copy';
138 }
139 $perl ~= ' = { ... }' if $default;
140 if self.sub_signature -> $sub {
141 $perl ~= ' ' ~ $sub.perl;
142 }
143 }
144 }
145 $perl
146 }
147 }
148 augment class ClassHOW {
149 method name($) { Q:CgOp { (box Str (obj_typename (stab_what (unbox stable (@ {self}))))) } }
150 }
151
152 my sub MAIN_HELPER() {
153 # Do we have a MAIN at all?
154 my $m = CALLER::<&MAIN>;
155 return unless $m;
156
157 # Convert raw command line args into positional and named args for MAIN
158 my sub process-cmd-args (@args is copy) {
159 my (@positional-arguments, %named-arguments);
160 while (@args) {
161 my $passed-value = @args.shift;
162 if $passed-value ~~ /^ ( '--' | '-' | ':' ) ('/'?) (<-[0..9\.]> .*) $/ {
163 my ($switch, $negate, $arg) = (~$0, ?((~$1).chars), ~$2);
164
165 if $arg.index('=').defined {
166 my ($name, $value) = $arg.split('=', 2);
167 $value = val($value);
168 $value = $value but False if $negate;
169 %named-arguments.push: $name => $value;
170 } else {
171 %named-arguments.push: $arg => !$negate;
172 }
173 } else {
174 @args.unshift($passed-value) unless $passed-value eq '--';
175 @positional-arguments.push: @args.map: &val;
176 last;
177 }
178 }
179
180 return @positional-arguments, %named-arguments;
181 }
182
183 # Generate $?USAGE string (default usage info for MAIN)
184 my sub gen-usage () {
185 my @help-msgs;
186 my $prog-name = $*PROGRAM_NAME eq '-e' ?? "-e '...'" !! $*PROGRAM_NAME;
187 for $m.candidates -> $sub {
188 my (@required-named, @optional-named, @positional);
189 for $sub.signature.params -> $param {
190 my $argument;
191 if $param.named {
192 my @names = $param.named_names.reverse;
193 $argument = @names.map({($^n.chars == 1 ?? '-' !! '--') ~ $^n}).join('|');
194 $argument ~= "=<{$param.type.^name}>" unless $param.type === Bool;
195 if $param.optional {
196 @optional-named.push("[$argument]");
197 }
198 else {
199 @required-named.push($argument);
200 }
201 }
202 else {
203 my $constraints = $param.value_constraint_list;
204 $argument = $constraints ?? $constraints !!
205 $param.name ?? '<' ~ $param.name.substr(1) ~ '>' !!
206 '<' ~ $param.type.^name ~ '>' ;
207
208 $argument = "[$argument ...]" if $param.slurpy;
209 $argument = "[$argument]" if $param.optional;
210 @positional.push($argument);
211 }
212 }
213 my $msg = join(' ', $prog-name, @required-named, @optional-named, @positional);
214 @help-msgs.push($msg);
215 }
216 my $usage = "Usage:\n" ~ @help-msgs.map(' ' ~ *).join("\n");
217 return $usage;
218 }
219
220 # Process command line arguments
221 my ($p, $n) = process-cmd-args(@*ARGS).lol;
222
223 # Generate default $?USAGE message
224 my $USAGE = gen-usage();
225
226 # If dispatch to MAIN is possible, do so
227 if $m.candidates_matching(|@($p), |%($n)).elems {
228 return $m(|@($p), |%($n));
229 }
230
231 # We could not find the correct MAIN to dispatch to!
232 # Let's try to run a user defined USAGE sub
233 my $h = CALLER::<&USAGE>;
234 return $h() if $h;
235
236 # We could not find a user defined USAGE sub!
237 # Let's display the default USAGE message
238 if ($n<help>) {
239 $*OUT.say($USAGE);
240 exit 1;
241 }
242 else {
243 $*ERR.say($USAGE);
244 exit 2;
245 }
246 }
Something went wrong with that request. Please try again.