basis/regexp/compiler/compiler.factor

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