basis/regexp/traversal/traversal.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators kernel math
   4 quotations sequences regexp.parser regexp.classes fry arrays
   5 combinators.short-circuit regexp.utils prettyprint regexp.nfa
   6 shuffle ;
   7 IN: regexp.traversal
   8
   9 TUPLE: dfa-traverser
  10     dfa-table
  11     traversal-flags
  12     traverse-forward
  13     lookahead-counters
  14     lookbehind-counters
  15     capture-counters
  16     captured-groups
  17     capture-group-index
  18     last-state current-state
  19     text
  20     match-failed?
  21     start-index current-index
  22     matches ;
  23
  24 : <dfa-traverser> ( text regexp -- match )
  25     [ dfa-table>> ] [ dfa-traversal-flags>> ] bi
  26     dfa-traverser new
  27         swap >>traversal-flags
  28         swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
  29         swap >>text
  30         t >>traverse-forward
  31         0 >>start-index
  32         0 >>current-index
  33         0 >>capture-group-index
  34         V{ } clone >>matches
  35         V{ } clone >>capture-counters
  36         V{ } clone >>lookbehind-counters
  37         V{ } clone >>lookahead-counters
  38         H{ } clone >>captured-groups ;
  39
  40 : final-state? ( dfa-traverser -- ? )
  41     [ current-state>> ]
  42     [ dfa-table>> final-states>> ] bi key? ;
  43
  44 : beginning-of-text? ( dfa-traverser -- ? )
  45     current-index>> 0 <= ; inline
  46
  47 : end-of-text? ( dfa-traverser -- ? )
  48     [ current-index>> ] [ text>> length ] bi >= ; inline
  49
  50 : text-finished? ( dfa-traverser -- ? )
  51     {
  52         [ current-state>> empty? ]
  53         [ end-of-text? ]
  54         [ match-failed?>> ]
  55     } 1|| ;
  56
  57 : save-final-state ( dfa-straverser -- )
  58     [ current-index>> ] [ matches>> ] bi push ;
  59
  60 : match-done? ( dfa-traverser -- ? )
  61     dup final-state? [
  62         dup save-final-state
  63     ] when text-finished? ;
  64
  65 : previous-text-character ( dfa-traverser -- ch )
  66     [ text>> ] [ current-index>> 1- ] bi nth ;
  67
  68 : current-text-character ( dfa-traverser -- ch )
  69     [ text>> ] [ current-index>> ] bi nth ;
  70
  71 : next-text-character ( dfa-traverser -- ch )
  72     [ text>> ] [ current-index>> 1+ ] bi nth ;
  73
  74 GENERIC: flag-action ( dfa-traverser flag -- )
  75
  76
  77 M: beginning-of-input flag-action ( dfa-traverser flag -- )
  78     drop
  79     dup beginning-of-text? [ t >>match-failed? ] unless drop ;
  80
  81 M: end-of-input flag-action ( dfa-traverser flag -- )
  82     drop
  83     dup end-of-text? [ t >>match-failed? ] unless drop ;
  84
  85
  86 M: beginning-of-line flag-action ( dfa-traverser flag -- )
  87     drop
  88     dup {
  89         [ beginning-of-text? ]
  90         [ previous-text-character terminator-class class-member? ]
  91     } 1|| [ t >>match-failed? ] unless drop ;
  92
  93 M: end-of-line flag-action ( dfa-traverser flag -- )
  94     drop
  95     dup {
  96         [ end-of-text? ]
  97         [ next-text-character terminator-class class-member? ]
  98     } 1|| [ t >>match-failed? ] unless drop ;
  99
 100
 101 M: word-boundary flag-action ( dfa-traverser flag -- )
 102     drop
 103     dup {
 104         [ end-of-text? ]
 105         [ current-text-character terminator-class class-member? ]
 106     } 1|| [ t >>match-failed? ] unless drop ;
 107
 108
 109 M: lookahead-on flag-action ( dfa-traverser flag -- )
 110     drop
 111     lookahead-counters>> 0 swap push ;
 112
 113 M: lookahead-off flag-action ( dfa-traverser flag -- )
 114     drop
 115     dup lookahead-counters>>
 116     [ drop ] [ pop '[ _ - ] change-current-index drop ] if-empty ;
 117
 118 M: lookbehind-on flag-action ( dfa-traverser flag -- )
 119     drop
 120     f >>traverse-forward
 121     [ 2 - ] change-current-index
 122     lookbehind-counters>> 0 swap push ;
 123
 124 M: lookbehind-off flag-action ( dfa-traverser flag -- )
 125     drop
 126     t >>traverse-forward
 127     dup lookbehind-counters>>
 128     [ drop ] [ pop '[ _ + 2 + ] change-current-index drop ] if-empty ;
 129
 130 M: capture-group-on flag-action ( dfa-traverser flag -- )
 131     drop
 132     [ current-index>> 0 2array ]
 133     [ capture-counters>> ] bi push ;
 134
 135 M: capture-group-off flag-action ( dfa-traverser flag -- )
 136     drop
 137     dup capture-counters>> empty? [
 138         drop
 139     ] [
 140         {
 141             [ capture-counters>> pop first2 dupd + ]
 142             [ text>> <slice> ]
 143             [ [ 1+ ] change-capture-group-index capture-group-index>> ]
 144             [ captured-groups>> set-at ]
 145         } cleave
 146     ] if ;
 147
 148 : process-flags ( dfa-traverser -- )
 149     [ [ 1+ ] map ] change-lookahead-counters
 150     [ [ 1+ ] map ] change-lookbehind-counters
 151     [ [ first2 1+ 2array ] map ] change-capture-counters
 152     ! dup current-state>> .
 153     dup [ current-state>> ] [ traversal-flags>> ] bi
 154     at [ flag-action ] with each ;
 155
 156 : increment-state ( dfa-traverser state -- dfa-traverser )
 157     [
 158         dup traverse-forward>>
 159         [ [ 1+ ] change-current-index ]
 160         [ [ 1- ] change-current-index ] if
 161         dup current-state>> >>last-state
 162     ] [ first ] bi* >>current-state ;
 163
 164 : match-literal ( transition from-state table -- to-state/f )
 165     transitions>> at at ;
 166
 167 : match-class ( transition from-state table -- to-state/f )
 168     transitions>> at* [
 169         [ drop class-member? ] assoc-with assoc-find [ nip ] [ drop ] if
 170     ] [ drop ] if ;
 171
 172 : match-default ( transition from-state table -- to-state/f )
 173     nipd transitions>> at t swap at ;
 174
 175 : match-transition ( obj from-state dfa -- to-state/f )
 176     { [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
 177
 178 : setup-match ( match -- obj state dfa-table )
 179     [ [ current-index>> ] [ text>> ] bi nth ]
 180     [ current-state>> ]
 181     [ dfa-table>> ] tri ;
 182
 183 : do-match ( dfa-traverser -- dfa-traverser )
 184     dup process-flags
 185     dup match-done? [
 186         dup setup-match match-transition
 187         [ increment-state do-match ] when*
 188     ] unless ;
 189
 190 : return-match ( dfa-traverser -- slice/f )
 191     dup matches>>
 192     [ drop f ]
 193     [
 194         [ [ text>> ] [ start-index>> ] bi ]
 195         [ peek ] bi* rot <slice>
 196     ] if-empty ;