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: assocs classes classes.tuple combinators kernel lexer
   6 macros make namespaces parser quotations sequences summary words
   7 ;
   8 IN: match
   9
  10 SYMBOL: _
  11
  12 : define-match-var ( name -- )
  13     create-word-in
  14     dup t "match-var" set-word-prop
  15     dup [ get ] curry ( -- value ) define-declared ;
  16
  17 : define-match-vars ( seq -- )
  18     [ define-match-var ] each ;
  19
  20 SYNTAX: MATCH-VARS: ! vars ...
  21     ";" [ define-match-var ] each-token ;
  22
  23 PREDICATE: match-var < word "match-var" word-prop ;
  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 ] same? [
  36                 [ (match) ] 2all?
  37             ] [ 2drop f ] if ] }
  38         { [ 2dup [ tuple? ] both? ] [
  39             2dup [ class-of ] same? [
  40                 [ tuple-slots ] bi@ [ (match) ] 2all?
  41             ] [ 2drop f ] if ] }
  42         { [ t ] [ 2drop f ] }
  43     } cond ;
  44
  45 : match ( value1 value2 -- bindings )
  46     [ (match) ] H{ } make swap [ drop f ] unless ;
  47
  48 ERROR: no-match-cond ;
  49
  50 M: no-match-cond summary drop "Fall-through in match-cond" ;
  51
  52 MACRO: match-cond ( assoc -- quot )
  53     <reversed>
  54     dup ?first callable? [ unclip ] [ [ throw-no-match-cond ] ] if
  55     [
  56         first2
  57         [ [ dupd match ] curry ] dip
  58         [ with-variables ] curry rot
  59         [ ?if ] 2curry append
  60     ] reduce ;
  61
  62 GENERIC: replace-patterns ( object -- result )
  63 M: object replace-patterns ;
  64 M: match-var replace-patterns get ;
  65 M: sequence replace-patterns [ replace-patterns ] map ;
  66 M: tuple replace-patterns tuple>array replace-patterns >tuple ;
  67
  68 : match-replace ( object pattern1 pattern2 -- result )
  69     [ match [ "Pattern does not match" throw ] unless* ] dip swap
  70     [ replace-patterns ] with-variables ;
  71
  72 : ?rest ( seq -- tailseq/f )
  73     [ f ] [ rest ] if-empty ;
  74
  75 : (match-first) ( seq pattern-seq -- bindings leftover/f )
  76     2dup shorter? [
  77         2drop f f
  78     ] [
  79         2dup length head over match
  80         [ swap ?rest ] [ [ rest ] dip (match-first) ] ?if
  81     ] if ;
  82
  83 : match-first ( seq pattern-seq -- bindings )
  84     (match-first) drop ;
  85
  86 : (match-all) ( seq pattern-seq -- )
  87     [ nip ] [ (match-first) swap ] 2bi
  88     [ , [ swap (match-all) ] [ drop ] if* ] [ 2drop ] if* ;
  89
  90 : match-all ( seq pattern-seq -- bindings-seq )
  91     [ (match-all) ] { } make ;