basis/regexp/compiler/compiler.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: regexp regexp.private regexp.classes kernel sequences regexp.negation
   4 quotations regexp.minimize assocs fry math locals combinators
   5 accessors words compiler.units ;
   6 IN: regexp.compiler
   7
   8 : literals>cases ( literal-transitions -- case-body )
   9     [ 1quotation ] assoc-map ;
  10
  11 : non-literals>dispatch ( non-literal-transitions -- quot )
  12     [ [ '[ dup _ class-member? ] ] [ 1quotation ] bi* ] assoc-map
  13     [ 3drop f ] suffix '[ _ cond ] ;
  14
  15 : split-literals ( transitions -- case default )
  16     ! Convert disjunction of literals to literals. Also maybe small ranges.
  17     >alist [ first integer? ] partition
  18     [ literals>cases ] [ non-literals>dispatch ] bi* ;
  19
  20 USING: kernel.private strings sequences.private ;
  21
  22 :: step ( index str case-body final? -- match? )
  23     index str bounds-check? [
  24         index 1+ str
  25         index str nth-unsafe
  26         case-body case
  27     ] [ final? ] if ; inline
  28
  29 : transitions>quot ( transitions final-state? -- quot )
  30     [ split-literals suffix ] dip
  31     '[ { array-capacity string } declare _ _ step ] ;
  32
  33 : word>quot ( word dfa -- quot )
  34     [ transitions>> at ]
  35     [ final-states>> key? ] 2bi
  36     transitions>quot ;
  37
  38 : states>code ( words dfa -- )
  39     '[
  40         [
  41             dup _ word>quot
  42             (( index string -- ? )) define-declared
  43         ] each
  44     ] with-compilation-unit ;
  45
  46 : transitions-at ( transitions assoc -- new-transitions )
  47     dup '[
  48         [ _ at ]
  49         [ [ _ at ] assoc-map ] bi*
  50     ] assoc-map ;
  51
  52 : states>words ( dfa -- words dfa )
  53     dup transitions>> keys [ gensym ] H{ } map>assoc
  54     [ [ transitions-at ] rewrite-transitions ]
  55     [ values ]
  56     bi swap ;
  57
  58 : dfa>word ( dfa -- word )
  59     states>words [ states>code ] keep start-state>> ;
  60
  61 : run-regexp ( string word -- ? )
  62     [ 0 ] 2dip execute ; inline
  63
  64 : regexp>quotation ( regexp -- quot )
  65     compile-regexp dfa>> dfa>word '[ _ run-regexp ] ;