extra/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 kernel words namespaces sequences tuples
   6 combinators macros ;
   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 define-compound ;
  15
  16 : define-match-vars ( seq -- )
  17     [ define-match-var ] each ;
  18
  19 : MATCH-VARS: ! vars ...
  20     ";" parse-tokens define-match-vars ; parsing
  21
  22 : match-var? ( symbol -- bool )
  23     dup word? [ "match-var" word-prop ] [ drop f ] if ;
  24
  25 : (match) ( value1 value2 -- matched? )
  26     {
  27         { [ dup match-var? ] [ set t ] }
  28         { [ over match-var? ] [ swap set t ] }
  29         { [ 2dup = ] [ 2drop t ] }
  30         { [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
  31         { [ 2dup [ sequence? ] both? ] [
  32             2dup [ length ] 2apply =
  33             [ [ (match) ] 2all? ] [ 2drop f ] if ] }
  34         { [ 2dup [ tuple? ] both? ]
  35           [ [ tuple>array ] 2apply [ (match) ] 2all? ] }
  36         { [ t ] [ 2drop f ] }
  37     } cond ;
  38
  39 : match ( value1 value2 -- bindings )
  40     [ (match) ] H{ } make-assoc swap [ drop f ] unless ;
  41
  42 MACRO: match-cond ( assoc -- )
  43     <reversed>
  44     [ "Fall-through in match-cond" throw ]
  45     [
  46         first2
  47         >r [ dupd match ] curry r>
  48         [ bind ] curry rot
  49         [ ?if ] 2curry append
  50     ] reduce ;
  51
  52 : replace-patterns ( object -- result )
  53     {
  54         { [ dup match-var? ] [ get ] }
  55         { [ dup sequence? ] [ [ replace-patterns ] map ] }
  56         { [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
  57         { [ t ] [ ] }
  58     } cond ;
  59
  60 : match-replace ( object pattern1 pattern2 -- result )
  61     -rot match [ replace-patterns ] bind ;