1 ! Copyright (C) 2006 Chris Double.
2 ! See https://factorcode.org/license.txt for BSD license.
4 ! Based on pattern matching code from Paul Graham's book 'On Lisp'.
5 USING: assocs classes classes.tuple combinators kernel lexer
6 make namespaces parser quotations sequences summary words ;
11 : define-match-var ( name -- )
13 dup t "match-var" set-word-prop
14 dup [ get ] curry ( -- value ) define-declared ;
16 : define-match-vars ( seq -- )
17 [ define-match-var ] each ;
19 SYNTAX: MATCH-VARS: ! vars ...
20 ";" [ define-match-var ] each-token ;
22 PREDICATE: match-var < word "match-var" word-prop ;
24 : set-match-var ( value var -- ? )
25 building get ?at [ = ] [ ,, t ] if ;
27 : (match) ( value1 value2 -- matched? )
29 { [ dup match-var? ] [ set-match-var ] }
30 { [ over match-var? ] [ swap set-match-var ] }
31 { [ 2dup = ] [ 2drop t ] }
32 { [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
33 { [ 2dup [ sequence? ] both? ] [
34 2dup [ length ] same? [
37 { [ 2dup [ tuple? ] both? ] [
38 2dup [ class-of ] same? [
39 [ tuple-slots ] bi@ [ (match) ] 2all?
44 : match ( value1 value2 -- bindings )
45 [ (match) ] H{ } make swap [ drop f ] unless ;
47 ERROR: no-match-cond ;
49 M: no-match-cond summary drop "Fall-through in match-cond" ;
51 MACRO: match-cond ( assoc -- quot )
53 dup ?first callable? [ unclip ] [ [ no-match-cond ] ] if
56 [ [ dupd match ] curry ] dip
57 [ with-variables ] curry rot
58 [ ?if-old ] 2curry append
61 GENERIC: replace-patterns ( object -- result )
62 M: object replace-patterns ;
63 M: match-var replace-patterns get ;
64 M: sequence replace-patterns [ replace-patterns ] map ;
65 M: tuple replace-patterns tuple>array replace-patterns >tuple ;
67 : match-replace ( object pattern1 pattern2 -- result )
68 [ match [ "Pattern does not match" throw ] unless* ] dip swap
69 [ replace-patterns ] with-variables ;
71 : ?rest ( seq -- tailseq/f )
72 [ f ] [ rest ] if-empty ;
74 : (match-first) ( seq pattern-seq -- bindings leftover/f )
78 2dup length head over match
79 [ swap ?rest ] [ [ rest ] dip (match-first) ] ?if-old
82 : match-first ( seq pattern-seq -- bindings )
85 : (match-all) ( seq pattern-seq -- )
86 [ (match-first) ] keep
87 [ , [ swap (match-all) ] [ drop ] if* ] [ 2drop ] if* ;
89 : match-all ( seq pattern-seq -- bindings-seq )
90 [ (match-all) ] { } make ;