match: making match-cond have an optional default like cond.

diff --git a/basis/match/match-docs.factor b/basis/match/match-docs.factor
index e6d61297cc9036ee3aa33df5e929f53f903bbb82..6110c037b8a073496eea1311cb1bcd754c352a2c 100644 (file)
--- a/basis/match/match-docs.factor
+++ b/basis/match/match-docs.factor
@@ -7,7 +7,7 @@ IN: match
 HELP: match
 { $values { "value1" object } { "value2" object } { "bindings" assoc }
 }
-{ $description "Pattern match value1 against value2. These values can be any Factor value, including sequences and tuples. The values can contain pattern variables, which are symbols that begin with '?'. The result is a hashtable of the bindings, mapping the pattern variables from one sequence to the equivalent value in the other sequence. The '_' symbol can be used to ignore the value at that point in the pattern for the match. " }
+{ $description "Pattern match " { $snippet "value1" } " against " { $snippet "value2" } ". These values can be any Factor value, including sequences and tuples. The values can contain pattern variables, which are symbols that begin with '?'. The result is a hashtable of the bindings, mapping the pattern variables from one sequence to the equivalent value in the other sequence. The " { $link _ } " symbol can be used to ignore the value at that point in the pattern for the match. " }
 { $examples
     { $unchecked-example "USE: match" "MATCH-VARS: ?a ?b ;\n{ ?a { 2 ?b } 5 } { 1 { 2 3 } _ } match ." "H{ { ?a 1 } { ?b 3 } }" }
 }
@@ -15,13 +15,14 @@ HELP: match
 
 HELP: match-cond
 { $values { "assoc" "a sequence of pairs" } }
-{ $description "Calls the second quotation in the first pair whose first sequence yields a successful " { $link match } " against the top of the stack. The second quotation, when called, has the hashtable returned from the " { $link match } " call bound as the top namespace so " { $link get } " can be used to retrieve the values. To have a fallthrough match clause use the '_' match variable." }
+{ $description "Calls the second quotation in the first pair whose first sequence yields a successful " { $link match } " against the top of the stack. The second quotation, when called, has the hashtable returned from the " { $link match } " call bound as the top namespace so " { $link get } " can be used to retrieve the values. A single quotation will always yield a true value. To have a fallthrough match clause use the " { $link _ } " match variable." }
+{ $errors "Throws a " { $link no-match-cond } " error if none of the test quotations yield a true value." }
 { $examples
-    { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment 346126 } {\n  { { increment ?value } [ ?value do-something ] }\n  { { decrement ?value } [ ?value do-something-else ] }\n  { _ [ no-match-found ] }\n} match-cond" }
+    { $code
+        "USE: match" "MATCH-VARS: ?value ;\n{ increment 346126 } {\n  { { increment ?value } [ ?value do-something ] }\n  { { decrement ?value } [ ?value do-something-else ] }\n  { _ [ no-match-found ] }\n} match-cond" }
 }
 { $see-also match POSTPONE: MATCH-VARS: replace-patterns match-replace } ;
 
-
 HELP: MATCH-VARS:
 { $syntax "MATCH-VARS: var ... ;" }
 { $values { "var" "a match variable name beginning with '?'" } }

diff --git a/basis/match/match-tests.factor b/basis/match/match-tests.factor
index d8143fd217b7c0415e1db1ed9b1547c703479175..9d12154c2a02740ec2d74e784f762ea8a1b53ebb 100644 (file)
--- a/basis/match/match-tests.factor
+++ b/basis/match/match-tests.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2006 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test match namespaces arrays ;
+USING: arrays kernel match namespaces tools.test ;
 IN: match.tests
 
 MATCH-VARS: ?a ?b ;
@@ -69,6 +69,25 @@ C: <foo> foo
     } match-cond
 ] unit-test
 
+{ "one" } [
+    1 {
+        { 1 [ "one" ] }
+    } match-cond
+] unit-test
+
+[
+    2 {
+        { 1 [ "one" ] }
+    } match-cond
+] [ no-match-cond? ] must-fail-with
+
+{ "default" } [
+    2 {
+        { 1 [ "one" ] }
+        [ drop "default" ]
+    } match-cond
+] unit-test
+
 { { 2 1 } } [
     { "a" 1 2 "b" } { _ ?a ?b _ } { ?b ?a } match-replace
 ] unit-test

diff --git a/basis/match/match.factor b/basis/match/match.factor
index 0b61389fd2215d63f94cd39f526c91ce0ad93c5c..489fa83a38845e97b72d76bbeef53e0d5626b7f6 100644 (file)
--- a/basis/match/match.factor
+++ b/basis/match/match.factor
@@ -2,8 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 ! Based on pattern matching code from Paul Graham's book 'On Lisp'.
-USING: assocs classes.tuple combinators kernel lexer macros make
-math namespaces parser sequences words ;
+USING: assocs classes classes.tuple combinators kernel lexer
+macros make namespaces parser quotations sequences summary words
+;
 IN: match
 
 SYMBOL: _
@@ -19,8 +20,7 @@ SYMBOL: _
 SYNTAX: MATCH-VARS: ! vars ...
     ";" [ define-match-var ] each-token ;
 
-: match-var? ( symbol -- bool )
-    dup word? [ "match-var" word-prop ] [ drop f ] if ;
+PREDICATE: match-var < word "match-var" word-prop ;
 
 : set-match-var ( value var -- ? )
     building get ?at [ = ] [ ,, t ] if ;
@@ -32,19 +32,26 @@ SYNTAX: MATCH-VARS: ! vars ...
         { [ 2dup = ] [ 2drop t ] }
         { [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
         { [ 2dup [ sequence? ] both? ] [
-            2dup [ length ] same?
-            [ [ (match) ] 2all? ] [ 2drop f ] if ] }
-        { [ 2dup [ tuple? ] both? ]
-          [ [ tuple>array ] bi@ [ (match) ] 2all? ] }
+            2dup [ length ] same? [
+                [ (match) ] 2all?
+            ] [ 2drop f ] if ] }
+        { [ 2dup [ tuple? ] both? ] [
+            2dup [ class-of ] same? [
+                [ tuple-slots ] bi@ [ (match) ] 2all?
+            ] [ 2drop f ] if ] }
         { [ t ] [ 2drop f ] }
     } cond ;
 
 : match ( value1 value2 -- bindings )
     [ (match) ] H{ } make swap [ drop f ] unless ;
 
+ERROR: no-match-cond ;
+
+M: no-match-cond summary drop "Fall-through in match-cond" ;
+
 MACRO: match-cond ( assoc -- quot )
     <reversed>
-    [ "Fall-through in match-cond" throw ]
+    dup ?first callable? [ unclip ] [ [ no-match-cond ] ] if
     [
         first2
         [ [ dupd match ] curry ] dip
@@ -52,14 +59,11 @@ MACRO: match-cond ( assoc -- quot )
         [ ?if ] 2curry append
     ] reduce ;
 
-: replace-patterns ( object -- result )
-    {
-        { [ dup number? ] [ ] }
-        { [ dup match-var? ] [ get ] }
-        { [ dup sequence? ] [ [ replace-patterns ] map ] }
-        { [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
-        [ ]
-    } cond ;
+GENERIC: replace-patterns ( object -- result )
+M: object replace-patterns ;
+M: match-var replace-patterns get ;
+M: sequence replace-patterns [ replace-patterns ] map ;
+M: tuple replace-patterns tuple>array replace-patterns >tuple ;
 
 : match-replace ( object pattern1 pattern2 -- result )
     [ match [ "Pattern does not match" throw ] unless* ] dip swap
@@ -69,7 +73,9 @@ MACRO: match-cond ( assoc -- quot )
     [ f ] [ rest ] if-empty ;
 
 : (match-first) ( seq pattern-seq -- bindings leftover/f )
-    2dup shorter? [ 2drop f f ] [
+    2dup shorter? [
+        2drop f f
+    ] [
         2dup length head over match
         [ swap ?rest ] [ [ rest ] dip (match-first) ] ?if
     ] if ;