diff --git a/basis/globs/globs.factor b/basis/globs/globs.factor index 173187574b..cac7fd9a2f 100644 --- a/basis/globs/globs.factor +++ b/basis/globs/globs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel regexp.combinators regexp.matchers strings unicode.case +USING: sequences kernel regexp.combinators strings unicode.case peg.ebnf regexp arrays ; IN: globs diff --git a/basis/regexp/classes/classes-tests.factor b/basis/regexp/classes/classes-tests.factor index 520e23c749..2deb944b61 100644 --- a/basis/regexp/classes/classes-tests.factor +++ b/basis/regexp/classes/classes-tests.factor @@ -30,15 +30,15 @@ IN: regexp.classes.tests [ T{ or-class { seq { 3 2 } } } ] [ { 2 3 } 1 2array ] unit-test [ f ] [ t ] unit-test [ t ] [ f ] unit-test -[ f ] [ 1 1 t replace-question ] unit-test +[ f ] [ 1 1 t answer ] unit-test ! Making classes into nested conditionals [ V{ 1 2 3 4 } ] [ T{ and-class f { 1 T{ not-class f 2 } T{ or-class f { 3 4 } } 2 } } class>questions ] unit-test [ { 3 } ] [ { { 3 t } } table>condition ] unit-test [ { T{ primitive-class } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>questions ] unit-test -[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t answer ] unit-test -[ { { 1 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } f answer ] unit-test +[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t assoc-answer ] unit-test +[ { { 1 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } f assoc-answer ] unit-test [ T{ condition f T{ primitive-class } { 1 2 } { 1 } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>condition ] unit-test SYMBOL: foo @@ -46,13 +46,13 @@ SYMBOL: bar [ T{ condition f T{ primitive-class f bar } T{ condition f T{ primitive-class f foo } { 1 3 2 } { 1 3 } } T{ condition f T{ primitive-class f foo } { 1 2 } { 1 } } } ] [ { { 1 t } { 3 T{ primitive-class f bar } } { 2 T{ primitive-class f foo } } } table>condition ] unit-test -[ t ] [ foo dup t replace-question ] unit-test -[ f ] [ foo dup f replace-question ] unit-test -[ T{ primitive-class f foo } ] [ foo bar t replace-question ] unit-test -[ T{ primitive-class f foo } ] [ foo bar f replace-question ] unit-test -[ T{ primitive-class f foo } ] [ foo bar 2array bar t replace-question ] unit-test -[ T{ primitive-class f bar } ] [ foo bar 2array foo t replace-question ] unit-test -[ f ] [ foo bar 2array foo f replace-question ] unit-test -[ f ] [ foo bar 2array bar f replace-question ] unit-test -[ t ] [ foo bar 2array bar t replace-question ] unit-test -[ T{ primitive-class f foo } ] [ foo bar 2array bar f replace-question ] unit-test +[ t ] [ foo dup t answer ] unit-test +[ f ] [ foo dup f answer ] unit-test +[ T{ primitive-class f foo } ] [ foo bar t answer ] unit-test +[ T{ primitive-class f foo } ] [ foo bar f answer ] unit-test +[ T{ primitive-class f foo } ] [ foo bar 2array bar t answer ] unit-test +[ T{ primitive-class f bar } ] [ foo bar 2array foo t answer ] unit-test +[ f ] [ foo bar 2array foo f answer ] unit-test +[ f ] [ foo bar 2array bar f answer ] unit-test +[ t ] [ foo bar 2array bar t answer ] unit-test +[ T{ primitive-class f foo } ] [ foo bar 2array bar f answer ] unit-test diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index 8912082ec3..4ddd470189 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -163,20 +163,32 @@ M: integer combine-or : try-combine ( elt1 elt2 quot -- combined/f ? ) 3dup call [ [ 3drop ] dip t ] [ drop swapd call ] if ; inline +DEFER: answer + +:: try-cancel ( elt1 elt2 empty -- combined/f ? ) + [ elt1 elt2 empty answer dup elt1 = not ] try-combine ; + :: prefix-combining ( seq elt quot: ( elt1 elt2 -- combined/f ? ) -- newseq ) f :> combined! - seq [ elt quot try-combine swap combined! ] find drop + seq [ elt quot call swap combined! ] find drop [ seq remove-nth combined prefix ] [ seq elt prefix ] if* ; inline +: combine-by ( seq quot -- new-seq ) + { } swap '[ _ prefix-combining ] reduce ; inline + +:: seq>instance ( seq empty class -- instance ) + seq length { + { 0 [ empty ] } + { 1 [ seq first ] } + [ drop class new seq >>seq ] + } case ; inline + :: combine ( seq quot: ( elt1 elt2 -- combined/f ? ) empty class -- newseq ) seq class flatten - { } [ quot prefix-combining ] reduce - dup length { - { 0 [ drop empty ] } - { 1 [ first ] } - [ drop class new swap >>seq ] - } case ; inline + [ quot try-combine ] combine-by + ! [ empty try-cancel ] combine-by ! This makes the algorithm O(n^4) + empty class seq>instance ; inline : ( seq -- class ) [ combine-and ] t and-class combine ; @@ -218,36 +230,36 @@ UNION: class primitive-class not-class or-class and-class range ; TUPLE: condition question yes no ; C: condition -GENERIC# replace-question 2 ( class from to -- new-class ) +GENERIC# answer 2 ( class from to -- new-class ) -M:: object replace-question ( class from to -- new-class ) +M:: object answer ( class from to -- new-class ) class from = to class ? ; : replace-compound ( class from to -- seq ) - [ seq>> ] 2dip '[ _ _ replace-question ] map ; + [ seq>> ] 2dip '[ _ _ answer ] map ; -M: and-class replace-question +M: and-class answer replace-compound ; -M: or-class replace-question +M: or-class answer replace-compound ; -M: not-class replace-question - [ class>> ] 2dip replace-question ; +M: not-class answer + [ class>> ] 2dip answer ; -: answer ( table question answer -- new-table ) - '[ _ _ replace-question ] assoc-map +: assoc-answer ( table question answer -- new-table ) + '[ _ _ answer ] assoc-map [ nip ] assoc-filter ; -: answers ( table questions answer -- new-table ) - '[ _ answer ] each ; +: assoc-answers ( table questions answer -- new-table ) + '[ _ assoc-answer ] each ; DEFER: make-condition : (make-condition) ( table questions question -- condition ) [ 2nip ] - [ swap [ t answer ] dip make-condition ] - [ swap [ f answer ] dip make-condition ] 3tri + [ swap [ t assoc-answer ] dip make-condition ] + [ swap [ f assoc-answer ] dip make-condition ] 3tri 2dup = [ 2nip ] [ ] if ; : make-condition ( table questions -- condition ) diff --git a/basis/regexp/combinators/combinators-tests.factor b/basis/regexp/combinators/combinators-tests.factor index 0ba2831842..ddfd0dcaad 100644 --- a/basis/regexp/combinators/combinators-tests.factor +++ b/basis/regexp/combinators/combinators-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: regexp.combinators tools.test regexp kernel sequences regexp.matchers ; +USING: regexp.combinators tools.test regexp kernel sequences ; IN: regexp.combinators.tests : strings ( -- regexp ) @@ -16,7 +16,7 @@ USE: multiline { R' .*a' R' b.*' } ; [ t ] [ "bljhasflsda" conj matches? ] unit-test -[ f ] [ "bsdfdfs" conj matches? ] unit-test ! why does this fail? +[ f ] [ "bsdfdfs" conj matches? ] unit-test [ f ] [ "fsfa" conj matches? ] unit-test [ f ] [ "bljhasflsda" conj matches? ] unit-test diff --git a/basis/regexp/compiler/compiler.factor b/basis/regexp/compiler/compiler.factor index 4e615d15d7..0e0c0eaae6 100644 --- a/basis/regexp/compiler/compiler.factor +++ b/basis/regexp/compiler/compiler.factor @@ -1,19 +1,19 @@ ! 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 +quotations assocs fry math locals combinators accessors words compiler.units kernel.private strings -sequences.private arrays regexp.matchers call namespaces +sequences.private arrays call namespaces regexp.transition-tables combinators.short-circuit ; IN: regexp.compiler GENERIC: question>quot ( question -- quot ) -quot drop [ 2drop t ] ; M: beginning-of-input question>quot @@ -64,7 +64,7 @@ C: box : non-literals>dispatch ( literals non-literals -- quot ) [ swap ] assoc-map ! we want state => predicate, and get the opposite as input - swap keys f answers + swap keys f assoc-answers table>condition [ ] condition-map condition>quot ; : literals>cases ( literal-transitions -- case-body ) @@ -106,13 +106,15 @@ C: box transitions>quot ; : states>code ( words dfa -- ) - '[ + [ ! with-compilation-unit doesn't compile, so we need call( -- ) [ - dup _ word>quot - (( last-match index string -- ? )) - define-declared - ] each - ] with-compilation-unit ; + '[ + dup _ word>quot + (( last-match index string -- ? )) + define-declared + ] each + ] with-compilation-unit + ] call( words dfa -- ) ; : states>words ( dfa -- words dfa ) dup transitions>> keys [ gensym ] H{ } map>assoc @@ -120,34 +122,23 @@ C: box [ values ] bi swap ; -: dfa>word ( dfa -- word ) +: dfa>main-word ( dfa -- word ) states>words [ states>code ] keep start-state>> ; -: check-string ( string -- string ) - ! Make this configurable - dup string? [ "String required" throw ] unless ; - -: setup-regexp ( start-index string -- f start-index string ) - [ f ] [ >fixnum ] [ check-string ] tri* ; inline - PRIVATE> -! The quotation returned is ( start-index string -- i/f ) +: simple-define-temp ( quot effect -- word ) + [ [ define-temp ] with-compilation-unit ] call( quot effect -- word ) ; -: dfa>quotation ( dfa -- quot ) - dfa>word execution-quot '[ setup-regexp @ ] ; +: dfa>word ( dfa -- quot ) + dfa>main-word execution-quot '[ drop [ f ] 2dip @ ] + (( start-index string regexp -- i/f )) simple-define-temp ; -: dfa>shortest-quotation ( dfa -- quot ) - t shortest? [ dfa>quotation ] with-variable ; +: dfa>shortest-word ( dfa -- word ) + t shortest? [ dfa>word ] with-variable ; -: dfa>reverse-quotation ( dfa -- quot ) - t backwards? [ dfa>quotation ] with-variable ; +: dfa>reverse-word ( dfa -- word ) + t backwards? [ dfa>word ] with-variable ; -: dfa>reverse-shortest-quotation ( dfa -- quot ) - t backwards? [ dfa>shortest-quotation ] with-variable ; - -TUPLE: quot-matcher quot ; -C: quot-matcher - -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 ; diff --git a/basis/regexp/negation/negation.factor b/basis/regexp/negation/negation.factor index 0633dca192..8b0a2f6edf 100644 --- a/basis/regexp/negation/negation.factor +++ b/basis/regexp/negation/negation.factor @@ -6,9 +6,6 @@ regexp.ast regexp.transition-tables regexp.minimize regexp.dfa namespaces ; IN: regexp.negation -: ast>dfa ( parse-tree -- minimal-dfa ) - construct-nfa disambiguate construct-dfa minimize ; - CONSTANT: fail-state -1 : add-default-transition ( state's-transitions -- new-state's-transitions ) @@ -49,5 +46,8 @@ CONSTANT: fail-state -1 [ final-states>> keys first ] [ nfa-table get [ transitions>> ] bi@ swap update ] tri ; +: ast>dfa ( parse-tree -- minimal-dfa ) + construct-nfa disambiguate construct-dfa minimize ; + M: negation nfa-node ( node -- start end ) term>> ast>dfa negate-table adjoin-dfa ; diff --git a/basis/regexp/regexp-docs.factor b/basis/regexp/regexp-docs.factor index d77abe877e..1d28e5e92f 100644 --- a/basis/regexp/regexp-docs.factor +++ b/basis/regexp/regexp-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel strings help.markup help.syntax regexp.matchers math ; +USING: kernel strings help.markup help.syntax math ; IN: regexp ABOUT: "regexp" @@ -39,13 +39,14 @@ ARTICLE: { "regexp" "theory" } "The theory of regular expressions" "The Factor regular expression engine was built with the design decision to support negation and intersection at the expense of backreferences. This lets us have a guaranteed linear-time matching algorithm. Systems like Ragel and Lex also use this algorithm, but in the Factor regular expression engine, all other features of regexps are still present." ; ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions" -{ $subsection all-matches } { $subsection matches? } +{ $subsection re-contains? } +{ $subsection first-match } +{ $subsection all-matches } { $subsection re-split1 } { $subsection re-split } { $subsection re-replace } -{ $subsection count-matches } -{ $subsection re-replace } ; +{ $subsection count-matches } ; HELP: { $values { "string" string } { "regexp" regexp } } @@ -63,25 +64,33 @@ HELP: regexp { $class-description "The class of regular expressions. To construct these, see " { $link { "regexp" "construction" } } "." } ; HELP: matches? -{ $values { "string" string } { "matcher" regexp } { "?" "a boolean" } } +{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } } { $description "Tests if the string as a whole matches the given regular expression." } ; HELP: re-split1 -{ $values { "string" string } { "matcher" regexp } { "before" string } { "after/f" string } } +{ $values { "string" string } { "regexp" regexp } { "before" string } { "after/f" string } } { $description "Searches the string for a substring which matches the pattern. If found, the input string is split on the leftmost and longest occurence of the match, and the two halves are given as output. If no match is found, then the input string and " { $link f } " are output." } ; HELP: all-matches -{ $values { "string" string } { "matcher" regexp } { "seq" "a sequence of slices of the input" } } +{ $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } } { $description "Finds a sequence of disjoint substrings which each match the pattern. It chooses this by finding the leftmost longest match, and then the leftmost longest match which starts after the end of the previous match, and so on." } ; HELP: count-matches -{ $values { "string" string } { "matcher" regexp } { "n" integer } } +{ $values { "string" string } { "regexp" regexp } { "n" integer } } { $description "Counts how many disjoint matches the regexp has in the string, as made unambiguous by " { $link all-matches } "." } ; HELP: re-split -{ $values { "string" string } { "matcher" regexp } { "seq" "a sequence of slices of the input" } } +{ $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } } { $description "Splits the input string into chunks separated by the regular expression. Each chunk contains no match of the regexp. The chunks are chosen by the strategy of " { $link all-matches } "." } ; HELP: re-replace -{ $values { "string" string } { "matcher" regexp } { "replacement" string } { "result" string } } +{ $values { "string" string } { "regexp" regexp } { "replacement" string } { "result" string } } { $description "Replaces substrings which match the input regexp with the given replacement text. The boundaries of the substring are chosen by the strategy used by " { $link all-matches } "." } ; + +HELP: first-match +{ $values { "string" string } { "regexp" regexp } { "slice/f" "the match, if one exists" } } +{ $description "Finds the first match of the regular expression in the string, and returns it as a slice. If there is no match, then " { $link f } " is returned." } ; + +HELP: re-contains? +{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } } +{ $description "Determines whether the string has a substring which matches the regular expression given." } ; diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 0a448ed276..f05416ab94 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -1,13 +1,12 @@ ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: regexp tools.test kernel sequences regexp.parser regexp.private -eval strings multiline accessors regexp.matchers ; +eval strings multiline accessors ; IN: regexp-tests \ must-infer -! the following don't compile because [ ] with-compilation-unit doesn't compile -! \ compile-regexp must-infer -! \ matches? must-infer +\ compile-regexp must-infer +\ matches? must-infer [ f ] [ "b" "a*" matches? ] unit-test [ t ] [ "" "a*" matches? ] unit-test @@ -212,8 +211,8 @@ IN: regexp-tests [ f ] [ "aaaxb" "a+ab" matches? ] unit-test [ t ] [ "aaacb" "a+cb" matches? ] unit-test -[ 3 ] [ "aaacb" "a*" match-index-head ] unit-test -[ 2 ] [ "aaacb" "aa?" match-index-head ] unit-test +[ "aaa" ] [ "aaacb" "a*" first-match >string ] unit-test +[ "aa" ] [ "aaacb" "aa?" first-match >string ] unit-test [ t ] [ "aaa" R/ AAA/i matches? ] unit-test [ f ] [ "aax" R/ AAA/i matches? ] unit-test @@ -240,11 +239,11 @@ IN: regexp-tests [ f ] [ "A" "\\p{Lower}" matches? ] unit-test [ t ] [ "A" R/ \p{Lower}/i matches? ] unit-test -[ t ] [ "abc" reverse R/ abc/r matches? ] unit-test -[ t ] [ "abc" reverse R/ a[bB][cC]/r matches? ] unit-test +[ t ] [ "abc" R/ abc/r matches? ] unit-test +[ t ] [ "abc" R/ a[bB][cC]/r matches? ] unit-test -[ t ] [ 3 "xabc" R/ abc/ match-index-from >boolean ] unit-test -[ t ] [ 3 "xabc" R/ a[bB][cC]/ match-index-from >boolean ] unit-test +[ t ] [ 3 "xabc" R/ abc/r match-index-from >boolean ] unit-test +[ t ] [ 3 "xabc" R/ a[bB][cC]/r match-index-from >boolean ] unit-test [ t ] [ "s@f" "[a-z.-]@[a-z]" matches? ] unit-test [ f ] [ "a" "[a-z.-]@[a-z]" matches? ] unit-test @@ -269,13 +268,13 @@ IN: regexp-tests [ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test -[ "ab" ] [ "ab" "(a|ab)(bc)?" match-head >string ] unit-test -[ "abc" ] [ "abc" "(a|ab)(bc)?" match-head >string ] unit-test +[ "ab" ] [ "ab" "(a|ab)(bc)?" first-match >string ] unit-test +[ "abc" ] [ "abc" "(a|ab)(bc)?" first-match >string ] unit-test -[ "ab" ] [ "ab" "(ab|a)(bc)?" match-head >string ] unit-test -[ "abc" ] [ "abc" "(ab|a)(bc)?" match-head >string ] unit-test +[ "ab" ] [ "ab" "(ab|a)(bc)?" first-match >string ] unit-test +[ "abc" ] [ "abc" "(ab|a)(bc)?" first-match >string ] unit-test -[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" match-head >string ] unit-test +[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" first-match >string ] unit-test [ { "1" "2" "3" "4" } ] [ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test @@ -301,18 +300,18 @@ IN: regexp-tests [ "-- title --" ] [ "== title ==" R/ =/ "-" re-replace ] unit-test -[ "" ] [ "ab" "a(?!b)" match-head >string ] unit-test -[ "a" ] [ "ac" "a(?!b)" match-head >string ] unit-test +[ "" ] [ "ab" "a(?!b)" first-match >string ] unit-test +[ "a" ] [ "ac" "a(?!b)" first-match >string ] unit-test [ t ] [ "fxxbar" ".{3}(?!foo)bar" matches? ] unit-test [ t ] [ "foobar" ".{3}(?!foo)bar" matches? ] unit-test [ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test [ f ] [ "foobar" "(?!foo).{3}bar" matches? ] unit-test -[ "a" ] [ "ab" "a(?=b)(?=b)" match-head >string ] unit-test -[ "a" ] [ "ba" "(?<=b)(?<=b)a" match-head >string ] unit-test -[ "a" ] [ "cab" "(?<=c)a(?=b)" match-head >string ] unit-test +[ "a" ] [ "ab" "a(?=b)(?=b)" first-match >string ] unit-test +[ "a" ] [ "ba" "(?<=b)(?<=b)a" first-match >string ] unit-test +[ "a" ] [ "cab" "(?<=c)a(?=b)" first-match >string ] unit-test -[ 3 ] [ "foobar" "foo(?=bar)" match-index-head ] unit-test -[ f ] [ "foobxr" "foo(?=bar)" match-index-head ] unit-test +[ 3 ] [ "foobar" "foo(?=bar)" first-match length ] unit-test +[ f ] [ "foobxr" "foo(?=bar)" first-match ] unit-test ! Bug in parsing word [ t ] [ "a" R' a' matches? ] unit-test @@ -342,9 +341,19 @@ IN: regexp-tests [ t ] [ "aaaa" R/ .*a./ matches? ] unit-test +[ f ] [ "ab" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test +[ f ] [ "ab" R/ (?~ac|[a-z]b)/ matches? ] unit-test +[ f ] [ "ac" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test +[ f ] [ "ac" R/ (?~ac|[a-z]b)/ matches? ] unit-test +[ f ] [ "ac" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test +[ f ] [ "ab" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test +[ f ] [ "πb" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test +[ t ] [ "πc" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test +[ t ] [ "Ab" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test + ! DFA is compiled when needed, or when literal -[ f ] [ "foo" dfa>> >boolean ] unit-test -[ t ] [ R/ foo/ dfa>> >boolean ] unit-test +[ regexp-initial-word ] [ "foo" dfa>> ] unit-test +[ f ] [ R/ foo/ dfa>> \ regexp-initial-word = ] unit-test [ t ] [ "a" R/ ^a/ matches? ] unit-test [ f ] [ "\na" R/ ^a/ matches? ] unit-test @@ -415,8 +424,12 @@ IN: regexp-tests [ 1 ] [ "a\r" R/ a$/m count-matches ] unit-test [ 1 ] [ "a\r\n" R/ a$/m count-matches ] unit-test -[ f ] [ "foobxr" "foo\\z" match-index-head ] unit-test -[ 3 ] [ "foo" "foo\\z" match-index-head ] unit-test +[ f ] [ "foobxr" "foo\\z" first-match ] unit-test +[ 3 ] [ "foo" "foo\\z" first-match length ] unit-test + +[ t ] [ "a foo b" R/ foo/ re-contains? ] unit-test +[ f ] [ "a bar b" R/ foo/ re-contains? ] unit-test +[ t ] [ "foo" R/ foo/ re-contains? ] unit-test ! [ t ] [ "foo" "\\bfoo\\b" matches? ] unit-test ! [ t ] [ "afoob" "\\Bfoo\\B" matches? ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index f938ddf60a..90218e05bd 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -2,71 +2,166 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators kernel math sequences strings sets assocs prettyprint.backend prettyprint.custom make lexer -namespaces parser arrays fry locals regexp.minimize -regexp.parser regexp.nfa regexp.dfa regexp.classes -regexp.transition-tables splitting sorting regexp.ast -regexp.negation regexp.matchers regexp.compiler ; +namespaces parser arrays fry locals regexp.parser splitting +sorting regexp.ast regexp.negation regexp.compiler words +call call.private math.ranges ; IN: regexp TUPLE: regexp { raw read-only } { parse-tree read-only } { options read-only } - dfa reverse-dfa ; + dfa next-match ; -: make-regexp ( string ast -- regexp ) - f f f f regexp boa ; foldable - ! Foldable because, when the dfa slot is set, - ! it'll be set to the same thing regardless of who sets it +TUPLE: reverse-regexp < regexp ; -: ( string options -- regexp ) - [ dup parse-regexp ] [ string>options ] bi* - f f regexp boa ; + ( string -- regexp ) "" ; +: maybe-negated ( lookaround quot -- regexp-quot ) + '[ term>> @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline -TUPLE: reverse-matcher regexp ; -C: reverse-matcher -! Reverse matchers won't work properly with most combinators, for now +M: lookahead question>quot ! Returns ( index string -- ? ) + [ ast>dfa dfa>shortest-word '[ f _ execute ] ] maybe-negated ; + +: ( ast -- reversed ) + "r" string>options ; + +M: lookbehind question>quot ! Returns ( index string -- ? ) + [ + + ast>dfa dfa>reverse-shortest-word + '[ [ 1- ] dip f _ execute ] + ] maybe-negated ; + +> execute( index string regexp -- i/f ) ; + +GENERIC: end/start ( string regexp -- end start ) +M: regexp end/start drop length 0 ; +M: reverse-regexp end/start drop length 1- -1 swap ; + +PRIVATE> + +: matches? ( string regexp -- ? ) + [ end/start ] 2keep + [ check-string ] dip + match-index-from + [ swap = ] [ drop f ] if* ; + + ] [ 2drop f ] if* ; inline + +: match-from ( i string quot -- slice/f ) + [ [ length [a,b) ] keep ] dip + '[ _ _ match-slice ] map-find drop ; inline + +: next-match ( i string quot -- i match/f ) + match-from [ dup [ to>> ] when ] keep ; inline + +: do-next-match ( i string regexp -- i match/f ) + dup next-match>> execute( i string regexp -- i match/f ) ; + +PRIVATE> + +: all-matches ( string regexp -- seq ) + [ check-string ] dip + [ 0 [ dup ] ] 2dip '[ _ _ do-next-match ] produce + nip but-last ; + +: count-matches ( string regexp -- n ) + all-matches length ; + +> ] map 0 prefix + slices [ from>> ] map string length suffix + [ string ] 2map ; + +PRIVATE> + +: first-match ( string regexp -- slice/f ) + [ 0 ] [ check-string ] [ ] tri* + do-next-match nip ; + +: re-contains? ( string regexp -- ? ) + first-match >boolean ; + +: re-split1 ( string regexp -- before after/f ) + dupd first-match [ 1array split-slices first2 ] [ f ] if* ; + +: re-split ( string regexp -- seq ) + dupd all-matches split-slices ; + +: re-replace ( string regexp replacement -- result ) + [ re-split ] dip join ; > ] [ options>> ] bi ; -: compile-regexp ( regexp -- regexp ) - dup '[ [ _ get-ast ast>dfa dfa>quotation ] unless* ] change-dfa ; +GENERIC: compile-regexp ( regex -- regexp ) -: ( ast -- reversed ) - "r" string>options ; +: regexp-initial-word ( i string regexp -- i/f ) + compile-regexp match-index-from ; -: maybe-negated ( lookaround quot -- regexp-quot ) - '[ term>> @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline - -M: lookahead question>quot ! Returns ( index string -- ? ) - [ ast>dfa dfa>shortest-quotation ] maybe-negated ; - -M: lookbehind question>quot ! Returns ( index string -- ? ) - [ - - ast>dfa dfa>reverse-shortest-quotation - [ [ 1- ] dip ] prepose - ] maybe-negated ; - -: compile-reverse ( regexp -- regexp ) +: do-compile-regexp ( regexp -- regexp ) dup '[ - [ - _ get-ast - ast>dfa dfa>reverse-quotation - ] unless* - ] change-reverse-dfa ; + dup \ regexp-initial-word = + [ drop _ get-ast ast>dfa dfa>word ] when + ] change-dfa ; -M: regexp match-index-from - compile-regexp dfa>> match-index-from ; +M: regexp compile-regexp ( regexp -- regexp ) + do-compile-regexp ; -M: reverse-matcher match-index-from - regexp>> compile-reverse reverse-dfa>> - match-index-from ; +M: reverse-regexp compile-regexp ( regexp -- regexp ) + t backwards? [ do-compile-regexp ] with-variable ; + +GENERIC: compile-next-match ( regexp -- regexp ) + +: next-initial-word ( i string regexp -- i slice/f ) + compile-next-match do-next-match ; + +M: regexp compile-next-match ( regexp -- regexp ) + dup '[ + dup \ next-initial-word = [ + drop _ compile-regexp dfa>> + '[ _ '[ _ _ execute ] next-match ] + (( i string -- i match/f )) simple-define-temp + ] when + ] change-next-match ; + +! Write M: reverse-regexp compile-next-match + +PRIVATE> + +: new-regexp ( string ast options class -- regexp ) + [ \ regexp-initial-word \ next-initial-word ] dip boa ; inline + +: make-regexp ( string ast -- regexp ) + f f regexp new-regexp ; + +: ( string options -- regexp ) + [ dup parse-regexp ] [ string>options ] bi* + dup on>> reversed-regexp swap member? + [ reverse-regexp new-regexp ] + [ regexp new-regexp ] if ; + +: ( string -- regexp ) "" ; + + compile-regexp parsed ; + compile-next-match parsed ; PRIVATE> @@ -120,3 +215,4 @@ M: regexp pprint* [ options>> options>string % ] bi ] "" make ] keep present-text ; + diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index 740cf7db13..f0ee13dd38 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel continuations sequences math namespaces make sets -math.parser math.ranges assocs regexp regexp.matchers unicode.categories arrays +math.parser math.ranges assocs regexp unicode.categories arrays hashtables words classes quotations xmode.catalog unicode.case ; IN: validators diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index de1f4254ea..d3ad266b5d 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: xmode.marker USING: kernel namespaces make xmode.rules xmode.tokens xmode.marker.state xmode.marker.context xmode.utilities xmode.catalog sequences math assocs combinators strings -regexp splitting ascii unicode.case regexp.matchers -ascii combinators.short-circuit accessors ; +regexp splitting unicode.case +combinators.short-circuit accessors ; +IN: xmode.marker ! Next two words copied from parser-combinators ! Just like head?, but they optionally ignore case diff --git a/extra/benchmark/regex-dna/regex-dna.factor b/extra/benchmark/regex-dna/regex-dna.factor index 29cb0b7357..5c11be357f 100644 --- a/extra/benchmark/regex-dna/regex-dna.factor +++ b/extra/benchmark/regex-dna/regex-dna.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors regexp.matchers prettyprint io io.encodings.ascii +USING: accessors prettyprint io io.encodings.ascii io.files kernel sequences assocs namespaces regexp ; IN: benchmark.regex-dna