basis/regexp/compiler/compiler.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators combinators.short-circuit
   4 kernel kernel.private math namespaces regexp.classes
   5 regexp.transition-tables sequences sequences.private sets
   6 strings unicode words ;
   7 IN: regexp.compiler
   8
   9 GENERIC: question>quot ( question -- quot )
  10
  11 SYMBOL: shortest?
  12 SYMBOL: backwards?
  13
  14 <PRIVATE
  15
  16 M: t question>quot drop [ 2drop t ] ;
  17 M: f question>quot drop [ 2drop f ] ;
  18
  19 M: beginning-of-input question>quot
  20     drop [ drop zero? ] ;
  21
  22 M: end-of-input question>quot
  23     drop [ length = ] ;
  24
  25 M: end-of-file question>quot
  26     drop [
  27         {
  28             [ length swap - 2 <= ]
  29             [ swap tail { "\n" "\r\n" "\r" "" } member? ]
  30         } 2&&
  31     ] ;
  32
  33 M: $crlf question>quot
  34     drop [ { [ length = ] [ ?nth "\r\n" member? ] } 2|| ] ;
  35
  36 M: ^crlf question>quot
  37     drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth "\r\n" member? ] } 2|| ] ;
  38
  39 M: $unix question>quot
  40     drop [ { [ length = ] [ ?nth CHAR: \n = ] } 2|| ] ;
  41
  42 M: ^unix question>quot
  43     drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth CHAR: \n = ] } 2|| ] ;
  44
  45 M: word-break question>quot
  46     drop [ word-break-at? ] ;
  47
  48 : (execution-quot) ( next-state -- quot )
  49     ! The conditions here are for lookaround and anchors, etc
  50     dup condition? [
  51         [ question>> question>quot ] [ yes>> ] [ no>> ] tri
  52         [ (execution-quot) ] bi@
  53         '[ 2dup @ _ _ if ]
  54     ] [ '[ _ execute ] ] if ;
  55
  56 : execution-quot ( next-state -- quot )
  57     dup sequence? [ first ] when
  58     (execution-quot) ;
  59
  60 TUPLE: box contents ;
  61 C: <box> box
  62
  63 : condition>quot ( condition -- quot )
  64     ! Conditions here are for different classes
  65     dup condition? [
  66         [ question>> ] [ yes>> ] [ no>> ] tri
  67         [ condition>quot ] bi@
  68         '[ dup _ class-member? _ _ if ]
  69     ] [
  70         contents>>
  71         [ [ 3drop ] ] [ execution-quot '[ drop @ ] ] if-empty
  72     ] if ;
  73
  74 : non-literals>dispatch ( literals non-literals  -- quot )
  75     [ swap ] assoc-map ! we want state => predicate, and get the opposite as input
  76     swap keys f assoc-answers
  77     table>condition [ <box> ] condition-map condition>quot ;
  78
  79 : literals>cases ( literal-transitions -- case-body )
  80     [ execution-quot ] assoc-map ;
  81
  82 : split-literals ( transitions -- case default )
  83     { } assoc-like [ first integer? ] partition
  84     [ [ literals>cases ] keep ] dip non-literals>dispatch ;
  85
  86 : advance ( index backwards? -- index+/-1 )
  87     -1 1 ? + >fixnum ; inline
  88
  89 : check ( index string backwards? -- in-bounds? )
  90     [ drop -1 eq? not ] [ length < ] if ; inline
  91
  92 :: step ( last-match index str quot final? backwards? -- last-index/f )
  93     final? index last-match ?
  94     index str backwards? check [
  95         index backwards? advance str
  96         index str nth-unsafe
  97         quot call
  98     ] when ; inline
  99
 100 : transitions>quot ( transitions final-state? -- quot )
 101     dup shortest? get and [ 2drop [ drop nip ] ] [
 102         [ split-literals swap case>quot ] dip backwards? get
 103         '[ { fixnum string } declare _ _ _ step ]
 104     ] if ;
 105
 106 : word>quot ( word dfa -- quot )
 107     [ transitions>> at ]
 108     [ final-states>> in? ] 2bi
 109     transitions>quot ;
 110
 111 : states>code ( words dfa -- )
 112     '[
 113         dup _ word>quot
 114         ( last-match index string -- ? )
 115         define-declared
 116     ] each ;
 117
 118 : states>words ( dfa -- words dfa )
 119     dup transitions>> keys [ gensym ] H{ } map>assoc
 120     [ transitions-at ]
 121     [ values ]
 122     bi swap ;
 123
 124 : dfa>main-word ( dfa -- word )
 125     states>words [ states>code ] keep start-state>> ;
 126
 127 : word-template ( quot -- quot' )
 128     '[ drop [ f ] 2dip over array-capacity? _ [ 2drop ] if ] ;
 129
 130 PRIVATE>
 131
 132 : dfa>word ( dfa -- quot )
 133     dfa>main-word execution-quot word-template
 134     ( start-index string regexp -- i/f ) define-temp ;
 135
 136 : dfa>shortest-word ( dfa -- word )
 137     t shortest? [ dfa>word ] with-variable ;
 138
 139 : dfa>reverse-word ( dfa -- word )
 140     t backwards? [ dfa>word ] with-variable ;
 141
 142 : dfa>reverse-shortest-word ( dfa -- word )
 143     t backwards? [ dfa>shortest-word ] with-variable ;