basis/regexp/nfa/nfa.factor

   1 ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators.short-circuit kernel
   4 math namespaces regexp.ast regexp.classes
   5 regexp.transition-tables sequences sets unicode vectors ;
   6 IN: regexp.nfa
   7
   8 ! This uses unicode for ch>upper and ch>lower
   9 ! but case-insensitive matching should be done by case-folding everything
  10 ! before processing starts
  11
  12 SYMBOL: option-stack
  13
  14 SYMBOL: state
  15
  16 : next-state ( -- state )
  17     state [ get ] [ inc ] bi ;
  18
  19 SYMBOL: nfa-table
  20
  21 : set-each ( keys value hashtable -- )
  22     '[ _ swap _ set-at ] each ;
  23
  24 : options>hash ( options -- hashtable )
  25     H{ } clone [
  26         [ [ on>> t ] dip set-each ]
  27         [ [ off>> f ] dip set-each ] 2bi
  28     ] keep ;
  29
  30 : using-options ( options quot -- )
  31     [ options>hash option-stack [ ?push ] change ] dip
  32     call option-stack get pop* ; inline
  33
  34 : option? ( obj -- ? )
  35     option-stack get assoc-stack ;
  36
  37 GENERIC: nfa-node ( node -- start-state end-state )
  38
  39 : add-simple-entry ( obj -- start-state end-state )
  40     [ next-state next-state 2dup ] dip
  41     nfa-table get add-transition ;
  42
  43 : epsilon-transition ( source target -- )
  44     epsilon nfa-table get add-transition ;
  45
  46 M:: star nfa-node ( node -- start end )
  47     node term>> nfa-node :> ( s0 s1 )
  48     next-state :> s2
  49     next-state :> s3
  50     s1 s0 epsilon-transition
  51     s2 s0 epsilon-transition
  52     s2 s3 epsilon-transition
  53     s1 s3 epsilon-transition
  54     s2 s3 ;
  55
  56 GENERIC: modify-epsilon ( tag -- newtag )
  57 ! Potential off-by-one errors when lookaround nested in lookbehind
  58
  59 M: object modify-epsilon ;
  60
  61 : line-option ( multiline unix-lines default -- option )
  62     multiline option? [
  63         drop [ unix-lines option? ] 2dip swap ?
  64     ] [ 2nip ] if ;
  65
  66 M: $crlf modify-epsilon
  67     $unix end-of-input line-option ;
  68
  69 M: ^crlf modify-epsilon
  70     ^unix beginning-of-input line-option ;
  71
  72 M: tagged-epsilon nfa-node
  73     clone [ modify-epsilon ] change-tag add-simple-entry ;
  74
  75 M: concatenation nfa-node
  76     [ first>> ] [ second>> ] bi
  77     reversed-regexp option? [ swap ] when
  78     [ nfa-node ] bi@
  79     [ epsilon-transition ] dip ;
  80
  81 :: alternate-nodes ( s0 s1 s2 s3 -- start end )
  82     next-state :> s4
  83     next-state :> s5
  84     s4 s0 epsilon-transition
  85     s4 s2 epsilon-transition
  86     s1 s5 epsilon-transition
  87     s3 s5 epsilon-transition
  88     s4 s5 ;
  89
  90 M: alternation nfa-node
  91     [ first>> ] [ second>> ] bi
  92     [ nfa-node ] bi@
  93     alternate-nodes ;
  94
  95 GENERIC: modify-class ( char-class -- char-class' )
  96
  97 M: object modify-class ;
  98
  99 M: integer modify-class
 100     case-insensitive option? [
 101         dup Letter? [
 102             [ ch>lower ] [ ch>upper ] bi 2array <or-class>
 103         ] when
 104     ] when ;
 105
 106 M: integer nfa-node
 107     modify-class add-simple-entry ;
 108
 109 M: primitive-class modify-class
 110     class>> modify-class <primitive-class> ;
 111
 112 M: or-class modify-class
 113     seq>> [ modify-class ] map <or-class> ;
 114
 115 M: not-class modify-class
 116     class>> modify-class <not-class> ;
 117
 118 MEMO: unix-dot ( -- class )
 119     CHAR: \n <not-class> ;
 120
 121 MEMO: nonl-dot ( -- class )
 122     { CHAR: \n CHAR: \r } <or-class> <not-class> ;
 123
 124 M: dot modify-class
 125     drop dotall option? [ t ] [
 126         unix-lines option?
 127         unix-dot nonl-dot ?
 128     ] if ;
 129
 130 : modify-letter-class ( class -- newclass )
 131     case-insensitive option? [ drop Letter-class ] when ;
 132 M: letter-class modify-class modify-letter-class ;
 133 M: LETTER-class modify-class modify-letter-class ;
 134
 135 : cased-range? ( range -- ? )
 136     [ from>> ] [ to>> ] bi {
 137         [ [ letter? ] both? ]
 138         [ [ LETTER? ] both? ]
 139     } 2|| ;
 140
 141 M: range-class modify-class
 142     case-insensitive option? [
 143         dup cased-range? [
 144             [ from>> ] [ to>> ] bi
 145             [ [ ch>lower ] bi@ <range-class> ]
 146             [ [ ch>upper ] bi@ <range-class> ] 2bi
 147             2array <or-class>
 148         ] when
 149     ] when ;
 150
 151 M: object nfa-node
 152     modify-class add-simple-entry ;
 153
 154 M: with-options nfa-node
 155     dup options>> [ tree>> nfa-node ] using-options ;
 156
 157 : construct-nfa ( ast -- nfa-table )
 158     [
 159         0 state namespaces:set
 160         <transition-table> nfa-table namespaces:set
 161         nfa-node
 162         nfa-table get
 163             swap 1array fast-set >>final-states
 164             swap >>start-state
 165     ] with-scope ;