Skip to content
Newer
Older
100644 322 lines (288 sloc) 9.9 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
11 # TODO (sorear): add True, False to val(); (eval) becomes -e
12
13 use MONKEY_TYPING;
14 augment class Code {
15 method candidates() { Q:CgOp { (code_candidates (@ {self})) } }
16 method signature() { Q:CgOp { (code_signature (@ {self})) } }
17 method candidates_matching(|$cap) { grep *.accepts_capture($cap), self.candidates }
18 method accepts_capture($cap) { Q:CgOp { (code_accepts_capture (@ {self}) (@ {$cap})) } }
19 method name() { Q:CgOp { (code_name (@ {self})) } }
20 }
21 augment class Routine {
22 method perl() {
23 self // nextsame;
24 my $perl = self.^name.lc();
25 if self.name() -> $n {
26 $perl ~= " $n";
27 }
28 $perl ~= self.signature().perl.substr(1);
29 $perl ~= ' { ... }';
30 $perl
31 }
32 }
33 augment class Signature {
34 method params() { Q:CgOp { (sig_params (@ {self})) } }
35 method arity() { Q:CgOp { (box Int (sig_arity (@ {self}))) } }
36 method count() { Q:CgOp { (box Int (sig_count (@ {self}))) } }
37 # XXX TODO: Parameter separators.
38 method perl() {
39 self // nextsame;
40 ':(' ~ join(', ', self.params».perl) ~ ')';
41 }
42 }
43 augment class Parameter {
44 # Value processing
45 our constant HASTYPE = 1;
46 our constant MULTI_IGNORED = 16384;
47 our constant ANY_DEF = 0x40000;
48 our constant UNDEF_ONLY = 0x80000;
49 our constant DEF_ONLY = 0xC0000;
50 our constant TYPE_ONLY = 0x100000;
51 our constant DEF_MASK = 0x1C0000;
52
53 # Value binding
54 our constant READWRITE = 2;
55 our constant RWTRANS = 8;
56 our constant INVOCANT = 8192;
57 our constant IS_COPY = 32768;
58 our constant IS_LIST = 65536;
59 our constant IS_HASH = 131072;
60 our constant CALLABLE = 0x20_0000;
61
62 # Value source
63 our constant HASDEFAULT = 32;
64 our constant OPTIONAL = 64;
65 our constant DEFOUTER = 4096;
66 our constant POSITIONAL = 128;
67 our constant SLURPY_POS = 256;
68 our constant SLURPY_NAM = 512;
69 our constant SLURPY_CAP = 1024;
70 our constant SLURPY_PCL = 2048;
71
72 method named() { !!! }
73 method named_names() { !!! }
74 method type() { !!! }
75 method optional() { !!! }
76 method value_constraint_list() { !!! }
77 method name() { !!! }
78 method slurpy() { !!! }
79
80 method name() {
81 $!variable_name
82 }
83
84 method constraint_list() {
85 pir::isnull($!post_constraints) ?? () !!
86 pir::perl6ize_type__PP($!post_constraints)
87 }
88
89 method constraints() {
90 all(pir::isnull($!post_constraints) ?? () !!
91 pir::perl6ize_type__PP($!post_constraints))
92 }
93
94 method type() {
95 $!nominal_type
96 }
97
98 method named() {
99 !nqp::p6bool(nqp::isnull($!named_names)) ||
100 nqp::p6bool($!flags +& $SIG_ELEM_SLURPY_NAMED)
101 }
102
103 method named_names() {
104 if !pir::isnull($!named_names) {
105 my Int $count = nqp::p6box_i(nqp::elems($!named_names));
106 my Int $i = 0;
107 my @res;
108 while $i < $count {
109 @res.push: nqp::p6box_s(nqp::atpos($!named_names, nqp::unbox_i($i)));
110 $i++;
111 }
112 @res;
113 } else {
114 ().list
115 }
116 }
117
118 method positional() {
119 nqp::p6bool(
120 ($!flags +& ($SIG_ELEM_SLURPY_POS +| $SIG_ELEM_SLURPY_NAMED)) == 0 &&
121 nqp::isnull($!named_names)
122 )
123 }
124
125 method slurpy() {
126 nqp::p6bool(
127 $!flags +& ($SIG_ELEM_SLURPY_POS
128 +| $SIG_ELEM_SLURPY_NAMED
129 +| $SIG_ELEM_SLURPY_BLOCK)
130 )
131 }
132
133 method optional() {
134 ?($!flags +& $SIG_ELEM_IS_OPTIONAL)
135 }
136
137 method parcel() {
138 ?($!flags +& $SIG_ELEM_IS_PARCEL)
139 }
140
141 method capture() {
142 ?($!flags +& $SIG_ELEM_IS_CAPTURE)
143 }
144
145 method rw() {
146 ?($!flags +& $SIG_ELEM_IS_RW)
147 }
148
149 method copy() {
150 ?($!flags +& $SIG_ELEM_IS_COPY)
151 }
152
153 method readonly() {
154 !($.rw || $.copy || $.parcel)
155 }
156
157 method invocant() {
158 ?($!flags +& $SIG_ELEM_INVOCANT)
159 }
160
161 method default() {
162 nqp::isnull($!default_value) ?? Any !!
163 $!default_value ~~ Code ?? $!default_value !! { $!default_value }
164 }
165
166 # XXX TODO: A few more bits :-)
167 multi method perl(Parameter:D:) {
168 my $perl = '';
169 my $flags = self.flags;
170 my $type = self.type.^name;
171 if $flags +& IS_LIST {
172 # XXX Need inner type
173 }
174 elsif $flags +& IS_HASH {
175 # XXX Need inner type
176 }
177 else {
178 $perl = $type;
179 if $flags +& DEF_ONLY {
180 $perl ~= ':D';
181 } elsif $flags +& UNDEF_ONLY {
182 $perl ~= ':U';
183 } elsif $flags +& TYPE_ONLY {
184 $perl ~= ':T';
185 }
186 $perl ~= ' ';
187 }
188 if self.name -> $name {
189 if $flags +& SLURPY_CAP {
190 $perl ~= '|' ~ $name;
191 } elsif $flags +& RWTRANS {
192 $perl ~= '\\' ~ $name;
193 } else {
194 my $default = self.default();
195 if self.named_names -> @names {
196 my $short = $name.substr(1);
197 $name = ':' ~ $name if $short eq any @names;
198 for @names {
199 next if $_ eq $short;
200 $name = ':' ~ $_ ~ '(' ~ $name ~ ')';
201 }
202 $name ~= '!' unless self.optional;
203 } elsif self.optional && !$default {
204 $name ~= '?';
205 } elsif self.slurpy {
206 $name = '*' ~ $name;
207 }
208 $perl ~= $name;
209 if $!flags +& READWRITE {
210 $perl ~= ' is rw';
211 } elsif $!flags +& IS_COPY {
212 $perl ~= ' is copy';
213 }
214 $perl ~= ' = { ... }' if $default;
215 if self.sub_signature -> $sub {
216 $perl ~= ' ' ~ $sub.perl;
217 }
218 }
219 }
220 $perl
221 }
222 }
223 augment class ClassHOW {
224 method name($) { Q:CgOp { (box Str (obj_typename (stab_what (unbox stable (@ {self}))))) } }
225 }
226
227 my sub MAIN_HELPER() {
228 # Do we have a MAIN at all?
229 my $m = CALLER::<&MAIN>;
230 return unless $m;
231
232 # Convert raw command line args into positional and named args for MAIN
233 my sub process-cmd-args (@args is copy) {
234 my (@positional-arguments, %named-arguments);
235 while (@args) {
236 my $passed-value = @args.shift;
237 if $passed-value ~~ /^ ( '--' | '-' | ':' ) ('/'?) (<-[0..9\.]> .*) $/ {
238 my ($switch, $negate, $arg) = (~$0, ?((~$1).chars), ~$2);
239
240 if $arg.index('=').defined {
241 my ($name, $value) = $arg.split('=', 2);
242 $value = val($value);
243 $value = $value but False if $negate;
244 %named-arguments.push: $name => $value;
245 } else {
246 %named-arguments.push: $arg => !$negate;
247 }
248 } else {
249 @args.unshift($passed-value) unless $passed-value eq '--';
250 @positional-arguments.push: @args.map: &val;
251 last;
252 }
253 }
254
255 return @positional-arguments, %named-arguments;
256 }
257
258 # Generate $?USAGE string (default usage info for MAIN)
259 my sub gen-usage () {
260 my @help-msgs;
261 my $prog-name = $*PROGRAM_NAME eq '-e' ?? "-e '...'" !! $*PROGRAM_NAME;
262 for $m.candidates -> $sub {
263 my (@required-named, @optional-named, @positional);
264 for $sub.signature.params -> $param {
265 my $argument;
266 if $param.named {
267 my @names = $param.named_names.reverse;
268 $argument = @names.map({($^n.chars == 1 ?? '-' !! '--') ~ $^n}).join('|');
269 $argument ~= "=<{$param.type.^name}>" unless $param.type === Bool;
270 if $param.optional {
271 @optional-named.push("[$argument]");
272 }
273 else {
274 @required-named.push($argument);
275 }
276 }
277 else {
278 my $constraints = $param.value_constraint_list;
279 $argument = $constraints ?? $constraints !!
280 $param.name ?? '<' ~ $param.name.substr(1) ~ '>' !!
281 '<' ~ $param.type.^name ~ '>' ;
282
283 $argument = "[$argument ...]" if $param.slurpy;
284 $argument = "[$argument]" if $param.optional;
285 @positional.push($argument);
286 }
287 }
288 my $msg = join(' ', $prog-name, @required-named, @optional-named, @positional);
289 @help-msgs.push($msg);
290 }
291 my $usage = "Usage:\n" ~ @help-msgs.map(' ' ~ *).join("\n");
292 return $usage;
293 }
294
295 # Process command line arguments
296 my ($p, $n) = process-cmd-args(@*ARGS).lol;
297
298 # Generate default $?USAGE message
299 my $USAGE = gen-usage();
300
301 # If dispatch to MAIN is possible, do so
302 if $m.candidates_matching(|@($p), |%($n)).elems {
303 return $m(|@($p), |%($n));
304 }
305
306 # We could not find the correct MAIN to dispatch to!
307 # Let's try to run a user defined USAGE sub
308 my $h = CALLER::<&USAGE>;
309 return $h() if $h;
310
311 # We could not find a user defined USAGE sub!
312 # Let's display the default USAGE message
313 if ($n<help>) {
314 $*OUT.say($USAGE);
315 exit 1;
316 }
317 else {
318 $*ERR.say($USAGE);
319 exit 2;
320 }
321 }
Something went wrong with that request. Please try again.