Implement hash constructors

lib/SAFE.setting

@@ -41,6 +41,8 @@ my class Any is Mu {
     }
     method flat() { (self,).flat }
 
+    method sort($cmp = &infix:<leg>) { self.list.sort($cmp) }
+
     method ACCEPTS($t) { self === $t }
     method !butWHENCE($cr) {
         Q:CgOp { (newgeneralvar (bool 1) (bool 0) (@ {$cr}) (@ {self})) }
@@ -238,6 +240,25 @@ sub prefix:<+>($x) { $x.Numeric }
 
 sub prefix:<!>($v) { $v ?? False !! True }
 
+sub infix:<x>($str, $ct) {
+    my $i = +$ct;
+    my $j = ''; # XXX use strbuf
+    while $i >= 1 {
+        $i--;
+        $j ~= $str;
+    }
+    $j;
+}
+
+sub infix:<leg>($s1, $s2) {
+    Q:CgOp { (box Num (cast num (strcmp (unbox str (@ {$s1.Str})) (unbox str (@ {$s2.Str}))))) }
+}
+
+sub infix:<ge>($s1, $s2) { ($s1 leg $s2) >= 0 }
+sub infix:<gt>($s1, $s2) { ($s1 leg $s2) > 0  }
+sub infix:<le>($s1, $s2) { ($s1 leg $s2) <= 0 }
+sub infix:<lt>($s1, $s2) { ($s1 leg $s2) < 0  }
+
 sub infix:<eq>($l,$r) { Q:CgOp {
     (box Bool (compare == (unbox str (@ {$l.Str}))
       (unbox str (@ {$r.Str}))))
@@ -488,6 +509,18 @@ my class List is Cool {
 
     method Str() { self.join(" ") }
 
+    method sort($cmp = &infix:<leg>) {
+        my $l = self.list.eager;
+        Q:CgOp {
+            (letn n (obj_newblank (obj_llhow (@ {List})))
+              (setslot flat (l n) (bool 1))
+              (setslot items (l n) (vvarlist_sort (@ {$cmp})
+                  (getslot items vvarlist (@ {$l}))))
+              (setslot rest (l n) (vvarlist_new_empty))
+              (newrwlistvar (l n)))
+        }
+    }
+
     method push(*@items) {
         self!push-iterator(@items.Seq.eager.iterator)
     }
@@ -547,7 +580,7 @@ my class Array is List {
 
 my class Hash {
     has $!value;
-    method new() { Q:CgOp { (box Hash (varhash_new)) } }
+    method new() { unitem(Q:CgOp { (box Hash (varhash_new)) }) }
     method !extend($key, \$var) {
         Q:CgOp {
             (letn d [unbox varhash (@ {self})]
@@ -713,6 +746,14 @@ sub invert(%h) { %h.invert }
 sub keys(%h) { %h.keys }
 sub values(%h) { %h.values }
 
+sub grep($filter, *@items) { @items.grep($filter) }
+sub map($callback, *@items) { @items.map($callback) }
+
+sub sort(*@bits) { @bits.sort }
+
+sub _array_constructor(\$parcel) { anon @new = $parcel }
+sub _hash_constructor(\$parcel) { anon %hash = $parcel }
+
 sub infix:<,>(\|$t) { Q:CgOp { (newrwlistvar (@ {$t})) }; }
 # }}}
 # Regular expression support {{{

src/Niecza/Actions.pm

@@ -987,10 +987,42 @@ sub circumfix__S_Bra_Ket { my ($cl, $M) = @_;
                 [ map { Op::Paren->new(inside => $_) } @kids ])]);
 }
 
+sub check_hash { my ($cl, $M) = @_;
+    my $do = $M->{pblock}{_ast}->do;
+
+    return 0 unless $do->isa('Op::StatementList');
+    return 1 if @{ $do->children } == 0;
+    return 0 if @{ $do->children } > 1;
+
+    $do = $do->children->[0];
+    my @bits = $do->isa('Op::SimpleParcel') ? @{ $do->items } : ($do);
+
+    return 1 if $bits[0]->isa('Op::SimplePair');
+
+    if ($bits[0]->isa('Op::CallSub') &&
+            $bits[0]->invocant->isa('Op::Lexical') &&
+            $bits[0]->invocant->name eq '&infix:<=>>') {
+        return 1;
+    }
+
+    if ($bits[0]->isa('Op::Lexical') && substr($bits[0]->name,0,1) eq '%') {
+        return 1;
+    }
+
+    return 0;
+}
+
 sub circumfix__S_Cur_Ly { my ($cl, $M) = @_;
     $M->{pblock}{_ast}->type('bare');
     $M->{_ast} = Op::BareBlock->new(node($M), var => $cl->gensym,
         body => $M->{pblock}{_ast});
+
+    if ($cl->check_hash($M)) {
+        $M->{_ast} = Op::CallSub->new(node($M),
+            invocant => Op::Lexical->new(node($M), name => '&_hash_constructor'),
+            args => [Op::CallSub->new(node($M), invocant =>
+                    $cl->block_to_closure($M, $M->{pblock}{_ast}, once => 1))]);
+    }
 }
 
 sub circumfix__S_sigil { my ($cl, $M) = @_;

test.pl

@@ -2,7 +2,7 @@
 
 use Test;
 
-plan 562;
+plan 581;
 
 ok 1, "one is true";
 ok 2, "two is also true";
@@ -1155,3 +1155,32 @@
     sub foo(*%x) { %x }
     is foo(:z(2))<z>, 2, "slurpy hashes work";
 }
+
+ok 'cow' le 'sow', 'cow le sow';
+ok !('sow' le 'cow'), 'sow !le cow';
+ok 'row' lt 'tow', 'row lt tow';
+ok 'how' gt 'bow', 'how gt bow';
+ok 'yow' ge 'yow', 'yow ge yow';
+is join("|", sort <c f d z a>), 'a|c|d|f|z', '&sort works';
+is join("|", <a3 b2 c1 d0>.sort({ substr($^a,1) leg substr($^b,1) })),
+    'd0|c1|b2|a3', '.sort with callback works';
+
+is ("yayay" ~~ /y\w*?y/), "yay", "minimal matching works";
+is ("yayay" ~~ /y**?a/), "y", "minimal matching works with **";
+
+is +[ 2 ], 1, "array construction w/ one argument";
+is +[ ], 0, "array construction w/ no arguments";
+is +[ 3, 4 ], 2, "array construction w/ two";
+is +[ $( 3, 4 ) ], 1, "array construction w/ scalar argument";
+
+{
+    sub bar { $*x + $*x }
+    sub foo($*x) { bar }
+    is foo(12), 24, "*-twigilled arguments work";
+}
+
+is { a => 1 }.<a>, 1, "hash constructors work (1)";
+is { "a" => 1 }.<a>, 1, "hash constructors work w/ quotes";
+is { :a(1) }.<a>, 1, "hash constructors work w/ colons";
+is { a => 1, b => 2 }.<b>, 2, "hash constructors work w/ lists";
+ok { } ~~ Hash, "hash constructors work w/ nothing";

test2.pl

@@ -2,45 +2,16 @@
 use Test;
 use MONKEY_TYPING;
 
-sub infix:<x>($str, $ct) {
-    my $i = +$ct;
-    my $j = ''; # XXX use strbuf
-    while $i >= 1 {
-        $i--;
-        $j ~= $str;
-    }
-    $j;
-}
-
 sub grep($filter, *@items) { @items.grep($filter) }
 sub map($callback, *@items) { @items.map($callback) }
 
-sub infix:<leg>($s1, $s2) {
-    Q:CgOp { (box Num (cast num (strcmp (unbox str (@ {$s1.Str})) (unbox str (@ {$s2.Str}))))) }
-}
-
-sub infix:<ge>($s1, $s2) { ($s1 leg $s2) >= 0 }
-sub infix:<gt>($s1, $s2) { ($s1 leg $s2) > 0  }
-sub infix:<le>($s1, $s2) { ($s1 leg $s2) <= 0 }
-sub infix:<lt>($s1, $s2) { ($s1 leg $s2) < 0  }
-
 augment class Any {
-    method sort($cmp = &infix:<leg>) {
-        my $l = self.list.eager;
-        Q:CgOp {
-            (letn n (obj_newblank (obj_llhow (@ {List})))
-              (setslot flat (l n) (bool 1))
-              (setslot items (l n) (vvarlist_sort (@ {$cmp})
-                  (getslot items vvarlist (@ {$l}))))
-              (setslot rest (l n) (vvarlist_new_empty))
-              (newrwlistvar (l n)))
-        }
-    }
 }
 
 sub sort(*@bits) { @bits.sort }
 
 sub _array_constructor(\$parcel) { anon @new = $parcel }
+sub _hash_constructor(\$parcel) { anon %hash = $parcel }
 
 ok 'cow' le 'sow', 'cow le sow';
 ok !('sow' le 'cow'), 'sow !le cow';