EXPR dependencies go live; add .suppose

sorear · Oct 23, 2010 · afb1d26 · afb1d26
1 parent 638cc46
commit afb1d26
Show file tree

Hide file tree

Showing 6 changed files with 346 additions and 69 deletions.
diff --git a/lib/SAFE.setting b/lib/SAFE.setting
@@ -16,6 +16,7 @@ my class Mu {
             $tn ~ "()"
         }
     }
+    method dump() { self.defined ?? "Unknown{self.Str}" !! "undef" }
     method item() { self }
     method so() { self.Bool }
     method not() { ! self.Bool }
@@ -104,6 +105,7 @@ my class Num is Cool {
     } }
     method Numeric() { self }
     method ACCEPTS($t) { self == $t }
+    method dump() { self.Str }
 }
 
 my class Str is Cool {
@@ -123,6 +125,7 @@ my class Str is Cool {
                     [cast int (unbox num (@ {$from}))]
                     [cast int (unbox num (@ {$len}))]))
     } }
+    method dump() { '"' ~ self ~ '"' }
 }
 
 my class Scalar {
@@ -440,6 +443,8 @@ my class List is Cool {
         }
     }
 
+    method dump() { '[' ~ self.map(*.dump).join(', ') ~ ']' }
+
     #| Takes an object and applies whatever semantics the List subclass
     #| needs to apply on stuff out of the iterator stack
     method _elem(\$x) { $x }
@@ -688,6 +693,9 @@ my class Hash {
         };
     }
 
+    method iterator () { self.list.iterator }
+    method dump () { '{' ~ self.list.map(*.dump).join(', ') ~ '}' }
+
     # TODO: We need something like pir:: notation for this to not suck
     method at-key($key) {
         Q:CgOp {
@@ -723,6 +731,8 @@ my class Enum is Cool {
         ($.key, $.value);
     }
 
+    method dump() { self.key.dump ~ ' => ' ~ self.value.dump }
+
     method pairs() {
         self.flat;
     }
@@ -828,6 +838,8 @@ my class Cursor {
         (@ {self}) (unbox str (@ {$str})))) } }
     method pos() { Q:CgOp { (box Num (cast num (cursor_pos
         (cast cursor (@ {self}))))) } }
+    method to() { Q:CgOp { (box Num (cast num (cursor_pos
+        (cast cursor (@ {self}))))) } }
     method cursor($np) { Q:CgOp { (ns (cursor_butpos
         (cast cursor (@ {self}))
           (cast int (unbox num (@ {$np}))))) } }
@@ -864,6 +876,24 @@ my class Match {
         (box Str (cursor_backing (cast cursor (@ {self})))) } }
     method chars() { $.defined ?? $.to - $.from !! 0 }
     method Str() { $.defined ?? $.orig.substr($.from, $.chars) !! "" }
+    method dump() {
+        "#<match from({ self.from }) to({ self.to }) text({ self }) pos({ @(self).dump }) named({ %(self).dump })>"
+    }
+    method synthetic(:$cursor!, :$method!, :@captures!, :$from!, :$to!) {
+        my $m = Q:CgOp {
+            (newscalar (cursor_synthetic
+                (cast cursor (@ {$cursor})) (unbox str (@ {$method.Str}))
+                (cast int (unbox num (@ {$from})))
+                (cast int (unbox num (@ {$to})))))
+        };
+        # this is wrong.  I need a better way to pass lists into primitives.
+        for @captures -> $pair {
+            Q:CgOp { (rnull
+                (cursor_synthcap (cast cursor (@ {$m}))
+                  (unbox str (@ {$pair.key.Str})) (@ {$pair.value}))) };
+        }
+        $m
+    }
 }
 
 my class Regex is Sub {

diff --git a/src/Niecza/Actions.pm b/src/Niecza/Actions.pm
@@ -293,22 +293,26 @@ sub quote__S_Q { my ($cl, $M) = @_;
     $M->{_ast} = $M->{quibble}{_ast};
 }
 
-sub quote__S_Slash_Slash { my ($cl, $M) = @_;
-    my @lift = $M->{nibble}{_ast}->oplift;
+sub op_for_regex { my ($cl, $M, $rxop) = @_;
+    my @lift = $rxop->oplift;
     {
         local $::paren = 0;
-        $M->{nibble}{_ast}->check
+        $rxop->check
     }
-    my ($rxop, $mb) = Optimizer::RxSimple::run($M->{nibble}{_ast});
-    $M->{_ast} = Op::SubDef->new(
+    my ($orxop, $mb) = Optimizer::RxSimple::run($rxop);
+    Op::SubDef->new(node($M),
         var  => $cl->gensym,
         body => Body->new(
             transparent => 1,
             class => 'Regex',
             type  => 'regex',
             signature => Sig->simple->for_regex,
-            do => Op::RegexBody->new(canback => $mb, pre => \@lift,
-                rxop => $rxop)));
+            do => Op::RegexBody->new(node($M), canback => $mb, pre => \@lift,
+                rxop => $orxop)));
+}
+
+sub quote__S_Slash_Slash { my ($cl, $M) = @_;
+    $M->{_ast} = $cl->op_for_regex($M, $M->{nibble}{_ast});
 }
 
 sub encapsulate_regex { my ($cl, $M, $rxop, %args) = @_;
@@ -766,8 +770,8 @@ sub assertion__S_name { my ($cl, $M) = @_;
         }
 
         if ($M->{nibbler}[0]) {
-            my $args = [$M->{nibbler}[0]{_ast}];
-            $M->{_ast} = RxOp::Subrule->new(zyg => $args, method => $name);
+            $M->{_ast} = RxOp::Subrule->new(method => $name,
+                arglist => [ $cl->op_for_regex($M, $M->{nibbler}[0]{_ast}) ]);
         } else {
             my $args = ($M->{arglist}[0] ? $M->{arglist}[0]{_ast} : []);
             $M->{_ast} = RxOp::Subrule->new(arglist => $args, method => $name);

diff --git a/test2.pl b/test2.pl
@@ -2,6 +2,22 @@
 use Test;
 use MONKEY_TYPING;
 
+augment class Cursor {
+    method suppose($rx) {
+        my $*IN_SUPPOSE = True;
+        my $*FATALS = 0;
+        my @*WORRIES;
+        my %*WORRIES;
+        my $*HIGHWATER = -1;
+        my $*HIGHEXPECT = {};
+        try {
+            my @ret := $rx(self);
+            if (@ret) { return @( self, ) }
+        };
+        return ();
+    }
+}
+
 {
     my $m = "ab" ~~ / (.) <alpha> /;
     is (@$m)[0], "a", "Match.list returns positional captures";
@@ -36,6 +52,9 @@
     my $i = 0;
     $i++ until $i == 10;
     is $i, 10, "until loops functional";
+
+    ok "foo" !~~ / f <.suppose { die }> /, ".suppose works (F)";
+    ok "foo" ~~ / f <.suppose o> oo /, ".suppose works (T)";
 }
 
 # {

diff --git a/test3.pl b/test3.pl
@@ -2,57 +2,6 @@
 use Test;
 use MONKEY_TYPING;
 
-augment class Hash {
-    method iterator () { self.list.iterator }
-    method dump () { '{' ~ self.list.map(*.dump).join(', ') ~ '}' }
-}
-
-augment class Pair {
-    method dump() { self.key.dump ~ ' => ' ~ self.value.dump }
-}
-
-augment class Str {
-    method dump() { '"' ~ self ~ '"' }
-}
-
-augment class Num {
-    method dump() { self.Str }
-}
-
-augment class List {
-    method dump() { '[' ~ self.map(*.dump).join(', ') ~ ']' }
-}
-
-augment class Cursor {
-    method to() { Q:CgOp { (box Num (cast num (cursor_pos
-        (cast cursor (@ {self}))))) } }
-}
-
-augment class Mu {
-    method dump() { self.defined ?? "Unknown{self.Str}" !! "undef" }
-}
-
-augment class Match {
-    method dump() {
-        "#<match from({ self.from }) to({ self.to }) text({ self }) pos({ @(self).dump }) named({ %(self).dump })>"
-    }
-    method synthetic(:$cursor!, :$method!, :@captures!, :$from!, :$to!) {
-        my $m = Q:CgOp {
-            (newscalar (cursor_synthetic
-                (cast cursor (@ {$cursor})) (unbox str (@ {$method.Str}))
-                (cast int (unbox num (@ {$from})))
-                (cast int (unbox num (@ {$to})))))
-        };
-        # this is wrong.  I need a better way to pass lists into primitives.
-        for @captures -> $pair {
-            Q:CgOp { (rnull
-                (cursor_synthcap (cast cursor (@ {$m}))
-                  (unbox str (@ {$pair.key.Str})) (@ {$pair.value}))) };
-        }
-        $m
-    }
-}
-
 package DEBUG { our $EXPR = False }
 
 grammar WithOPP {