basis/match/match.factor

   1 ! Copyright (C) 2006 Chris Double.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   4 ! Based on pattern matching code from Paul Graham's book 'On Lisp'.
   5 USING: parser lexer kernel words namespaces make sequences
   6 classes.tuple combinators macros assocs math effects ;
   7 IN: match
   8
   9 SYMBOL: _
  10
  11 : define-match-var ( name -- )
  12     create-in
  13     dup t "match-var" set-word-prop
  14     dup [ get ] curry ( -- value ) define-declared ;
  15
  16 : define-match-vars ( seq -- )
  17     [ define-match-var ] each ;
  18
  19 SYNTAX: MATCH-VARS: ! vars ...
  20     ";" [ define-match-var ] each-token ;
  21
  22 : match-var? ( symbol -- bool )
  23     dup word? [ "match-var" word-prop ] [ drop f ] if ;
  24
  25 : set-match-var ( value var -- ? )
  26     building get ?at [ = ] [ ,, t ] if ;
  27
  28 : (match) ( value1 value2 -- matched? )
  29     {
  30         { [ dup match-var? ] [ set-match-var ] }
  31         { [ over match-var? ] [ swap set-match-var ] }
  32         { [ 2dup = ] [ 2drop t ] }
  33         { [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
  34         { [ 2dup [ sequence? ] both? ] [
  35             2dup [ length ] bi@ =
  36             [ [ (match) ] 2all? ] [ 2drop f ] if ] }
  37         { [ 2dup [ tuple? ] both? ]
  38           [ [ tuple>array ] bi@ [ (match) ] 2all? ] }
  39         { [ t ] [ 2drop f ] }
  40     } cond ;
  41
  42 : match ( value1 value2 -- bindings )
  43     [ (match) ] H{ } make swap [ drop f ] unless ;
  44
  45 MACRO: match-cond ( assoc -- )
  46     <reversed>
  47     [ "Fall-through in match-cond" throw ]
  48     [
  49         first2
  50         [ [ dupd match ] curry ] dip
  51         [ with-variables ] curry rot
  52         [ ?if ] 2curry append
  53     ] reduce ;
  54
  55 : replace-patterns ( object -- result )
  56     {
  57         { [ dup number? ] [ ] }
  58         { [ dup match-var? ] [ get ] }
  59         { [ dup sequence? ] [ [ replace-patterns ] map ] }
  60         { [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
  61         [ ]
  62     } cond ;
  63
  64 : match-replace ( object pattern1 pattern2 -- result )
  65     [ match [ "Pattern does not match" throw ] unless* ] dip swap
  66     [ replace-patterns ] with-variables ;
  67
  68 : ?1-tail ( seq -- tail/f )
  69     dup length zero? not [ rest ] [ drop f ] if ;
  70
  71 : (match-first) ( seq pattern-seq -- bindings leftover/f )
  72     2dup shorter? [ 2drop f f ] [
  73         2dup length head over match
  74         [ swap ?1-tail ] [ [ rest ] dip (match-first) ] ?if
  75     ] if ;
  76
  77 : match-first ( seq pattern-seq -- bindings )
  78     (match-first) drop ;
  79
  80 : (match-all) ( seq pattern-seq -- )
  81     [ nip ] [ (match-first) swap ] 2bi
  82     [ , [ swap (match-all) ] [ drop ] if* ] [ 2drop ] if* ;
  83
  84 : match-all ( seq pattern-seq -- bindings-seq )
  85     [ (match-all) ] { } make ;