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 regexp.minimize assocs fry math locals combinators
   5 accessors words compiler.units kernel.private strings
   6 sequences.private arrays regexp.matchers call namespaces
   7 regexp.transition-tables combinators.short-circuit ;
   8 IN: regexp.compiler
   9
  10 GENERIC: question>quot ( question -- quot )
  11
  12 <PRIVATE
  13
  14 SYMBOL: shortest?
  15 SYMBOL: backwards?
  16
  17 M: t question>quot drop [ 2drop t ] ;
  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         [ [ nip [ length ] keep ] when ] keep
  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 ! Maybe the condition>quot things can be combined, given a suitable method
  41 ! for question>quot on classes, but maybe that'd make stack shuffling annoying
  42
  43 : execution-quot ( next-state -- quot )
  44     ! The conditions here are for lookaround and anchors, etc
  45     dup condition? [
  46         [ question>> question>quot ] [ yes>> ] [ no>> ] tri
  47         [ execution-quot ] bi@
  48         '[ 2dup @ _ _ if ]
  49     ] [
  50         ! There shouldn't be a condition like this!
  51         dup sequence?
  52         [ [ [ 2drop ] ] [ first '[ _ execute ] ] if-empty ]
  53         [ '[ _ execute ] ] if
  54     ] if ;
  55
  56 TUPLE: box contents ;
  57 C: <box> box
  58
  59 : condition>quot ( condition -- quot )
  60     ! Conditions here are for different classes
  61     dup condition? [
  62         [ question>> ] [ yes>> ] [ no>> ] tri
  63         [ condition>quot ] bi@
  64         '[ dup _ class-member? _ _ if ]
  65     ] [
  66         contents>>
  67         [ [ 3drop ] ] [ execution-quot '[ drop @ ] ] if-empty
  68     ] if ;
  69
  70 : non-literals>dispatch ( non-literal-transitions -- quot )
  71     [ swap ] assoc-map ! we want state => predicate, and get the opposite as input
  72     table>condition [ <box> ] condition-map condition>quot ;
  73
  74 : literals>cases ( literal-transitions -- case-body )
  75     [ execution-quot ] assoc-map ;
  76
  77 : expand-one-or ( or-class transition -- alist )
  78     [ seq>> ] dip '[ _ 2array ] map ;
  79
  80 : expand-or ( alist -- new-alist )
  81     [
  82         first2 over or-class?
  83         [ expand-one-or ] [ 2array 1array ] if
  84     ] map concat ;
  85
  86 : split-literals ( transitions -- case default )
  87     >alist expand-or [ first integer? ] partition
  88     [ literals>cases ] [ non-literals>dispatch ] bi* ;
  89
  90 :: step ( last-match index str quot final? direction -- last-index/f )
  91     final? index last-match ?
  92     index str bounds-check? [
  93         index direction + str
  94         index str nth-unsafe
  95         quot call
  96     ] when ; inline
  97
  98 : direction ( -- n )
  99     backwards? get -1 1 ? ;
 100
 101 : transitions>quot ( transitions final-state? -- quot )
 102     dup shortest? get and [ 2drop [ drop nip ] ] [
 103         [ split-literals swap case>quot ] dip direction
 104         '[ { array-capacity 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         [
 115             dup _ word>quot
 116             (( last-match index string -- ? ))
 117             define-declared
 118         ] each
 119     ] with-compilation-unit ;
 120
 121 : states>words ( dfa -- words dfa )
 122     dup transitions>> keys [ gensym ] H{ } map>assoc
 123     [ transitions-at ]
 124     [ values ]
 125     bi swap ;
 126
 127 : dfa>word ( dfa -- word )
 128     states>words [ states>code ] keep start-state>> ;
 129
 130 : check-string ( string -- string )
 131     ! Make this configurable
 132     dup string? [ "String required" throw ] unless ;
 133
 134 : setup-regexp ( start-index string -- f start-index string )
 135     [ f ] [ >fixnum ] [ check-string ] tri* ; inline
 136
 137 PRIVATE>
 138
 139 ! The quotation returned is ( start-index string -- i/f )
 140
 141 : dfa>quotation ( dfa -- quot )
 142     dfa>word execution-quot '[ setup-regexp @ ] ;
 143
 144 : dfa>shortest-quotation ( dfa -- quot )
 145     t shortest? [ dfa>quotation ] with-variable ;
 146
 147 : dfa>reverse-quotation ( dfa -- quot )
 148     t backwards? [ dfa>quotation ] with-variable ;
 149
 150 : dfa>reverse-shortest-quotation ( dfa -- quot )
 151     t backwards? [ dfa>shortest-quotation ] with-variable ;
 152
 153 TUPLE: quot-matcher quot ;
 154 C: <quot-matcher> quot-matcher
 155
 156 M: quot-matcher match-index-from
 157     quot>> call( index string -- i/f ) ;