! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: regexp.classes kernel sequences regexp.negation
-quotations regexp.minimize assocs fry math locals combinators
-accessors words compiler.units kernel.private strings
-sequences.private arrays regexp.matchers call ;
+USING: accessors assocs combinators combinators.short-circuit
+kernel kernel.private math namespaces quotations regexp.classes
+regexp.transition-tables sequences sequences.private sets
+strings unicode words ;
IN: regexp.compiler
-: literals>cases ( literal-transitions -- case-body )
- [ 1quotation ] assoc-map ;
+GENERIC: question>quot ( question -- quot )
+
+SYMBOL: shortest?
+SYMBOL: backwards?
+
+<PRIVATE
+
+M: t question>quot drop [ 2drop t ] ;
+M: f question>quot drop [ 2drop f ] ;
+
+M: beginning-of-input question>quot
+ drop [ drop zero? ] ;
+
+M: end-of-input question>quot
+ drop [ length = ] ;
+
+M: end-of-file question>quot
+ drop [
+ {
+ [ length swap - 2 <= ]
+ [ swap tail { "\n" "\r\n" "\r" "" } member? ]
+ } 2&&
+ ] ;
+
+M: $crlf question>quot
+ drop [ { [ length = ] [ ?nth "\r\n" member? ] } 2|| ] ;
+
+M: ^crlf question>quot
+ drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth "\r\n" member? ] } 2|| ] ;
+
+M: $unix question>quot
+ drop [ { [ length = ] [ ?nth CHAR: \n = ] } 2|| ] ;
-: non-literals>dispatch ( non-literal-transitions -- quot )
- [ [ '[ dup _ class-member? ] ] [ '[ drop _ execute ] ] bi* ] assoc-map
- [ 3drop ] suffix '[ _ cond ] ;
+M: ^unix question>quot
+ drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth CHAR: \n = ] } 2|| ] ;
-: expand-one-or ( or-class transition -- alist )
- [ seq>> ] dip '[ _ 2array ] map ;
+M: word-break question>quot
+ drop [ word-break-at? ] ;
-: expand-or ( alist -- new-alist )
- [
- first2 over or-class?
- [ expand-one-or ] [ 2array 1array ] if
- ] map concat ;
+: (execution-quot) ( next-state -- quot )
+ ! The conditions here are for lookaround and anchors, etc
+ dup condition? [
+ [ question>> question>quot ] [ yes>> ] [ no>> ] tri
+ [ (execution-quot) ] bi@
+ '[ 2dup @ _ _ if ]
+ ] [ 1quotation ] if ;
+
+: execution-quot ( next-state -- quot )
+ dup sequence? [ first ] when
+ (execution-quot) ;
+
+TUPLE: box contents ;
+C: <box> box
+
+: condition>quot ( condition -- quot )
+ ! Conditions here are for different classes
+ dup condition? [
+ [ question>> ] [ yes>> ] [ no>> ] tri
+ [ condition>quot ] bi@
+ '[ dup _ class-member? _ _ if ]
+ ] [
+ contents>>
+ [ [ 3drop ] ] [ execution-quot '[ drop @ ] ] if-empty
+ ] if ;
+
+: non-literals>dispatch ( literals non-literals -- quot )
+ [ swap ] assoc-map ! we want state => predicate, and get the opposite as input
+ swap keys f assoc-answers
+ table>condition [ <box> ] condition-map condition>quot ;
+
+: literals>cases ( literal-transitions -- case-body )
+ [ execution-quot ] assoc-map ;
: split-literals ( transitions -- case default )
- >alist expand-or [ first integer? ] partition
- [ literals>cases ] [ non-literals>dispatch ] bi* ;
+ { } assoc-like [ first integer? ] partition
+ [ [ literals>cases ] keep ] dip non-literals>dispatch ;
+
+: advance ( index backwards? -- index+/-1 )
+ -1 1 ? + >fixnum ; inline
-:: step ( last-match index str case-body final? -- last-index/f )
+: check ( index string backwards? -- in-bounds? )
+ [ drop -1 eq? not ] [ length < ] if ; inline
+
+:: step ( last-match index str quot final? backwards? -- last-index/f )
final? index last-match ?
- index str bounds-check? [
- index 1+ str
+ index str backwards? check [
+ index backwards? advance str
index str nth-unsafe
- case-body case
+ quot call
] when ; inline
: transitions>quot ( transitions final-state? -- quot )
- [ split-literals suffix ] dip
- '[ { array-capacity string } declare _ _ step ] ;
+ dup shortest? get and [ 2drop [ drop nip ] ] [
+ [ split-literals swap case>quot ] dip backwards? get
+ '[ { fixnum string } declare _ _ _ step ]
+ ] if ;
: word>quot ( word dfa -- quot )
[ transitions>> at ]
- [ final-states>> key? ] 2bi
+ [ final-states>> in? ] 2bi
transitions>quot ;
: states>code ( words dfa -- )
'[
- [
- dup _ word>quot
- (( last-match index string -- ? ))
- define-declared
- ] each
- ] with-compilation-unit ;
-
-: transitions-at ( transitions assoc -- new-transitions )
- dup '[
- [ _ at ]
- [ [ _ at ] assoc-map ] bi*
- ] assoc-map ;
+ dup _ word>quot
+ ( last-match index string -- ? )
+ define-declared
+ ] each ;
: states>words ( dfa -- words dfa )
dup transitions>> keys [ gensym ] H{ } map>assoc
- [ [ transitions-at ] rewrite-transitions ]
+ [ transitions-at ]
[ values ]
- bi swap ;
+ bi swap ;
-: dfa>word ( dfa -- word )
+: dfa>main-word ( dfa -- word )
states>words [ states>code ] keep start-state>> ;
-: check-string ( string -- string )
- dup string? [ "String required" throw ] unless ;
+: word-template ( quot -- quot' )
+ '[ drop [ f ] 2dip over array-capacity? _ [ 2drop ] if ] ;
+
+PRIVATE>
-: run-regexp ( start-index string word -- ? )
- { [ f ] [ >fixnum ] [ check-string ] [ execute ] } spread ; inline
+: dfa>word ( dfa -- quot )
+ dfa>main-word execution-quot word-template
+ ( start-index string regexp -- i/f ) define-temp ;
-: dfa>quotation ( dfa -- quot )
- dfa>word '[ _ run-regexp ] ;
+: dfa>shortest-word ( dfa -- word )
+ t shortest? [ dfa>word ] with-variable ;
-TUPLE: quot-matcher quot ;
-C: <quot-matcher> quot-matcher
+: dfa>reverse-word ( dfa -- word )
+ t backwards? [ dfa>word ] with-variable ;
-M: quot-matcher match-index-from
- quot>> call( index string -- i/f ) ;
+: dfa>reverse-shortest-word ( dfa -- word )
+ t backwards? [ dfa>shortest-word ] with-variable ;
projects / factor.git / blobdiff