factor: trim using lists

[factor.git] / basis / match / match.factor

diff --git a/basis/match/match.factor b/basis/match/match.factor
index 7d393dadc9a2bab92567ec252275d2009915e97c..855672fdc4a05a55f21894e0b1fc84f200d11dd3 100644 (file)
--- a/basis/match/match.factor
+++ b/basis/match/match.factor
@@ -2,28 +2,27 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 ! Based on pattern matching code from Paul Graham's book 'On Lisp'.
-USING: parser lexer kernel words namespaces make sequences
-classes.tuple combinators macros assocs math effects ;
+USING: assocs classes classes.tuple combinators kernel lexer
+make namespaces parser quotations sequences summary words ;
 IN: match
 
 SYMBOL: _
 
 : define-match-var ( name -- )
-    create-in
+    create-word-in
     dup t "match-var" set-word-prop
-    dup [ get ] curry (( -- value )) define-declared ;
+    dup [ get ] curry ( -- value ) define-declared ;
 
 : define-match-vars ( seq -- )
     [ define-match-var ] each ;
 
-: MATCH-VARS: ! vars ...
-    ";" parse-tokens define-match-vars ; parsing
+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 -- ? )
-    dup namespace key? [ get = ] [ set t ] if ;
+    building get ?at [ = ] [ ,, t ] if ;
 
 : (match) ( value1 value2 -- matched? )
     {
@@ -32,59 +31,60 @@ SYMBOL: _
         { [ 2dup = ] [ 2drop t ] }
         { [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
         { [ 2dup [ sequence? ] both? ] [
-            2dup [ length ] bi@ =
-            [ [ (match) ] 2all? ] [ 2drop f ] if ] }
-        { [ 2dup [ tuple? ] both? ]
-          [ [ tuple>array ] bi@ [ (match) ] 2all? ] }
-        { [ t ] [ 2drop f ] }
+            2dup [ length ] same? [
+                [ (match) ] 2all?
+            ] [ 2drop f ] if ] }
+        { [ 2dup [ tuple? ] both? ] [
+            2dup [ class-of ] same? [
+                [ tuple-slots ] bi@ [ (match) ] 2all?
+            ] [ 2drop f ] if ] }
+        [ 2drop f ]
     } cond ;
 
 : match ( value1 value2 -- bindings )
-    [ (match) ] H{ } make-assoc swap [ drop f ] unless ;
+    [ (match) ] H{ } make swap [ drop f ] unless ;
 
-MACRO: match-cond ( assoc -- )
+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
-        >r [ dupd match ] curry r>
-        [ bind ] curry rot
+        [ [ 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 )
-    -rot
-    match [ "Pattern does not match" throw ] unless*
-    [ replace-patterns ] bind ;
+    [ match [ "Pattern does not match" throw ] unless* ] dip swap
+    [ replace-patterns ] with-variables ;
 
-: ?1-tail ( seq -- tail/f )
-    dup length zero? not [ rest ] [ drop f ] if ;
+: ?rest ( seq -- tailseq/f )
+    [ f ] [ rest ] if-empty ;
 
 : (match-first) ( seq pattern-seq -- bindings leftover/f )
-    2dup [ length ] bi@ < [ 2drop f f ]
-    [
+    2dup shorter? [
+        2drop f f
+    ] [
         2dup length head over match
-        [ nip swap ?1-tail ] [ [ rest ] dip (match-first) ] if*
+        [ swap ?rest ] [ [ rest ] dip (match-first) ] ?if
     ] if ;
-    
+
 : match-first ( seq pattern-seq -- bindings )
     (match-first) drop ;
 
 : (match-all) ( seq pattern-seq -- )
-    tuck (match-first) swap 
-    [ 
-        , [ swap (match-all) ] [ drop ] if* 
-    ] [ 2drop ] if* ;
+    [ (match-first) ] keep
+    [ , [ swap (match-all) ] [ drop ] if* ] [ 2drop ] if* ;
 
 : match-all ( seq pattern-seq -- bindings-seq )
     [ (match-all) ] { } make ;
-