Permalink
Browse files

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

  • Loading branch information...
mrjbq7 committed Aug 6, 2015
1 parent 6e397d5 commit 8c82f46ee96193cc016f6ea2fca472d2e0ee7c42
Showing with 49 additions and 23 deletions.
  1. +5 −4 basis/match/match-docs.factor
  2. +20 −1 basis/match/match-tests.factor
  3. +24 −18 basis/match/match.factor
@@ -7,21 +7,22 @@ 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 } }" }
}
{ $see-also match-cond POSTPONE: MATCH-VARS: replace-patterns match-replace } ;
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 '?'" } }
@@ -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
View
@@ -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,34 +32,38 @@ 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
[ with-variables ] curry rot
[ ?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 ;

0 comments on commit 8c82f46

Please sign in to comment.