Changeset 7925

Timestamp:

11/10/05 18:33:20 (3 years ago)

Author:

gaal

Message:

* when CODE:

• given { when &sub { ... } } works for 0- and 1-arity subs.
• still TODO: when { bare closure }, as this requires parser tweaking.
• tests.

Files:

• src/Pugs/Prim/Match.hs (modified) (2 diffs)
• t/statements/given.t (modified) (3 diffs)

src/Pugs/Prim/Match.hs

@@ -10 +10 @@
 import Pugs.Types
 import Pugs.Config
+import Pugs.Prim.Code
 import qualified RRegex.PCRE as PCRE
 import qualified Data.Map as Map
@@ -82 +83 @@
 op2Match :: Val -> Val -> Eval Val
 
+op2Match _ y@(VCode _) = do
+    (arity :: Int) <- fromVal =<< op1CodeArity y
+    res <- fromVal =<< case arity of
+        0 -> evalExp $ App (Val y) Nothing []
+        1 -> do
+             topic <- readVar "$_"
+             evalExp $ App (Val y) Nothing [Val topic]
+        _ -> fail ("Unexpected arity in smart match: " ++ (show arity))
+    return $ VBool $ res
+
 op2Match x (VRef (MkRef (IScalar sv))) | scalar_iType sv == mkType "Scalar::Const" = do
     y' <- scalar_fetch' sv

t/statements/given.t

@@ -4 +4 @@
 use Test;
 
-plan 48;
+plan 49;
 
 =kwid
@@ -244 +244 @@
         }
     ';
-    ok($x, 'given tests closures for truth', :todo);
+    ok($x, 'given tests 0-arg closures for truth', :todo);
+}
+
+# given + closure with 0-arg code
+{
+    my $x = 41;
+    sub always_true { bool::true }
+    given 1 {
+        when &always_true { $x++ }
+    }
+    is($x, 42, 'given tests 0-arg subs for truth');
 }
 
@@ -250 +260 @@
 {
     my $x = 41;
-    sub setx ($value) { $value == 41 }
-    eval '
-        given 1 {
-            when &setx { $x++ }
-        }
-    ';
-    is($x, 42, 'given tests closures for truth', :todo);
-}
-
+    sub maybe_true ($value) { $value eq "mytopic" }
+    given "mytopic" {
+        when &maybe_true { $x++ }
+    }
+    is($x, 42, 'given tests 1-arg subs for truth');
+}
+