Implement Signature.perl in the setting, using the introspection inte…

…rface. Fix three RT tickets along the way.
rakudo · Oct 9, 2009 · 489f5d1 · 489f5d1
1 parent 1f2e5f4
commit 489f5d1
Show file tree

Hide file tree

Showing 3 changed files with 72 additions and 126 deletions.
diff --git a/build/Makefile.in b/build/Makefile.in
@@ -165,6 +165,7 @@ SETTING = \
   src/setting/Pair.pm \
   src/setting/Parameter.pm \
   src/setting/Range.pm \
+  src/setting/Signature.pm \
   src/setting/Str.pm \
   src/setting/Temporal.pm \
   src/setting/Whatever.pm \

diff --git a/src/classes/Signature.pir b/src/classes/Signature.pir
@@ -95,132 +95,6 @@ Returns a C<List> of C<Parameter> descriptors.
 .end
 
 
-=item perl
-
-Gets a perl representation of the signature.
-
-=cut
-
-.sub 'perl' :method
-    .local pmc s
-    s = new ['Str']
-    concat s, ':('
-
-    # Various bits of state we'll want.
-    .local int last_was_multi_inv, want_colon, first
-    last_was_multi_inv = 1
-    want_colon = 0
-    first = 1
-
-    # Grab low level signature we're wrapping.
-    .local pmc signature
-    signature = getattribute self, '$!ll_sig'
-    signature = descalarref signature
-
-    # Loop over parameters.
-    .local int cur_param, count
-    count = get_signature_size signature
-    cur_param = -1
-  param_loop:
-    inc cur_param
-    unless cur_param < count goto param_done
-
-    # Get all curent parameter info.
-    .local pmc nom_type, cons_type, names
-    .local int flags, optional, multi_invocant, slurpy
-    .local string name
-    get_signature_elem signature, cur_param, name, flags, nom_type, cons_type, names, $P1
-    optional       = flags & SIG_ELEM_IS_OPTIONAL
-    multi_invocant = flags & SIG_ELEM_MULTI_INVOCANT
-    slurpy         = flags & SIG_ELEM_SLURPY
-
-    # If it's the first time, no separator.
-    if first goto first_time
-    if want_colon goto emit_colon
-    if multi_invocant goto emit_comma
-    unless last_was_multi_inv goto emit_comma
-    concat s, ';; '
-    last_was_multi_inv = 0
-    goto separator_done
-  emit_comma:
-    concat s, ', '
-    goto separator_done
-  emit_colon:
-    concat s, ': '
-    goto separator_done
-  first_time:
-    first = 0
-  separator_done:
-
-    # First any nominal type.
-    if null nom_type goto any_type
-    $I0 = isa nom_type, 'Role'
-    unless $I0 goto type_as_is
-    $S0 = substr name, 0, 1
-    if $S0 == '$' goto type_as_is
-    $S1 = nom_type.'perl'()
-    $I0 = index $S1, '['
-    inc $I0
-    $I1 = length $S1
-    $I1 -= $I0
-    dec $I1
-    $S1 = substr $S1, $I0, $I1
-    concat s, $S1
-    goto type_done
-  type_as_is:
-    $P0 = nom_type.'perl'()
-    if $P0 == 'Positional' goto no_type
-    if $P0 == 'Associative' goto no_type
-    if $P0 == 'Callable' goto no_type
-    concat s, $P0
-    goto type_done
-  any_type:
-    concat s, "Any"
-  type_done:
-    concat s, " "
-  no_type:
-
-    # If it's slurpy, the *.
-    unless slurpy goto slurpy_done
-    concat s, '*'
-    goto named_done
-  slurpy_done:
-
-    # If it's named, the :. XXX Handle different naming/multiple names.
-    if null names goto named_done
-    concat s, ':'
-  named_done:
-
-    # Now the name.
-    concat s, name
-
-    # If it's optional, the ?. XXX Fix named case for non-optional.
-    unless optional goto optional_done
-    concat s, '?'
-  optional_done:
-
-    # Now any constraints.
-    if null cons_type goto constraints_done
-    unless cons_type goto constraints_done
-    concat s, " where "
-    $P0 = cons_type.'perl'()
-    concat s, $P0
-  constraints_done:
-
-    goto param_loop
-  param_done:
-
-    # If we just had an invocant, need the colon.
-    unless want_colon goto no_trailing_colon
-    concat s, ':'
-  no_trailing_colon:
-
-    # Done.
-    concat s, ')'
-    .return (s)
-.end
-
-
 =item !SIGNATURE_BIND
 
 Analyze the signature of the caller, (re)binding the caller's

diff --git a/src/setting/Signature.pm b/src/setting/Signature.pm
@@ -0,0 +1,71 @@
+class Signature is also {
+    method perl() {
+        return [~] gather {
+            take ':(';
+            my $sep = '';
+            my $last_was_multi_inv = True;
+            for $.params -> $param {
+                # First, separator, if any.
+                if $last_was_multi_inv && !$param.multi_invocant { $sep = ';; ' }
+                take ~$sep;
+                $sep = ', ';
+
+                # First the type.
+                my $name = $param.name;
+                if !$param.slurpy {
+                    my $sigil = substr($name, 0, 1);
+                    my $perl = $param.type.perl;
+                    if $sigil eq '$' {
+                        take $perl ~ ' ';
+                    }
+                    elsif $sigil eq '@' {
+                        if $perl ne 'Positional' {
+                            take substr($perl, 11, $perl.chars - 12) ~ ' ';
+                        }
+                    }
+                    elsif $sigil eq '%' {
+                        if $perl ne 'Associative' {
+                            take substr($perl, 12, $perl.chars - 13) ~ ' ';
+                        }
+                    }
+                    elsif substr($perl, 0, 8) eq 'Callable' {
+                        $name = '&' ~ $name;
+                        if $perl ne 'Callable' {
+                            take substr($perl, 9, $perl.chars - 10) ~ ' ';
+                        }
+                    }
+                    else {
+                        take $perl ~ ' ';
+                    }
+                }
+
+                # Slurpiness, namedness, then the name.
+                if $param.slurpy { take '*' }
+                for @($param.named_names) -> $name {
+                    take ':' ~ $name ~ '(';
+                }
+                take $name;
+                take ')' x +$param.named_names;
+
+                # Optionality.
+                if $param.optional && !$param.named && !$param.default   { take '?' }
+                elsif !$param.optional && $param.named && !$param.slurpy { take '!' }
+
+                # Any constraints?
+                if $param.constraints {
+                    take ' where ' ~ $param.constraints.perl;
+                }
+
+                # Default.
+                if $param.default {
+                    take ' = ' ~ $param.default.perl;
+                }
+
+                # Invocant/multi invocant marking.
+                if $param.invocant { $sep = ': '; }
+                $last_was_multi_inv = $param.multi_invocant;
+            }
+            take ')';
+        }
+    }
+}