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

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 '?'" } }

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

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
+USING: assocs classes classes.tuple combinators kernel lexer
-math namespaces parser sequences words ;
+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 )
+PREDICATE: match-var < word "match-var" word-prop ;
-    dup word? [ "match-var" word-prop ] [ drop f ] if ;
 
 : 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?
+            2dup [ length ] same? [
-            [ [ (match) ] 2all? ] [ 2drop f ] if ] }
+                [ (match) ] 2all?
-        { [ 2dup [ tuple? ] both? ]
+            ] [ 2drop f ] if ] }
-          [ [ tuple>array ] bi@ [ (match) ] 2all? ] }
+        { [ 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 )
+GENERIC: replace-patterns ( object -- result )
-    {
+M: object replace-patterns ;
-        { [ dup number? ] [ ] }
+M: match-var replace-patterns get ;
-        { [ dup match-var? ] [ get ] }
+M: sequence replace-patterns [ replace-patterns ] map ;
-        { [ dup sequence? ] [ [ replace-patterns ] map ] }
+M: tuple replace-patterns tuple>array replace-patterns >tuple ;
-        { [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
-        [ ]
-    } cond ;
 
 : 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 ;