steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-03-09 15:25:41 -05:00
parent c2d3b5ae1f 5cd1c8db52
commit 9a531a32ea
41 changed files with 1750 additions and 1320 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/ascii/ascii.factor
View File

@ -10,7 +10,7 @@ IN: ascii
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline
: control? ( ch -- ? ) { [ 0 HEX: 1F between? ] [ HEX: 7F = ] } 1|| ; inline
: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
@ -20,4 +20,4 @@ IN: ascii
: >upper ( str -- upper ) [ ch>upper ] map ;
HINTS: >lower string ;
HINTS: >upper string ;
HINTS: >upper string ;

3
basis/globs/globs-tests.factor
View File

@ -14,5 +14,6 @@ USING: tools.test globs ;
[ f ] [ "foo.java" "*.{xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.txt" "*.{xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.xml" "*.{xml,txt}" glob-matches? ] unit-test
[ f ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
[ f ] [ "foo." "*.{xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.{" "*.{" glob-matches? ] unit-test

54
basis/globs/globs.factor
View File

@ -1,42 +1,42 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: parser-combinators parser-combinators.regexp lists sequences kernel
promises strings unicode.case ;
USING: sequences kernel regexp.combinators regexp.matchers strings unicode.case
peg.ebnf regexp arrays ;
IN: globs
<PRIVATE
EBNF: <glob>
: 'char' ( -- parser )
[ ",*?" member? not ] satisfy ;
Character = "\\" .:c => [[ c 1string <literal> ]]
| !(","|"}") . => [[ 1string <literal> ]]
: 'string' ( -- parser )
'char' <+> [ >lower token ] <@ ;
RangeCharacter = !("]") .
: 'escaped-char' ( -- parser )
"\\" token any-char-parser &> [ 1token ] <@ ;
Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b <char-range> ]]
| RangeCharacter => [[ 1string <literal> ]]
: 'escaped-string' ( -- parser )
'string' 'escaped-char' <|> ;
StartRange = .:a "-" RangeCharacter:b => [[ a b <char-range> ]]
| . => [[ 1string <literal> ]]
DEFER: 'term'
Ranges = StartRange:s Range*:r => [[ r s prefix ]]
: 'glob' ( -- parser )
'term' <*> [ <and-parser> ] <@ ;
CharClass = "^"?:n Ranges:e => [[ e <or> n [ <not> ] when ]]
: 'union' ( -- parser )
'glob' "," token nonempty-list-of "{" "}" surrounded-by
[ <or-parser> ] <@ ;
AlternationBody = Concatenation:c "," AlternationBody:a => [[ a c prefix ]]
| Concatenation => [[ 1array ]]
LAZY: 'term' ( -- parser )
'union'
'character-class' <|>
"?" token [ drop any-char-parser ] <@ <|>
"*" token [ drop any-char-parser <*> ] <@ <|>
'escaped-string' <|> ;
Element = "*" => [[ R/ .*/ ]]
| "?" => [[ R/ ./ ]]
| "[" CharClass:c "]" => [[ c ]]
| "{" AlternationBody:b "}" => [[ b <or> ]]
| Character
PRIVATE>
Concatenation = Element* => [[ <sequence> ]]
: <glob> ( string -- glob ) 'glob' just parse-1 just ;
End = !(.)
Main = Concatenation End
;EBNF
: glob-matches? ( input glob -- ? )
[ >lower ] [ <glob> ] bi* parse nil? not ;
[ >case-fold ] bi@ <glob> matches? ;

65
basis/regexp/ast/ast.factor Normal file
View File

@ -0,0 +1,65 @@
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays accessors fry sequences regexp.classes ;
FROM: math.ranges => [a,b] ;
IN: regexp.ast
TUPLE: negation term ;
C: <negation> negation
TUPLE: from-to n m ;
C: <from-to> from-to
TUPLE: at-least n ;
C: <at-least> at-least
TUPLE: tagged-epsilon tag ;
C: <tagged-epsilon> tagged-epsilon
CONSTANT: epsilon T{ tagged-epsilon { tag t } }
TUPLE: concatenation first second ;
: <concatenation> ( seq -- concatenation )
[ epsilon ] [ unclip [ concatenation boa ] reduce ] if-empty ;
TUPLE: alternation first second ;
: <alternation> ( seq -- alternation )
unclip [ alternation boa ] reduce ;
TUPLE: star term ;
C: <star> star
TUPLE: with-options tree options ;
C: <with-options> with-options
TUPLE: options on off ;
C: <options> options
SINGLETONS: unix-lines dotall multiline comments case-insensitive
unicode-case reversed-regexp ;
: <maybe> ( term -- term' )
f <concatenation> 2array <alternation> ;
: <plus> ( term -- term' )
dup <star> 2array <concatenation> ;
: repetition ( n term -- term' )
<array> <concatenation> ;
GENERIC: <times> ( term times -- term' )
M: at-least <times>
n>> swap [ repetition ] [ <star> ] bi 2array <concatenation> ;
M: from-to <times>
[ n>> ] [ m>> ] bi [a,b] swap '[ _ repetition ] map <alternation> ;
: char-class ( ranges ? -- term )
[ <or-class> ] dip [ <not-class> ] when ;
TUPLE: lookahead term positive? ;
C: <lookahead> lookahead
TUPLE: lookbehind term positive? ;
C: <lookbehind> lookbehind

27
basis/regexp/backend/backend.factor
View File

@ -1,27 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors hashtables kernel math vectors ;
IN: regexp.backend
TUPLE: regexp
raw
{ options hashtable }
stack
parse-tree
nfa-table
dfa-table
minimized-table
matchers
{ nfa-traversal-flags hashtable }
{ dfa-traversal-flags hashtable }
{ state integer }
{ new-states vector }
{ visited-states hashtable } ;
: reset-regexp ( regexp -- regexp )
0 >>state
V{ } clone >>stack
V{ } clone >>new-states
H{ } clone >>visited-states ;
SYMBOL: current-regexp

58
basis/regexp/classes/classes-tests.factor Normal file
View File

@ -0,0 +1,58 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: regexp.classes tools.test arrays kernel ;
IN: regexp.classes.tests
! Class algebra
[ f ] [ { 1 2 } <and-class> ] unit-test
[ T{ or-class f { 2 1 } } ] [ { 1 2 } <or-class> ] unit-test
[ 3 ] [ { 1 2 } <and-class> 3 2array <or-class> ] unit-test
[ CHAR: A ] [ CHAR: A LETTER-class <primitive-class> 2array <and-class> ] unit-test
[ CHAR: A ] [ LETTER-class <primitive-class> CHAR: A 2array <and-class> ] unit-test
[ T{ primitive-class { class LETTER-class } } ] [ CHAR: A LETTER-class <primitive-class> 2array <or-class> ] unit-test
[ T{ primitive-class { class LETTER-class } } ] [ LETTER-class <primitive-class> CHAR: A 2array <or-class> ] unit-test
[ t ] [ { t 1 } <or-class> ] unit-test
[ t ] [ { 1 t } <or-class> ] unit-test
[ f ] [ { f 1 } <and-class> ] unit-test
[ f ] [ { 1 f } <and-class> ] unit-test
[ 1 ] [ { f 1 } <or-class> ] unit-test
[ 1 ] [ { 1 f } <or-class> ] unit-test
[ 1 ] [ { t 1 } <and-class> ] unit-test
[ 1 ] [ { 1 t } <and-class> ] unit-test
[ 1 ] [ 1 <not-class> <not-class> ] unit-test
[ 1 ] [ { 1 1 } <and-class> ] unit-test
[ 1 ] [ { 1 1 } <or-class> ] unit-test
[ t ] [ { t t } <or-class> ] unit-test
[ T{ primitive-class { class letter-class } } ] [ letter-class <primitive-class> dup 2array <and-class> ] unit-test
[ T{ primitive-class { class letter-class } } ] [ letter-class <primitive-class> dup 2array <or-class> ] unit-test
[ T{ or-class { seq { 2 3 1 } } } ] [ { 1 2 } <or-class> { 2 3 } <or-class> 2array <or-class> ] unit-test
[ T{ or-class { seq { 3 2 } } } ] [ { 2 3 } <or-class> 1 <not-class> 2array <and-class> ] unit-test
[ f ] [ t <not-class> ] unit-test
[ t ] [ f <not-class> ] unit-test
[ f ] [ 1 <not-class> 1 t replace-question ] 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
[ T{ condition f T{ primitive-class } { 1 2 } { 1 } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>condition ] unit-test
SYMBOL: foo
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 <primitive-class> dup t replace-question ] unit-test
[ f ] [ foo <primitive-class> dup f replace-question ] unit-test
[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> t replace-question ] unit-test
[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> f replace-question ] unit-test
[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> t replace-question ] unit-test
[ T{ primitive-class f bar } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> t replace-question ] unit-test
[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> f replace-question ] unit-test
[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> f replace-question ] unit-test
[ t ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> t replace-question ] unit-test
[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> f replace-question ] unit-test

236
basis/regexp/classes/classes.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.order words regexp.utils
unicode.categories combinators.short-circuit ;
USING: accessors kernel math math.order words combinators locals
ascii unicode.categories combinators.short-circuit sequences
fry macros arrays assocs sets classes ;
IN: regexp.classes
SINGLETONS: any-char any-char-no-nl
@ -11,19 +12,18 @@ ascii-class punctuation-class java-printable-class blank-class
control-character-class hex-digit-class java-blank-class c-identifier-class
unmatchable-class terminator-class word-boundary-class ;
SINGLETONS: beginning-of-input beginning-of-line
end-of-input end-of-line ;
SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file ;
MIXIN: node
TUPLE: character-class-range from to ; INSTANCE: character-class-range node
TUPLE: range from to ;
C: <range> range
GENERIC: class-member? ( obj class -- ? )
M: t class-member? ( obj class -- ? ) 2drop f ;
M: t class-member? ( obj class -- ? ) 2drop t ;
M: integer class-member? ( obj class -- ? ) 2drop f ;
M: integer class-member? ( obj class -- ? ) = ;
M: character-class-range class-member? ( obj class -- ? )
M: range class-member? ( obj class -- ? )
[ from>> ] [ to>> ] bi between? ;
M: any-char class-member? ( obj class -- ? )
@ -47,16 +47,24 @@ M: ascii-class class-member? ( obj class -- ? )
M: digit-class class-member? ( obj class -- ? )
drop digit? ;
: c-identifier-char? ( ch -- ? )
{ [ alpha? ] [ CHAR: _ = ] } 1|| ;
M: c-identifier-class class-member? ( obj class -- ? )
drop
{ [ digit? ] [ Letter? ] [ CHAR: _ = ] } 1|| ;
drop c-identifier-char? ;
M: alpha-class class-member? ( obj class -- ? )
drop alpha? ;
: punct? ( ch -- ? )
"!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
M: punctuation-class class-member? ( obj class -- ? )
drop punct? ;
: java-printable? ( ch -- ? )
{ [ alpha? ] [ punct? ] } 1|| ;
M: java-printable-class class-member? ( obj class -- ? )
drop java-printable? ;
@ -64,11 +72,24 @@ M: non-newline-blank-class class-member? ( obj class -- ? )
drop { [ blank? ] [ CHAR: \n = not ] } 1&& ;
M: control-character-class class-member? ( obj class -- ? )
drop control-char? ;
drop control? ;
: hex-digit? ( ch -- ? )
{
[ CHAR: A CHAR: F between? ]
[ CHAR: a CHAR: f between? ]
[ CHAR: 0 CHAR: 9 between? ]
} 1|| ;
M: hex-digit-class class-member? ( obj class -- ? )
drop hex-digit? ;
: java-blank? ( ch -- ? )
{
CHAR: \s CHAR: \t CHAR: \n
HEX: b HEX: 7 CHAR: \r
} member? ;
M: java-blank-class class-member? ( obj class -- ? )
drop java-blank? ;
@ -76,16 +97,187 @@ M: unmatchable-class class-member? ( obj class -- ? )
2drop f ;
M: terminator-class class-member? ( obj class -- ? )
drop {
[ CHAR: \r = ]
[ CHAR: \n = ]
[ CHAR: \u000085 = ]
[ CHAR: \u002028 = ]
[ CHAR: \u002029 = ]
} 1|| ;
drop "\r\n\u000085\u002029\u002028" member? ;
M: beginning-of-line class-member? ( obj class -- ? )
M: ^ class-member? ( obj class -- ? )
2drop f ;
M: end-of-line class-member? ( obj class -- ? )
M: $ class-member? ( obj class -- ? )
2drop f ;
M: f class-member? 2drop f ;
TUPLE: primitive-class class ;
C: <primitive-class> primitive-class
TUPLE: or-class seq ;
TUPLE: not-class class ;
TUPLE: and-class seq ;
GENERIC: combine-and ( class1 class2 -- combined ? )
: replace-if-= ( object object -- object ? )
over = ;
M: object combine-and replace-if-= ;
M: t combine-and
drop t ;
M: f combine-and
nip t ;
M: not-class combine-and
class>> 2dup = [ 2drop f t ] [
dup integer? [
2dup swap class-member?
[ 2drop f f ]
[ drop t ] if
] [ 2drop f f ] if
] if ;
M: integer combine-and
swap 2dup class-member? [ drop t ] [ 2drop f t ] if ;
GENERIC: combine-or ( class1 class2 -- combined ? )
M: object combine-or replace-if-= ;
M: t combine-or
nip t ;
M: f combine-or
drop t ;
M: not-class combine-or
class>> = [ t t ] [ f f ] if ;
M: integer combine-or
2dup swap class-member? [ drop t ] [ 2drop f f ] if ;
: flatten ( seq class -- newseq )
'[ dup _ instance? [ seq>> ] [ 1array ] if ] map concat ; inline
: try-combine ( elt1 elt2 quot -- combined/f ? )
3dup call [ [ 3drop ] dip t ] [ drop swapd call ] if ; inline
:: prefix-combining ( seq elt quot: ( elt1 elt2 -- combined/f ? ) -- newseq )
f :> combined!
seq [ elt quot try-combine swap combined! ] find drop
[ seq remove-nth combined prefix ]
[ seq elt prefix ] if* ; 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
: <and-class> ( seq -- class )
[ combine-and ] t and-class combine ;
M: and-class class-member?
seq>> [ class-member? ] with all? ;
: <or-class> ( seq -- class )
[ combine-or ] f or-class combine ;
M: or-class class-member?
seq>> [ class-member? ] with any? ;
GENERIC: <not-class> ( class -- inverse )
M: object <not-class>
not-class boa ;
M: not-class <not-class>
class>> ;
M: and-class <not-class>
seq>> [ <not-class> ] map <or-class> ;
M: or-class <not-class>
seq>> [ <not-class> ] map <and-class> ;
M: t <not-class> drop f ;
M: f <not-class> drop t ;
M: not-class class-member?
class>> class-member? not ;
M: primitive-class class-member?
class>> class-member? ;
UNION: class primitive-class not-class or-class and-class range ;
TUPLE: condition question yes no ;
C: <condition> condition
GENERIC# replace-question 2 ( class from to -- new-class )
M:: object replace-question ( class from to -- new-class )
class from = to class ? ;
: replace-compound ( class from to -- seq )
[ seq>> ] 2dip '[ _ _ replace-question ] map ;
M: and-class replace-question
replace-compound <and-class> ;
M: or-class replace-question
replace-compound <or-class> ;
M: not-class replace-question
[ class>> ] 2dip replace-question <not-class> ;
: answer ( table question answer -- new-table )
'[ _ _ replace-question ] assoc-map
[ nip ] assoc-filter ;
: answers ( table questions answer -- new-table )
'[ _ 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
2dup = [ 2nip ] [ <condition> ] if ;
: make-condition ( table questions -- condition )
[ keys ] [ unclip (make-condition) ] if-empty ;
GENERIC: class>questions ( class -- questions )
: compound-questions ( class -- questions ) seq>> [ class>questions ] gather ;
M: or-class class>questions compound-questions ;
M: and-class class>questions compound-questions ;
M: not-class class>questions class>> class>questions ;
M: object class>questions 1array ;
: table>questions ( table -- questions )
values [ class>questions ] gather >array t swap remove ;
: table>condition ( table -- condition )
! input table is state => class
>alist dup table>questions make-condition ;
: condition-map ( condition quot: ( obj -- obj' ) -- new-condition )
over condition? [
[ [ question>> ] [ yes>> ] [ no>> ] tri ] dip
'[ _ condition-map ] bi@ <condition>
] [ call ] if ; inline recursive
: condition-states ( condition -- states )
dup condition? [
[ yes>> ] [ no>> ] bi
[ condition-states ] bi@ append prune
] [ 1array ] if ;
: condition-at ( condition assoc -- new-condition )
'[ _ at ] condition-map ;

1
basis/regexp/combinators/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

54
basis/regexp/combinators/combinators-docs.factor Normal file
View File

@ -0,0 +1,54 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup regexp strings ;
IN: regexp.combinators
ABOUT: "regexp.combinators"
ARTICLE: "regexp.combinators" "Regular expression combinators"
"The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This is in addition to the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary."
{ $subsection <literal> }
{ $subsection <nothing> }
{ $subsection <or> }
{ $subsection <and> }
{ $subsection <not> }
{ $subsection <sequence> }
{ $subsection <zero-or-more> }
{ $subsection <one-or-more> }
{ $subsection <option> } ;
HELP: <literal>
{ $values { "string" string } { "regexp" regexp } }
{ $description "Creates a regular expression which matches the given literal string." } ;
HELP: <nothing>
{ $values { "value" regexp } }
{ $description "The empty regular language." } ;
HELP: <or>
{ $values { "regexps" "a sequence of regular expressions" } { "disjunction" regexp } }
{ $description "Creates a new regular expression which matches the union of what elements of the sequence match." } ;
HELP: <and>
{ $values { "regexps" "a sequence of regular expressions" } { "conjunction" regexp } }
{ $description "Creates a new regular expression which matches the intersection of what elements of the sequence match." } ;
HELP: <sequence>
{ $values { "regexps" "a sequence of regular expressions" } { "regexp" regexp } }
{ $description "Creates a new regular expression which matches strings that match each element of the sequence in order." } ;
HELP: <not>
{ $values { "regexp" regexp } { "not-regexp" regexp } }
{ $description "Creates a new regular expression which matches everything that the given regexp does not match." } ;
HELP: <one-or-more>
{ $values { "regexp" regexp } { "regexp+" regexp } }
{ $description "Creates a new regular expression which matches one or more copies of the given regexp." } ;
HELP: <option>
{ $values { "regexp" regexp } { "regexp?" regexp } }
{ $description "Creates a new regular expression which matches zero or one copies of the given regexp." } ;
HELP: <zero-or-more>
{ $values { "regexp" regexp } { "regexp*" regexp } }
{ $description "Creates a new regular expression which matches zero or more copies of the given regexp." } ;

32
basis/regexp/combinators/combinators-tests.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: regexp.combinators tools.test regexp kernel sequences regexp.matchers ;
IN: regexp.combinators.tests
: strings ( -- regexp )
{ "foo" "bar" "baz" } <any-of> ;
[ t t t ] [ "foo" "bar" "baz" [ strings matches? ] tri@ ] unit-test
[ f f f ] [ "food" "ibar" "ba" [ strings matches? ] tri@ ] unit-test
USE: multiline
/*
! Why is conjuction broken?
: conj ( -- regexp )
{ R' .*a' R' b.*' } <and> ;
[ t ] [ "bljhasflsda" conj matches? ] unit-test
[ f ] [ "bsdfdfs" conj matches? ] unit-test ! why does this fail?
[ f ] [ "fsfa" conj matches? ] unit-test
[ f ] [ "bljhasflsda" conj <not> matches? ] unit-test
[ t ] [ "bsdfdfs" conj <not> matches? ] unit-test
[ t ] [ "fsfa" conj <not> matches? ] unit-test
*/
[ f f ] [ "" "hi" [ <nothing> matches? ] bi@ ] unit-test
[ t t ] [ "" "hi" [ <nothing> <not> matches? ] bi@ ] unit-test
[ { t t t f } ] [ { "" "a" "aaaaa" "aab" } [ "a" <literal> <zero-or-more> matches? ] map ] unit-test
[ { f t t f } ] [ { "" "a" "aaaaa" "aab" } [ "a" <literal> <one-or-more> matches? ] map ] unit-test
[ { t t f f } ] [ { "" "a" "aaaaa" "aab" } [ "a" <literal> <option> matches? ] map ] unit-test

56
basis/regexp/combinators/combinators.factor Normal file
View File

@ -0,0 +1,56 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: regexp sequences kernel regexp.negation regexp.ast
accessors fry regexp.classes ;
IN: regexp.combinators
<PRIVATE
: modify-regexp ( regexp raw-quot tree-quot -- new-regexp )
[ '[ raw>> @ ] ]
[ '[ parse-tree>> @ ] ] bi* bi
make-regexp ; inline
PRIVATE>
CONSTANT: <nothing> R/ (?~.*)/
: <literal> ( string -- regexp )
[ "\\Q" "\\E" surround ] [ <concatenation> ] bi make-regexp ; foldable
: <char-range> ( char1 char2 -- regexp )
[ [ "[" "-" surround ] [ "]" append ] bi* append ]
[ <range> ]
2bi make-regexp ;
: <or> ( regexps -- disjunction )
[ [ raw>> "(" ")" surround ] map "|" join ]
[ [ parse-tree>> ] map <alternation> ] bi
make-regexp ; foldable
: <any-of> ( strings -- regexp )
[ <literal> ] map <or> ; foldable
: <sequence> ( regexps -- regexp )
[ [ raw>> ] map concat ]
[ [ parse-tree>> ] map <concatenation> ] bi
make-regexp ; foldable
: <not> ( regexp -- not-regexp )
[ "(?~" ")" surround ]
[ <negation> ] modify-regexp ; foldable
: <and> ( regexps -- conjunction )
[ <not> ] map <or> <not> ; foldable
: <zero-or-more> ( regexp -- regexp* )
[ "(" ")*" surround ]
[ <star> ] modify-regexp ; foldable
: <one-or-more> ( regexp -- regexp+ )
[ "(" ")+" surround ]
[ <plus> ] modify-regexp ; foldable
: <option> ( regexp -- regexp? )
[ "(" ")?" surround ]
[ <maybe> ] modify-regexp ; foldable

1
basis/regexp/combinators/summary.txt Normal file
View File

@ -0,0 +1 @@
Combinators for creating regular expressions

1
basis/regexp/combinators/tags.txt Normal file
View File

@ -0,0 +1 @@
parsing

153
basis/regexp/compiler/compiler.factor Normal file
View File

@ -0,0 +1,153 @@
! 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 namespaces
regexp.transition-tables combinators.short-circuit ;
IN: regexp.compiler
GENERIC: question>quot ( question -- quot )
<PRIVATE
SYMBOL: shortest?
SYMBOL: backwards?
M: t question>quot drop [ 2drop t ] ;
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: $ question>quot
drop [ { [ length = ] [ ?nth "\r\n" member? ] } 2|| ] ;
M: ^ question>quot
drop [ { [ drop zero? ] [ [ 1- ] dip ?nth "\r\n" member? ] } 2|| ] ;
: (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 ]
] [ '[ _ execute ] ] 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 answers
table>condition [ <box> ] condition-map condition>quot ;
: literals>cases ( literal-transitions -- case-body )
[ execution-quot ] assoc-map ;
: expand-one-or ( or-class transition -- alist )
[ seq>> ] dip '[ _ 2array ] map ;
: expand-or ( alist -- new-alist )
[
first2 over or-class?
[ expand-one-or ] [ 2array 1array ] if
] map concat ;
: split-literals ( transitions -- case default )
>alist expand-or [ first integer? ] partition
[ [ literals>cases ] keep ] dip non-literals>dispatch ;
:: step ( last-match index str quot final? direction -- last-index/f )
final? index last-match ?
index str bounds-check? [
index direction + str
index str nth-unsafe
quot call
] when ; inline
: direction ( -- n )
backwards? get -1 1 ? ;
: transitions>quot ( transitions final-state? -- quot )
dup shortest? get and [ 2drop [ drop nip ] ] [
[ split-literals swap case>quot ] dip direction
'[ { array-capacity string } declare _ _ _ step ]
] if ;
: word>quot ( word dfa -- quot )
[ transitions>> at ]
[ final-states>> key? ] 2bi
transitions>quot ;
: states>code ( words dfa -- )
'[
[
dup _ word>quot
(( last-match index string -- ? ))
define-declared
] each
] with-compilation-unit ;
: states>words ( dfa -- words dfa )
dup transitions>> keys [ gensym ] H{ } map>assoc
[ transitions-at ]
[ values ]
bi swap ;
: dfa>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 )
: dfa>quotation ( dfa -- quot )
dfa>word execution-quot '[ setup-regexp @ ] ;
: dfa>shortest-quotation ( dfa -- quot )
t shortest? [ dfa>quotation ] with-variable ;
: dfa>reverse-quotation ( dfa -- quot )
t backwards? [ dfa>quotation ] with-variable ;
: dfa>reverse-shortest-quotation ( dfa -- quot )
t backwards? [ dfa>shortest-quotation ] with-variable ;
TUPLE: quot-matcher quot ;
C: <quot-matcher> quot-matcher
M: quot-matcher match-index-from
quot>> call( index string -- i/f ) ;

3
basis/regexp/dfa/dfa-tests.factor Normal file
View File

@ -0,0 +1,3 @@
USING: regexp.dfa tools.test ;
IN: regexp.dfa.tests

134
basis/regexp/dfa/dfa.factor
View File

@ -1,84 +1,84 @@
! Copyright (C) 2008 Doug Coleman.
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry kernel locals
math math.order regexp.nfa regexp.transition-tables sequences
sets sorting vectors regexp.utils sequences.deep ;
USING: io prettyprint threads ;
sets sorting vectors regexp.ast regexp.classes ;
IN: regexp.dfa
: find-delta ( states transition regexp -- new-states )
nfa-table>> transitions>>
rot [ swap at at ] with with gather sift ;
: find-delta ( states transition nfa -- new-states )
transitions>> '[ _ swap _ at at ] gather sift ;
: (find-epsilon-closure) ( states regexp -- new-states )
eps swap find-delta ;
:: epsilon-loop ( state table nfa question -- )
state table at :> old-value
old-value question 2array <or-class> :> new-question
new-question old-value = [
new-question state table set-at
state nfa transitions>> at
[ drop tagged-epsilon? ] assoc-filter
[| trans to |
to [
table nfa
trans tag>> new-question 2array <and-class>
epsilon-loop
] each
] assoc-each
] unless ;
: find-epsilon-closure ( states regexp -- new-states )
'[ dup _ (find-epsilon-closure) union ] [ length ] while-changes
natural-sort ;
: epsilon-table ( states nfa -- table )
[ H{ } clone tuck ] dip
'[ _ _ t epsilon-loop ] each ;
: find-closure ( states transition regexp -- new-states )
[ find-delta ] 2keep nip find-epsilon-closure ;
: find-epsilon-closure ( states nfa -- dfa-state )
epsilon-table table>condition ;
: find-start-state ( regexp -- state )
[ nfa-table>> start-state>> 1vector ] keep find-epsilon-closure ;
: find-closure ( states transition nfa -- new-states )
[ find-delta ] keep find-epsilon-closure ;
: find-transitions ( seq1 regexp -- seq2 )
nfa-table>> transitions>>
[ at keys ] curry gather
eps swap remove ;
: find-start-state ( nfa -- state )
[ start-state>> 1array ] keep find-epsilon-closure ;
: add-todo-state ( state regexp -- )
2dup visited-states>> key? [
2drop
] [
[ visited-states>> conjoin ]
[ new-states>> push ] 2bi
: find-transitions ( dfa-state nfa -- next-dfa-state )
transitions>>
'[ _ at keys [ condition-states ] map concat ] gather
[ tagged-epsilon? not ] filter ;
: add-todo-state ( state visited-states new-states -- )
3dup drop key? [ 3drop ] [
[ conjoin ] [ push ] bi-curry* bi
] if ;
: new-transitions ( regexp -- )
dup new-states>> [
drop
] [
dupd pop dup pick find-transitions rot
[
[ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep
[ swapd transition make-transition ] dip
dfa-table>> add-transition
] curry with each
new-transitions
: add-todo-states ( state/condition visited-states new-states -- )
[ condition-states ] 2dip
'[ _ _ add-todo-state ] each ;
:: new-transitions ( nfa dfa new-states visited-states -- nfa dfa )
new-states [ nfa dfa ] [
pop :> state
state dfa transitions>> maybe-initialize-key
state nfa find-transitions
[| trans |
state trans nfa find-closure :> new-state
new-state visited-states new-states add-todo-states
state new-state trans dfa set-transition
] each
nfa dfa new-states visited-states new-transitions
] if-empty ;
: states ( hashtable -- array )
[ keys ]
[ values [ values concat ] map concat append ] bi ;
: set-final-states ( nfa dfa -- )
[
[ final-states>> keys ]
[ transitions>> keys ] bi*
[ intersects? ] with filter
unique
] keep (>>final-states) ;
: set-final-states ( regexp -- )
dup
[ nfa-table>> final-states>> keys ]
[ dfa-table>> transitions>> states ] bi
[ intersects? ] with filter
: initialize-dfa ( nfa -- dfa )
<transition-table>
swap find-start-state >>start-state ;
swap dfa-table>> final-states>>
[ conjoin ] curry each ;
: set-initial-state ( regexp -- )
dup
[ dfa-table>> ] [ find-start-state ] bi
[ >>start-state drop ] keep
1vector >>new-states drop ;
: set-traversal-flags ( regexp -- )
dup
[ nfa-traversal-flags>> ]
[ dfa-table>> transitions>> keys ] bi
[ [ nip ] [ [ swap at ] with map concat ] 2bi ] with H{ } map>assoc
>>dfa-traversal-flags drop ;
: construct-dfa ( regexp -- )
{
[ set-initial-state ]
[ new-transitions ]
[ set-final-states ]
[ set-traversal-flags ]
} cleave ;
: construct-dfa ( nfa -- dfa )
dup initialize-dfa
dup start-state>> condition-states >vector
H{ } clone
new-transitions
[ set-final-states ] keep ;

44
basis/regexp/disambiguate/disambiguate.factor Normal file
View File

@ -0,0 +1,44 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors regexp.classes math.bits assocs sequences
arrays sets regexp.dfa math fry regexp.minimize regexp.ast ;
IN: regexp.disambiguate
TUPLE: parts in out ;
: make-partition ( choices classes -- partition )
zip [ first ] partition [ values ] bi@ parts boa ;
: powerset-partition ( classes -- partitions )
[ length [ 2^ ] keep ] keep '[
_ <bits> _ make-partition
] map rest ;
: partition>class ( parts -- class )
[ out>> [ <not-class> ] map ]
[ in>> <and-class> ] bi
prefix <and-class> ;
: get-transitions ( partition state-transitions -- next-states )
[ in>> ] dip '[ _ at ] gather sift ;
: new-transitions ( transitions -- assoc ) ! assoc is class, partition
values [ keys ] gather
[ tagged-epsilon? not ] filter
powerset-partition
[ [ partition>class ] keep ] { } map>assoc
[ drop ] assoc-filter ;
: preserving-epsilon ( state-transitions quot -- new-state-transitions )
[ [ drop tagged-epsilon? ] assoc-filter ] bi
assoc-union H{ } assoc-like ; inline
: disambiguate ( nfa -- nfa )
[
dup new-transitions '[
[
_ swap '[ _ get-transitions ] assoc-map
[ nip empty? not ] assoc-filter
] preserving-epsilon
] assoc-map
] change-transitions ;

59
basis/regexp/matchers/matchers.factor Normal file
View File

@ -0,0 +1,59 @@
! Copyright (C) 2008, 2009 Daniel Ehrenberg, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math splitting make fry locals math.ranges
accessors arrays ;
IN: regexp.matchers
! For now, a matcher is just something with a method to do the
! equivalent of match.
GENERIC: match-index-from ( i string matcher -- index/f )
: match-index-head ( string matcher -- index/f )
[ 0 ] 2dip match-index-from ;
: match-slice ( i string matcher -- slice/f )
[ 2dup ] dip match-index-from
[ swap <slice> ] [ 2drop f ] if* ;
: matches? ( string matcher -- ? )
dupd match-index-head
[ swap length = ] [ drop f ] if* ;
: match-from ( i string matcher -- slice/f )
[ [ length [a,b) ] keep ] dip
'[ _ _ match-slice ] map-find drop ;
: match-head ( str matcher -- slice/f )
[ 0 ] 2dip match-from ;
<PRIVATE
: next-match ( i string matcher -- i match/f )
match-from [ dup [ to>> ] when ] keep ;
PRIVATE>
:: all-matches ( string matcher -- seq )
0 [ dup ] [ string matcher next-match ] produce nip but-last ;
: count-matches ( string matcher -- n )
all-matches length ;
<PRIVATE
:: split-slices ( string slices -- new-slices )
slices [ to>> ] map 0 prefix
slices [ from>> ] map string length suffix
[ string <slice> ] 2map ;
PRIVATE>
: re-split1 ( string matcher -- before after/f )
dupd match-head [ 1array split-slices first2 ] [ f ] if* ;
: re-split ( string matcher -- seq )
dupd all-matches split-slices ;
: re-replace ( string matcher replacement -- result )
[ re-split ] dip join ;

58
basis/regexp/minimize/minimize-tests.factor Normal file
View File

@ -0,0 +1,58 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test regexp.minimize assocs regexp
accessors regexp.transition-tables regexp.parser
regexp.classes regexp.negation ;
IN: regexp.minimize.tests
[ t ] [ 1 2 H{ { { 1 2 } t } } same-partition? ] unit-test
[ t ] [ 2 1 H{ { { 1 2 } t } } same-partition? ] unit-test
[ f ] [ 2 3 H{ { { 1 2 } t } } same-partition? ] unit-test
[ H{ { 1 1 } { 2 1 } { 3 3 } { 4 3 } } ]
[ { { 1 1 } { 1 2 } { 2 2 } { 3 3 } { 3 4 } { 4 4 } } [ t ] H{ } map>assoc partition>classes ] unit-test
[ { { 1 2 } { 3 4 } } ] [ H{ { "elephant" 1 } { "tiger" 3 } } H{ { "elephant" 2 } { "tiger" 4 } } assemble-values ] unit-test
: regexp-states ( string -- n )
parse-regexp ast>dfa transitions>> assoc-size ;
[ 3 ] [ "ab|ac" regexp-states ] unit-test
[ 3 ] [ "a(b|c)" regexp-states ] unit-test
[ 1 ] [ "((aa*)*)*" regexp-states ] unit-test
[ 1 ] [ "a|((aa*)*)*" regexp-states ] unit-test
[ 2 ] [ "ab|((aa*)*)*b" regexp-states ] unit-test
[ 4 ] [ "ab|cd" regexp-states ] unit-test
[ 1 ] [ "(?i:[a-z]*|[A-Z]*)" regexp-states ] unit-test
[
T{ transition-table
{ transitions H{
{ 0 H{ { CHAR: a 1 } { CHAR: b 1 } } }
{ 1 H{ { CHAR: a 2 } { CHAR: b 2 } } }
{ 2 H{ { CHAR: c 3 } } }
{ 3 H{ } }
} }
{ start-state 0 }
{ final-states H{ { 3 3 } } }
}
] [
T{ transition-table
{ transitions H{
{ 0 H{ { CHAR: a 1 } { CHAR: b 4 } } }
{ 1 H{ { CHAR: a 2 } { CHAR: b 5 } } }
{ 2 H{ { CHAR: c 3 } } }
{ 3 H{ } }
{ 4 H{ { CHAR: a 2 } { CHAR: b 5 } } }
{ 5 H{ { CHAR: c 6 } } }
{ 6 H{ } }
} }
{ start-state 0 }
{ final-states H{ { 3 3 } { 6 6 } } }
} combine-states
] unit-test
[ [ ] [ ] while-changes ] must-infer
[ H{ { T{ or-class f { 1 2 } } 3 } { 4 5 } } ]
[ H{ { 1 3 } { 2 3 } { 4 5 } } combine-state-transitions ] unit-test

99
basis/regexp/minimize/minimize.factor Normal file
View File

@ -0,0 +1,99 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences regexp.transition-tables fry assocs
accessors locals math sorting arrays sets hashtables regexp.dfa
combinators.short-circuit regexp.classes ;
IN: regexp.minimize
: table>state-numbers ( table -- assoc )
transitions>> keys <enum> [ swap ] H{ } assoc-map-as ;
: number-states ( table -- newtable )
dup table>state-numbers transitions-at ;
: has-conditions? ( assoc -- ? )
values [ condition? ] any? ;
: initially-same? ( s1 s2 transition-table -- ? )
{
[ drop <= ]
[ transitions>> '[ _ at keys ] bi@ set= ]
[ final-states>> '[ _ key? ] bi@ = ]
} 3&& ;
:: initialize-partitions ( transition-table -- partitions )
! Partition table is sorted-array => ?
H{ } clone :> out
transition-table transitions>> keys :> states
states [| s1 |
states [| s2 |
s1 s2 transition-table initially-same?
[ s1 s2 2array out conjoin ] when
] each
] each out ;
: same-partition? ( s1 s2 partitions -- ? )
{ [ [ 2array natural-sort ] dip key? ] [ drop = ] } 3|| ;
: assemble-values ( assoc1 assoc2 -- values )
dup keys '[ _ swap [ at ] curry map ] bi@ zip ;
: stay-same? ( s1 s2 transition partitions -- ? )
[ '[ _ transitions>> at ] bi@ assemble-values ] dip
'[ _ same-partition? ] assoc-all? ;
: partition-more ( partitions transition-table -- partitions )
over '[ drop first2 _ _ stay-same? ] assoc-filter ;
: partition>classes ( partitions -- synonyms ) ! old-state => new-state
>alist sort-keys
[ drop first2 swap ] assoc-map
<reversed>
>hashtable ;
:: (while-changes) ( obj quot: ( obj -- obj' ) comp: ( obj -- key ) old-key -- obj )
obj quot call :> new-obj
new-obj comp call :> new-key
new-key old-key =
[ new-obj ]
[ new-obj quot comp new-key (while-changes) ]
if ; inline recursive
: while-changes ( obj quot pred -- obj' )
3dup nip call (while-changes) ; inline
: (state-classes) ( transition-table -- partition )
[ initialize-partitions ] keep
'[ _ partition-more ] [ assoc-size ] while-changes ;
: assoc>set ( assoc -- keys-set )
[ drop dup ] assoc-map ;
: state-classes ( transition-table -- synonyms )
clone [ [ nip has-conditions? ] assoc-partition ] change-transitions
[ assoc>set ] [ (state-classes) partition>classes ] bi* assoc-union ;
: canonical-state? ( state transitions state-classes -- ? )
'[ dup _ at = ] swap '[ _ at has-conditions? ] bi or ;
: delete-duplicates ( transitions state-classes -- new-transitions )
dupd '[ drop _ _ canonical-state? ] assoc-filter ;
: combine-states ( table -- smaller-table )
dup state-classes
[ transitions-at ] keep
'[ _ delete-duplicates ] change-transitions ;
: combine-state-transitions ( hash -- hash )
H{ } clone tuck '[
_ [ 2array <or-class> ] change-at
] assoc-each [ swap ] assoc-map ;
: combine-transitions ( table -- table )
[ [ combine-state-transitions ] assoc-map ] change-transitions ;
: minimize ( table -- minimal-table )
clone
number-states
combine-states
combine-transitions ;

27
basis/regexp/negation/negation-tests.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test regexp.negation regexp.transition-tables regexp.classes ;
IN: regexp.negation.tests
[
! R/ |[^a]|.+/
T{ transition-table
{ transitions H{
{ 0 H{ { CHAR: a 1 } { T{ not-class f CHAR: a } -1 } } }
{ 1 H{ { t -1 } } }
{ -1 H{ { t -1 } } }
} }
{ start-state 0 }
{ final-states H{ { 0 0 } { -1 -1 } } }
}
] [
! R/ a/
T{ transition-table
{ transitions H{
{ 0 H{ { CHAR: a 1 } } }
{ 1 H{ } }
} }
{ start-state 0 }
{ final-states H{ { 1 1 } } }
} negate-table
] unit-test

53
basis/regexp/negation/negation.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: regexp.nfa regexp.disambiguate kernel sequences
assocs regexp.classes hashtables accessors fry vectors
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 )
clone dup
[ [ fail-state ] dip keys [ <not-class> ] map <and-class> ] keep set-at ;
: fail-state-recurses ( transitions -- new-transitions )
clone dup
[ fail-state t associate fail-state ] dip set-at ;
: add-fail-state ( transitions -- new-transitions )
[ add-default-transition ] assoc-map
fail-state-recurses ;
: inverse-final-states ( transition-table -- final-states )
[ transitions>> assoc>set ] [ final-states>> ] bi assoc-diff ;
: negate-table ( transition-table -- transition-table )
clone
[ add-fail-state ] change-transitions
dup inverse-final-states >>final-states ;
: renumber-states ( transition-table -- transition-table )
dup transitions>> keys [ next-state ] H{ } map>assoc
transitions-at ;
: box-transitions ( transition-table -- transition-table )
[ [ [ 1vector ] assoc-map ] assoc-map ] change-transitions ;
: unify-final-state ( transition-table -- transition-table )
dup [ final-states>> keys ] keep
'[ -2 epsilon _ set-transition ] each
H{ { -2 -2 } } >>final-states ;
: adjoin-dfa ( transition-table -- start end )
unify-final-state renumber-states box-transitions
[ start-state>> ]
[ final-states>> keys first ]
[ nfa-table get [ transitions>> ] bi@ swap update ] tri ;
M: negation nfa-node ( node -- start end )
term>> ast>dfa negate-table adjoin-dfa ;

312
basis/regexp/nfa/nfa.factor
View File

@ -1,235 +1,153 @@
! Copyright (C) 2008 Doug Coleman.
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs grouping kernel regexp.backend
locals math namespaces regexp.parser sequences fry quotations
math.order math.ranges vectors unicode.categories regexp.utils
regexp.transition-tables words sets regexp.classes unicode.case.private ;
USING: accessors arrays assocs grouping kernel
locals math namespaces sequences fry quotations
math.order math.ranges vectors unicode.categories
regexp.transition-tables words sets hashtables combinators.short-circuit
unicode.case.private regexp.ast regexp.classes ;
IN: regexp.nfa
! This uses unicode.case.private for ch>upper and ch>lower
! but case-insensitive matching should be done by case-folding everything
! before processing starts
IN: regexp.nfa
ERROR: feature-is-broken feature ;
SYMBOL: option-stack
SYMBOL: negation-mode
: negated? ( -- ? ) negation-mode get 0 or odd? ;
SYMBOL: state
SINGLETON: eps
: next-state ( -- state )
state [ get ] [ inc ] bi ;
MIXIN: traversal-flag
SINGLETON: lookahead-on INSTANCE: lookahead-on traversal-flag
SINGLETON: lookahead-off INSTANCE: lookahead-off traversal-flag
SINGLETON: lookbehind-on INSTANCE: lookbehind-on traversal-flag
SINGLETON: lookbehind-off INSTANCE: lookbehind-off traversal-flag
SINGLETON: capture-group-on INSTANCE: capture-group-on traversal-flag
SINGLETON: capture-group-off INSTANCE: capture-group-off traversal-flag
SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag
SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag
SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag
SYMBOL: nfa-table
: options ( -- obj ) current-regexp get options>> ;
: set-each ( keys value hashtable -- )
'[ _ swap _ set-at ] each ;
: option? ( obj -- ? ) options key? ;
: options>hash ( options -- hashtable )
H{ } clone [
[ [ on>> t ] dip set-each ]
[ [ off>> f ] dip set-each ] 2bi
] keep ;
: option-on ( obj -- ) options conjoin ;
: using-options ( options quot -- )
[ options>hash option-stack [ ?push ] change ] dip
call option-stack get pop* ; inline
: option-off ( obj -- ) options delete-at ;
: option? ( obj -- ? )
option-stack get assoc-stack ;
: next-state ( regexp -- state )
[ state>> ] [ [ 1+ ] change-state drop ] bi ;
GENERIC: nfa-node ( node -- start-state end-state )
: set-start-state ( regexp -- )
dup stack>> [
drop
] [
[ nfa-table>> ] [ pop first ] bi* >>start-state drop
] if-empty ;
: add-simple-entry ( obj -- start-state end-state )
[ next-state next-state 2dup ] dip
nfa-table get add-transition ;
GENERIC: nfa-node ( node -- )
: epsilon-transition ( source target -- )
epsilon nfa-table get add-transition ;
:: add-simple-entry ( obj class -- )
[let* | regexp [ current-regexp get ]
s0 [ regexp next-state ]
s1 [ regexp next-state ]
stack [ regexp stack>> ]
table [ regexp nfa-table>> ] |
negated? [
s0 f obj class make-transition table add-transition
s0 s1 <default-transition> table add-transition
] [
s0 s1 obj class make-transition table add-transition
] if
s0 s1 2array stack push
t s1 table final-states>> set-at ] ;
M:: star nfa-node ( node -- start end )
node term>> nfa-node :> s1 :> s0
next-state :> s2
next-state :> s3
s1 s0 epsilon-transition
s2 s0 epsilon-transition
s2 s3 epsilon-transition
s1 s3 epsilon-transition
s2 s3 ;
: add-traversal-flag ( flag -- )
stack peek second
current-regexp get nfa-traversal-flags>> push-at ;
GENERIC: modify-epsilon ( tag -- newtag )
! Potential off-by-one errors when lookaround nested in lookbehind
:: concatenate-nodes ( -- )
[let* | regexp [ current-regexp get ]
stack [ regexp stack>> ]
table [ regexp nfa-table>> ]
s2 [ stack peek first ]
s3 [ stack pop second ]
s0 [ stack peek first ]
s1 [ stack pop second ] |
s1 s2 eps <literal-transition> table add-transition
s1 table final-states>> delete-at
s0 s3 2array stack push ] ;
M: object modify-epsilon ;
:: alternate-nodes ( -- )
[let* | regexp [ current-regexp get ]
stack [ regexp stack>> ]
table [ regexp nfa-table>> ]
s2 [ stack peek first ]
s3 [ stack pop second ]
s0 [ stack peek first ]
s1 [ stack pop second ]
s4 [ regexp next-state ]
s5 [ regexp next-state ] |
s4 s0 eps <literal-transition> table add-transition
s4 s2 eps <literal-transition> table add-transition
s1 s5 eps <literal-transition> table add-transition
s3 s5 eps <literal-transition> table add-transition
s1 table final-states>> delete-at
s3 table final-states>> delete-at
t s5 table final-states>> set-at
s4 s5 2array stack push ] ;
M: $ modify-epsilon
multiline option? [ drop end-of-input ] unless ;
M: kleene-star nfa-node ( node -- )
term>> nfa-node
[let* | regexp [ current-regexp get ]
stack [ regexp stack>> ]
s0 [ stack peek first ]
s1 [ stack pop second ]
s2 [ regexp next-state ]
s3 [ regexp next-state ]
table [ regexp nfa-table>> ] |
s1 table final-states>> delete-at
t s3 table final-states>> set-at
s1 s0 eps <literal-transition> table add-transition
s2 s0 eps <literal-transition> table add-transition
s2 s3 eps <literal-transition> table add-transition
s1 s3 eps <literal-transition> table add-transition
s2 s3 2array stack push ] ;
M: ^ modify-epsilon
multiline option? [ drop beginning-of-input ] unless ;
M: concatenation nfa-node ( node -- )
seq>>
reversed-regexp option? [ <reversed> ] when
[ [ nfa-node ] each ]
[ length 1- [ concatenate-nodes ] times ] bi ;
M: tagged-epsilon nfa-node
clone [ modify-epsilon ] change-tag add-simple-entry ;
M: alternation nfa-node ( node -- )
seq>>
[ [ nfa-node ] each ]
[ length 1- [ alternate-nodes ] times ] bi ;
M: concatenation nfa-node ( node -- start end )
[ first>> ] [ second>> ] bi
reversed-regexp option? [ swap ] when
[ nfa-node ] bi@
[ epsilon-transition ] dip ;
M: constant nfa-node ( node -- )
:: alternate-nodes ( s0 s1 s2 s3 -- start end )
next-state :> s4
next-state :> s5
s4 s0 epsilon-transition
s4 s2 epsilon-transition
s1 s5 epsilon-transition
s3 s5 epsilon-transition
s4 s5 ;
M: alternation nfa-node ( node -- start end )
[ first>> ] [ second>> ] bi
[ nfa-node ] bi@
alternate-nodes ;
GENERIC: modify-class ( char-class -- char-class' )
M: object modify-class ;
M: integer modify-class
case-insensitive option? [
dup char>> [ ch>lower ] [ ch>upper ] bi
2dup = [
2drop
char>> literal-transition add-simple-entry
] [
[ literal-transition add-simple-entry ] bi@
alternate-nodes drop
] if
] [
char>> literal-transition add-simple-entry
] if ;
dup Letter? [
[ ch>lower ] [ ch>upper ] bi 2array <or-class>
] when
] when ;
M: epsilon nfa-node ( node -- )
drop eps literal-transition add-simple-entry ;
M: integer nfa-node ( node -- start end )
modify-class add-simple-entry ;
M: word nfa-node ( node -- ) class-transition add-simple-entry ;
M: primitive-class modify-class
class>> modify-class <primitive-class> ;
M: any-char nfa-node ( node -- )
[ dotall option? ] dip any-char-no-nl ?
class-transition add-simple-entry ;
M: or-class modify-class
seq>> [ modify-class ] map <or-class> ;
! M: beginning-of-text nfa-node ( node -- ) ;
M: not-class modify-class
class>> modify-class <not-class> ;
M: beginning-of-line nfa-node ( node -- ) class-transition add-simple-entry ;
M: any-char modify-class
drop dotall option? t any-char-no-nl ? ;
M: end-of-line nfa-node ( node -- ) class-transition add-simple-entry ;
: modify-letter-class ( class -- newclass )
case-insensitive option? [ drop Letter-class ] when ;
M: letter-class modify-class modify-letter-class ;
M: LETTER-class modify-class modify-letter-class ;
: choose-letter-class ( node -- node' )
case-insensitive option? Letter-class rot ? ;
: cased-range? ( range -- ? )
[ from>> ] [ to>> ] bi {
[ [ letter? ] bi@ and ]
[ [ LETTER? ] bi@ and ]
} 2|| ;
M: letter-class nfa-node ( node -- )
choose-letter-class class-transition add-simple-entry ;
M: LETTER-class nfa-node ( node -- )
choose-letter-class class-transition add-simple-entry ;
M: character-class-range nfa-node ( node -- )
M: range modify-class
case-insensitive option? [
! This should be implemented for Unicode by case-folding
! the input and all strings in the regexp.
dup [ from>> ] [ to>> ] bi
2dup [ Letter? ] bi@ and [
rot drop
[ [ ch>lower ] bi@ character-class-range boa ]
[ [ ch>upper ] bi@ character-class-range boa ] 2bi
[ class-transition add-simple-entry ] bi@
alternate-nodes
] [
2drop
class-transition add-simple-entry
] if
] [
class-transition add-simple-entry
] if ;
dup cased-range? [
[ from>> ] [ to>> ] bi
[ [ ch>lower ] bi@ <range> ]
[ [ ch>upper ] bi@ <range> ] 2bi
2array <or-class>
] when
] when ;
M: capture-group nfa-node ( node -- )
"capture-groups" feature-is-broken
eps literal-transition add-simple-entry
capture-group-on add-traversal-flag
term>> nfa-node
eps literal-transition add-simple-entry
capture-group-off add-traversal-flag
2 [ concatenate-nodes ] times ;
M: class nfa-node
modify-class add-simple-entry ;
! xyzzy
M: non-capture-group nfa-node ( node -- )
term>> nfa-node ;
M: with-options nfa-node ( node -- start end )
dup options>> [ tree>> nfa-node ] using-options ;
M: reluctant-kleene-star nfa-node ( node -- )
term>> <kleene-star> nfa-node ;
M: negation nfa-node ( node -- )
negation-mode inc
term>> nfa-node
negation-mode dec ;
M: lookahead nfa-node ( node -- )
"lookahead" feature-is-broken
eps literal-transition add-simple-entry
lookahead-on add-traversal-flag
term>> nfa-node
eps literal-transition add-simple-entry
lookahead-off add-traversal-flag
2 [ concatenate-nodes ] times ;
M: lookbehind nfa-node ( node -- )
"lookbehind" feature-is-broken
eps literal-transition add-simple-entry
lookbehind-on add-traversal-flag
term>> nfa-node
eps literal-transition add-simple-entry
lookbehind-off add-traversal-flag
2 [ concatenate-nodes ] times ;
M: option nfa-node ( node -- )
[ option>> ] [ on?>> ] bi [ option-on ] [ option-off ] if
eps literal-transition add-simple-entry ;
: construct-nfa ( regexp -- )
: construct-nfa ( ast -- nfa-table )
[
reset-regexp
negation-mode off
[ current-regexp set ]
[ parse-tree>> nfa-node ]
[ set-start-state ] tri
0 state set
<transition-table> nfa-table set
nfa-node
nfa-table get
swap dup associate >>final-states
swap >>start-state
] with-scope ;

50
basis/regexp/parser/parser-tests.factor
View File

@ -1,34 +1,24 @@
USING: kernel tools.test regexp.backend regexp ;
IN: regexp.parser
USING: kernel tools.test regexp.parser fry sequences ;
IN: regexp.parser.tests
: test-regexp ( string -- )
default-regexp parse-regexp ;
: regexp-parses ( string -- )
[ [ ] ] dip '[ _ parse-regexp drop ] unit-test ;
! [ "(" ] [ unmatched-parentheses? ] must-fail-with
: regexp-fails ( string -- )
'[ _ parse-regexp ] must-fail ;
[ ] [ "a|b" test-regexp ] unit-test
[ ] [ "a.b" test-regexp ] unit-test
[ ] [ "a|b|c" test-regexp ] unit-test
[ ] [ "abc|b" test-regexp ] unit-test
[ ] [ "a|bcd" test-regexp ] unit-test
[ ] [ "a|(b)" test-regexp ] unit-test
[ ] [ "(a)|b" test-regexp ] unit-test
[ ] [ "(a|b)" test-regexp ] unit-test
[ ] [ "((a)|(b))" test-regexp ] unit-test
{
"a|b" "a.b" "a|b|c" "abc|b" "a|bcd" "a|(b)" "(?-i:a)" "||"
"(a)|b" "(a|b)" "((a)|(b))" "(?:a)" "(?i:a)" "|b" "b|"
"[abc]" "[a-c]" "[^a-c]" "[^]]" "[]a]" "[[]" "[]-a]" "[a-]" "[-]"
"[--a]" "foo*" "(foo)*" "(a|b)|c" "(foo){2,3}" "(foo){2,}"
"(foo){2}" "{2,3}" "{," "{,}" "}" "foo}" "[^]-a]" "[^-]a]"
"[a-]" "[^a-]" "[^a-]" "a{,2}" "(?#foobar)"
"\\p{Space}" "\\t" "\\[" "[\\]]" "\\P{Space}"
"\\ueeee" "\\0333" "\\xff" "\\\\" "\\w"
} [ regexp-parses ] each
[ ] [ "(?:a)" test-regexp ] unit-test
[ ] [ "(?i:a)" test-regexp ] unit-test
[ ] [ "(?-i:a)" test-regexp ] unit-test
[ "(?z:a)" test-regexp ] [ unknown-regexp-option? ] must-fail-with
[ "(?-z:a)" test-regexp ] [ unknown-regexp-option? ] must-fail-with
[ ] [ "(?=a)" test-regexp ] unit-test
[ ] [ "[abc]" test-regexp ] unit-test
[ ] [ "[a-c]" test-regexp ] unit-test
[ ] [ "[^a-c]" test-regexp ] unit-test
[ "[^]" test-regexp ] must-fail
[ ] [ "|b" test-regexp ] unit-test
[ ] [ "b|" test-regexp ] unit-test
[ ] [ "||" test-regexp ] unit-test
{
"[^]" "[]" "a{foo}" "a{,}" "a{}" "(?)" "\\p{foo}" "\\P{foo}"
"\\ueeeg" "\\0339" "\\xfg"
} [ regexp-fails ] each

532
basis/regexp/parser/parser.factor
View File

@ -1,437 +1,177 @@
! Copyright (C) 2008 Doug Coleman.
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators io io.streams.string
kernel math math.parser namespaces sets
quotations sequences splitting vectors math.order
strings regexp.backend regexp.utils
unicode.case unicode.categories words locals regexp.classes ;
USING: peg.ebnf kernel math.parser sequences assocs arrays fry math
combinators regexp.classes strings splitting peg locals accessors
regexp.ast ;
IN: regexp.parser
FROM: math.ranges => [a,b] ;
: allowed-char? ( ch -- ? )
".()|[*+?$^" member? not ;
TUPLE: concatenation seq ; INSTANCE: concatenation node
TUPLE: alternation seq ; INSTANCE: alternation node
TUPLE: kleene-star term ; INSTANCE: kleene-star node
ERROR: bad-number ;
! !!!!!!!!
TUPLE: possessive-question term ; INSTANCE: possessive-question node
TUPLE: possessive-kleene-star term ; INSTANCE: possessive-kleene-star node
: ensure-number ( n -- n )
[ bad-number ] unless* ;
! !!!!!!!!
TUPLE: reluctant-question term ; INSTANCE: reluctant-question node
TUPLE: reluctant-kleene-star term ; INSTANCE: reluctant-kleene-star node
:: at-error ( key assoc quot: ( key -- replacement ) -- value )
key assoc at* [ drop key quot call ] unless ; inline
TUPLE: negation term ; INSTANCE: negation node
TUPLE: constant char ; INSTANCE: constant node
TUPLE: range from to ; INSTANCE: range node
ERROR: bad-class name ;
MIXIN: parentheses-group
TUPLE: lookahead term ; INSTANCE: lookahead node
INSTANCE: lookahead parentheses-group
TUPLE: lookbehind term ; INSTANCE: lookbehind node
INSTANCE: lookbehind parentheses-group
TUPLE: capture-group term ; INSTANCE: capture-group node
INSTANCE: capture-group parentheses-group
TUPLE: non-capture-group term ; INSTANCE: non-capture-group node
INSTANCE: non-capture-group parentheses-group
TUPLE: independent-group term ; INSTANCE: independent-group node ! atomic group
INSTANCE: independent-group parentheses-group
TUPLE: comment-group term ; INSTANCE: comment-group node
INSTANCE: comment-group parentheses-group
: name>class ( name -- class )
{
{ "Lower" letter-class }
{ "Upper" LETTER-class }
{ "Alpha" Letter-class }
{ "ASCII" ascii-class }
{ "Digit" digit-class }
{ "Alnum" alpha-class }
{ "Punct" punctuation-class }
{ "Graph" java-printable-class }
{ "Print" java-printable-class }
{ "Blank" non-newline-blank-class }
{ "Cntrl" control-character-class }
{ "XDigit" hex-digit-class }
{ "Space" java-blank-class }
! TODO: unicode-character-class
} [ bad-class ] at-error ;
SINGLETON: epsilon INSTANCE: epsilon node
: lookup-escape ( char -- ast )
{
{ CHAR: t [ CHAR: \t ] }
{ CHAR: n [ CHAR: \n ] }
{ CHAR: r [ CHAR: \r ] }
{ CHAR: f [ HEX: c ] }
{ CHAR: a [ HEX: 7 ] }
{ CHAR: e [ HEX: 1b ] }
{ CHAR: \\ [ CHAR: \\ ] }
TUPLE: option option on? ; INSTANCE: option node
{ CHAR: w [ c-identifier-class <primitive-class> ] }
{ CHAR: W [ c-identifier-class <primitive-class> <not-class> ] }
{ CHAR: s [ java-blank-class <primitive-class> ] }
{ CHAR: S [ java-blank-class <primitive-class> <not-class> ] }
{ CHAR: d [ digit-class <primitive-class> ] }
{ CHAR: D [ digit-class <primitive-class> <not-class> ] }
SINGLETONS: unix-lines dotall multiline comments case-insensitive
unicode-case reversed-regexp ;
{ CHAR: z [ end-of-input <tagged-epsilon> ] }
{ CHAR: Z [ end-of-file <tagged-epsilon> ] }
{ CHAR: A [ beginning-of-input <tagged-epsilon> ] }
[ ]
} case ;
SINGLETONS: beginning-of-character-class end-of-character-class
left-parenthesis pipe caret dash ;
: push1 ( obj -- ) input-stream get stream>> push ;
: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ;
: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ;
: drop1 ( -- ) read1 drop ;
: stack ( -- obj ) current-regexp get stack>> ;
: change-whole-stack ( quot -- )
current-regexp get
[ stack>> swap call ] keep (>>stack) ; inline
: push-stack ( obj -- ) stack push ;
: pop-stack ( -- obj ) stack pop ;
: cut-out ( vector n -- vector' vector ) cut rest ;
ERROR: cut-stack-error ;
: cut-stack ( obj vector -- vector' vector )
[ nip ] [ last-index ] 2bi [ cut-stack-error ] unless* cut-out swap ;
: <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
: <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;
: <possessive-question> ( obj -- kleene ) possessive-question boa ;
: <reluctant-question> ( obj -- kleene ) reluctant-question boa ;
: <negation> ( obj -- negation ) negation boa ;
: <concatenation> ( seq -- concatenation )
>vector [ epsilon ] [ concatenation boa ] if-empty ;
: <alternation> ( seq -- alternation ) >vector alternation boa ;
: <capture-group> ( obj -- capture-group ) capture-group boa ;
: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
: <constant> ( obj -- constant ) constant boa ;
: first|concatenation ( seq -- first/concatenation )
dup length 1 = [ first ] [ <concatenation> ] if ;
: first|alternation ( seq -- first/alternation )
dup length 1 = [ first ] [ <alternation> ] if ;
: <character-class-range> ( from to -- obj )
2dup <
[ character-class-range boa ] [ 2drop unmatchable-class ] if ;
ERROR: unmatched-parentheses ;
ERROR: unknown-regexp-option option ;
: options-assoc ( -- assoc )
H{
{ CHAR: i case-insensitive }
{ CHAR: d unix-lines }
{ CHAR: m multiline }
{ CHAR: n multiline }
{ CHAR: r reversed-regexp }
{ CHAR: s dotall }
{ CHAR: u unicode-case }
{ CHAR: x comments }
} ;
: ch>option ( ch -- singleton )
{
{ CHAR: i [ case-insensitive ] }
{ CHAR: d [ unix-lines ] }
{ CHAR: m [ multiline ] }
{ CHAR: n [ multiline ] }
{ CHAR: r [ reversed-regexp ] }
{ CHAR: s [ dotall ] }
{ CHAR: u [ unicode-case ] }
{ CHAR: x [ comments ] }
[ unknown-regexp-option ]
} case ;
options-assoc at ;
: option>ch ( option -- string )
{
{ case-insensitive [ CHAR: i ] }
{ multiline [ CHAR: m ] }
{ reversed-regexp [ CHAR: r ] }
{ dotall [ CHAR: s ] }
[ unknown-regexp-option ]
} case ;
options-assoc value-at ;
: toggle-option ( ch ? -- )
[ ch>option ] dip option boa push-stack ;
: parse-options ( on off -- options )
[ [ ch>option ] { } map-as ] bi@ <options> ;
: (parse-options) ( string ? -- ) [ toggle-option ] curry each ;
: string>options ( string -- options )
"-" split1 parse-options ;
: options>string ( options -- string )
[ on>> ] [ off>> ] bi
[ [ option>ch ] map ] bi@
[ "-" glue ] unless-empty
"" like ;
: parse-options ( string -- )
"-" split1 [ t (parse-options) ] [ f (parse-options) ] bi* ;
! TODO: add syntax for various parenthized things,
! add greedy and nongreedy forms of matching
! (once it's all implemented)
ERROR: bad-special-group string ;
EBNF: parse-regexp
DEFER: (parse-regexp)
: nested-parse-regexp ( token ? -- )
[ push-stack (parse-regexp) pop-stack ] dip
[ <negation> ] when pop-stack new swap >>term push-stack ;
CharacterInBracket = !("}") Character
! non-capturing groups
: (parse-special-group) ( -- )
read1 {
{ [ dup CHAR: # = ] ! comment
[ drop comment-group f nested-parse-regexp pop-stack drop ] }
{ [ dup CHAR: : = ]
[ drop non-capture-group f nested-parse-regexp ] }
{ [ dup CHAR: = = ]
[ drop lookahead f nested-parse-regexp ] }
{ [ dup CHAR: ! = ]
[ drop lookahead t nested-parse-regexp ] }
{ [ dup CHAR: > = ]
[ drop non-capture-group f nested-parse-regexp ] }
{ [ dup CHAR: < = peek1 CHAR: = = and ]
[ drop drop1 lookbehind f nested-parse-regexp ] }
{ [ dup CHAR: < = peek1 CHAR: ! = and ]
[ drop drop1 lookbehind t nested-parse-regexp ] }
[
":)" read-until
[ swap prefix ] dip
{
{ CHAR: : [ parse-options non-capture-group f nested-parse-regexp ] }
{ CHAR: ) [ parse-options ] }
[ drop bad-special-group ]
} case
]
} cond ;
QuotedCharacter = !("\\E") .
: handle-left-parenthesis ( -- )
peek1 CHAR: ? =
[ drop1 (parse-special-group) ]
[ capture-group f nested-parse-regexp ] if ;
Escape = "p{" CharacterInBracket*:s "}" => [[ s >string name>class <primitive-class> ]]
| "P{" CharacterInBracket*:s "}" => [[ s >string name>class <primitive-class> <negation> ]]
| "Q" QuotedCharacter*:s "\\E" => [[ s <concatenation> ]]
| "u" Character:a Character:b Character:c Character:d
=> [[ { a b c d } hex> ensure-number ]]
| "x" Character:a Character:b
=> [[ { a b } hex> ensure-number ]]
| "0" Character:a Character:b Character:c
=> [[ { a b c } oct> ensure-number ]]
| . => [[ lookup-escape ]]
: handle-dot ( -- ) any-char push-stack ;
: handle-pipe ( -- ) pipe push-stack ;
: (handle-star) ( obj -- kleene-star )
peek1 {
{ CHAR: + [ drop1 <possessive-kleene-star> ] }
{ CHAR: ? [ drop1 <reluctant-kleene-star> ] }
[ drop <kleene-star> ]
} case ;
: handle-star ( -- ) stack pop (handle-star) push-stack ;
: handle-question ( -- )
stack pop peek1 {
{ CHAR: + [ drop1 <possessive-question> ] }
{ CHAR: ? [ drop1 <reluctant-question> ] }
[ drop epsilon 2array <alternation> ]
} case push-stack ;
: handle-plus ( -- )
stack pop dup (handle-star)
2array <concatenation> push-stack ;
EscapeSequence = "\\" Escape:e => [[ e ]]
ERROR: unmatched-brace ;
: parse-repetition ( -- start finish ? )
"}" read-until [ unmatched-brace ] unless
[ "," split1 [ string>number ] bi@ ]
[ CHAR: , swap index >boolean ] bi ;
Character = EscapeSequence
| "$" => [[ $ <tagged-epsilon> ]]
| "^" => [[ ^ <tagged-epsilon> ]]
| . ?[ allowed-char? ]?
: replicate/concatenate ( n obj -- obj' )
over zero? [ 2drop epsilon ]
[ <repetition> first|concatenation ] if ;
AnyRangeCharacter = EscapeSequence | .
: exactly-n ( n -- )
stack pop replicate/concatenate push-stack ;
RangeCharacter = !("]") AnyRangeCharacter
: at-least-n ( n -- )
stack pop
[ replicate/concatenate ] keep
<kleene-star> 2array <concatenation> push-stack ;
Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b <range> ]]
| RangeCharacter
: at-most-n ( n -- )
1+
stack pop
[ replicate/concatenate ] curry map <alternation> push-stack ;
StartRange = AnyRangeCharacter:a "-" RangeCharacter:b => [[ a b <range> ]]
| AnyRangeCharacter
: from-m-to-n ( m n -- )
[a,b]
stack pop
[ replicate/concatenate ] curry map
<alternation> push-stack ;
Ranges = StartRange:s Range*:r => [[ r s prefix ]]
ERROR: invalid-range a b ;
CharClass = "^"?:n Ranges:e => [[ e n char-class ]]
: handle-left-brace ( -- )
parse-repetition
[ 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ ] dip
[
2dup and [ from-m-to-n ]
[ [ nip at-most-n ] [ at-least-n ] if* ] if
] [ drop 0 max exactly-n ] if ;
Options = [idmsux]*
: handle-front-anchor ( -- ) beginning-of-line push-stack ;
: handle-back-anchor ( -- ) end-of-line push-stack ;
Parenthized = "?:" Alternation:a => [[ a ]]
| "?" Options:on "-"? Options:off ":" Alternation:a
=> [[ a on off parse-options <with-options> ]]
| "?#" [^)]* => [[ f ]]
| "?~" Alternation:a => [[ a <negation> ]]
| "?=" Alternation:a => [[ a t <lookahead> <tagged-epsilon> ]]
| "?!" Alternation:a => [[ a f <lookahead> <tagged-epsilon> ]]
| "?<=" Alternation:a => [[ a t <lookbehind> <tagged-epsilon> ]]
| "?<!" Alternation:a => [[ a f <lookbehind> <tagged-epsilon> ]]
| Alternation
ERROR: bad-character-class obj ;
ERROR: expected-posix-class ;
Element = "(" Parenthized:p ")" => [[ p ]]
| "[" CharClass:r "]" => [[ r ]]
| ".":d => [[ any-char <primitive-class> ]]
| Character
: parse-posix-class ( -- obj )
read1 CHAR: { = [ expected-posix-class ] unless
"}" read-until [ bad-character-class ] unless
{
{ "Lower" [ letter-class ] }
{ "Upper" [ LETTER-class ] }
{ "Alpha" [ Letter-class ] }
{ "ASCII" [ ascii-class ] }
{ "Digit" [ digit-class ] }
{ "Alnum" [ alpha-class ] }
{ "Punct" [ punctuation-class ] }
{ "Graph" [ java-printable-class ] }
{ "Print" [ java-printable-class ] }
{ "Blank" [ non-newline-blank-class ] }
{ "Cntrl" [ control-character-class ] }
{ "XDigit" [ hex-digit-class ] }
{ "Space" [ java-blank-class ] }
! TODO: unicode-character-class, fallthrough in unicode is bad-char-clss
[ bad-character-class ]
} case ;
Number = (!(","|"}").)* => [[ string>number ensure-number ]]
: parse-octal ( -- n ) 3 read oct> check-octal ;
: parse-short-hex ( -- n ) 2 read hex> check-hex ;
: parse-long-hex ( -- n ) 6 read hex> check-hex ;
: parse-control-character ( -- n ) read1 ;
Times = "," Number:n "}" => [[ 0 n <from-to> ]]
| Number:n ",}" => [[ n <at-least> ]]
| Number:n "}" => [[ n n <from-to> ]]
| "}" => [[ bad-number ]]
| Number:n "," Number:m "}" => [[ n m <from-to> ]]
ERROR: bad-escaped-literals seq ;
Repeated = Element:e "{" Times:t => [[ e t <times> ]]
| Element:e "??" => [[ e <maybe> ]]
| Element:e "*?" => [[ e <star> ]]
| Element:e "+?" => [[ e <plus> ]]
| Element:e "?" => [[ e <maybe> ]]
| Element:e "*" => [[ e <star> ]]
| Element:e "+" => [[ e <plus> ]]
| Element
: parse-til-E ( -- obj )
"\\E" read-until [ bad-escaped-literals ] unless ;
:: (parse-escaped-literals) ( quot: ( obj -- obj' ) -- obj )
parse-til-E
drop1
[ epsilon ] [
quot call [ <constant> ] V{ } map-as
first|concatenation
] if-empty ; inline
Concatenation = Repeated*:r => [[ r sift <concatenation> ]]
: parse-escaped-literals ( -- obj )
[ ] (parse-escaped-literals) ;
Alternation = Concatenation:c ("|" Concatenation)*:a
=> [[ a empty? [ c ] [ a values c prefix <alternation> ] if ]]
: lower-case-literals ( -- obj )
[ >lower ] (parse-escaped-literals) ;
End = !(.)
: upper-case-literals ( -- obj )
[ >upper ] (parse-escaped-literals) ;
: parse-escaped ( -- obj )
read1
{
{ CHAR: t [ CHAR: \t <constant> ] }
{ CHAR: n [ CHAR: \n <constant> ] }
{ CHAR: r [ CHAR: \r <constant> ] }
{ CHAR: f [ HEX: c <constant> ] }
{ CHAR: a [ HEX: 7 <constant> ] }
{ CHAR: e [ HEX: 1b <constant> ] }
{ CHAR: w [ c-identifier-class ] }
{ CHAR: W [ c-identifier-class <negation> ] }
{ CHAR: s [ java-blank-class ] }
{ CHAR: S [ java-blank-class <negation> ] }
{ CHAR: d [ digit-class ] }
{ CHAR: D [ digit-class <negation> ] }
{ CHAR: p [ parse-posix-class ] }
{ CHAR: P [ parse-posix-class <negation> ] }
{ CHAR: x [ parse-short-hex <constant> ] }
{ CHAR: u [ parse-long-hex <constant> ] }
{ CHAR: 0 [ parse-octal <constant> ] }
{ CHAR: c [ parse-control-character ] }
{ CHAR: Q [ parse-escaped-literals ] }
! { CHAR: b [ word-boundary-class ] }
! { CHAR: B [ word-boundary-class <negation> ] }
! { CHAR: A [ handle-beginning-of-input ] }
! { CHAR: z [ handle-end-of-input ] }
! { CHAR: Z [ handle-end-of-input ] } ! plus a final terminator
! m//g mode
! { CHAR: G [ end of previous match ] }
! Group capture
! { CHAR: 1 [ CHAR: 1 <constant> ] }
! { CHAR: 2 [ CHAR: 2 <constant> ] }
! { CHAR: 3 [ CHAR: 3 <constant> ] }
! { CHAR: 4 [ CHAR: 4 <constant> ] }
! { CHAR: 5 [ CHAR: 5 <constant> ] }
! { CHAR: 6 [ CHAR: 6 <constant> ] }
! { CHAR: 7 [ CHAR: 7 <constant> ] }
! { CHAR: 8 [ CHAR: 8 <constant> ] }
! { CHAR: 9 [ CHAR: 9 <constant> ] }
! Perl extensions
! can't do \l and \u because \u is already a 4-hex
{ CHAR: L [ lower-case-literals ] }
{ CHAR: U [ upper-case-literals ] }
[ <constant> ]
} case ;
: handle-escape ( -- ) parse-escaped push-stack ;
: handle-dash ( vector -- vector' )
H{ { dash CHAR: - } } substitute ;
: character-class>alternation ( seq -- alternation )
[ dup number? [ <constant> ] when ] map first|alternation ;
: handle-caret ( vector -- vector' )
dup [ length 2 >= ] [ first caret eq? ] bi and [
rest-slice character-class>alternation <negation>
] [
character-class>alternation
] if ;
: make-character-class ( -- character-class )
[ beginning-of-character-class swap cut-stack ] change-whole-stack
handle-dash handle-caret ;
: apply-dash ( -- )
stack [ pop3 nip <character-class-range> ] keep push ;
: apply-dash? ( -- ? )
stack dup length 3 >=
[ [ length 2 - ] keep nth dash eq? ] [ drop f ] if ;
ERROR: empty-negated-character-class ;
DEFER: handle-left-bracket
: (parse-character-class) ( -- )
read1 [ empty-negated-character-class ] unless* {
{ CHAR: [ [ handle-left-bracket t ] }
{ CHAR: ] [ make-character-class push-stack f ] }
{ CHAR: - [ dash push-stack t ] }
{ CHAR: \ [ parse-escaped push-stack t ] }
[ push-stack apply-dash? [ apply-dash ] when t ]
} case
[ (parse-character-class) ] when ;
: push-constant ( ch -- ) <constant> push-stack ;
: parse-character-class-second ( -- )
read1 {
{ CHAR: [ [ CHAR: [ push-constant ] }
{ CHAR: ] [ CHAR: ] push-constant ] }
{ CHAR: - [ CHAR: - push-constant ] }
[ push1 ]
} case ;
: parse-character-class-first ( -- )
read1 {
{ CHAR: ^ [ caret push-stack parse-character-class-second ] }
{ CHAR: [ [ CHAR: [ push-constant ] }
{ CHAR: ] [ CHAR: ] push-constant ] }
{ CHAR: - [ CHAR: - push-constant ] }
[ push1 ]
} case ;
: handle-left-bracket ( -- )
beginning-of-character-class push-stack
parse-character-class-first (parse-character-class) ;
: finish-regexp-parse ( stack -- obj )
{ pipe } split
[ first|concatenation ] map first|alternation ;
: handle-right-parenthesis ( -- )
stack dup [ parentheses-group "members" word-prop member? ] find-last
-rot cut rest
[ [ push ] keep current-regexp get (>>stack) ]
[ finish-regexp-parse push-stack ] bi* ;
: parse-regexp-token ( token -- ? )
{
{ CHAR: ( [ handle-left-parenthesis t ] } ! handle (?..) at beginning?
{ CHAR: ) [ handle-right-parenthesis f ] }
{ CHAR: . [ handle-dot t ] }
{ CHAR: | [ handle-pipe t ] }
{ CHAR: ? [ handle-question t ] }
{ CHAR: * [ handle-star t ] }
{ CHAR: + [ handle-plus t ] }
{ CHAR: { [ handle-left-brace t ] }
{ CHAR: [ [ handle-left-bracket t ] }
{ CHAR: \ [ handle-escape t ] }
[
dup CHAR: $ = peek1 f = and
[ drop handle-back-anchor f ]
[ push-constant t ] if
]
} case ;
: (parse-regexp) ( -- )
read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
: parse-regexp-beginning ( -- )
peek1 CHAR: ^ = [ drop1 handle-front-anchor ] when ;
: parse-regexp ( regexp -- )
dup current-regexp [
raw>> [
<string-reader> [
parse-regexp-beginning (parse-regexp)
] with-input-stream
] unless-empty
current-regexp get [ finish-regexp-parse ] change-stack
dup stack>> >>parse-tree drop
] with-variable ;
Main = Alternation End
;EBNF

85
basis/regexp/regexp-docs.factor
View File

@ -1,8 +1,87 @@
! Copyright (C) 2008 Doug Coleman.
! 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.backend ;
USING: kernel strings help.markup help.syntax regexp.matchers math ;
IN: regexp
ABOUT: "regexp"
ARTICLE: "regexp" "Regular expressions"
"The " { $vocab-link "regexp" } " vocabulary provides word for creating and using regular expressions."
{ $subsection { "regexp" "syntax" } }
{ $subsection { "regexp" "construction" } }
{ $vocab-subsection "regexp.combinators" "Regular expression combinators" }
{ $subsection { "regexp" "operations" } }
{ $subsection regexp }
{ $subsection { "regexp" "theory" } } ;
ARTICLE: { "regexp" "construction" } "Constructing regular expressions"
"Words which are useful for creating regular expressions:"
{ $subsection POSTPONE: R/ }
{ $subsection <regexp> }
{ $subsection <optioned-regexp> }
{ $heading "See also" }
{ $vocab-link "regexp.combinators" } ;
ARTICLE: { "regexp" "syntax" } "Regular expression syntax"
"Regexp syntax is largely compatible with Perl, Java and extended POSTFIX regexps, but not completely." $nl
"A new addition is the inclusion of a negation operator, with the syntax " { $snippet "(?~foo)" } " to match everything that does not match " { $snippet "foo" } "." $nl
"One missing feature is backreferences. This is because of a design decision to allow only regular expressions following the formal theory of regular languages. For more information, see " { $link { "regexp" "theory" } } ". You can create a new regular expression to match a particular string using " { $vocab-link "regexp.combinators" } " and group capture is available to extract parts of a regular expression match." $nl
"A distinction from Perl is that " { $snippet "\\G" } ", which references the previous match, is not included. This is because that sequence is inherently stateful, and Factor regexps don't hold state." $nl
"Additionally, none of the operations which embed code into a regexp are supported, as this would require the inclusion of the Factor parser and compiler in any application which wants to expose regexps to the user. None of the casing operations are included, for simplicity." ; ! Also describe syntax, from the beginning
ARTICLE: { "regexp" "theory" } "The theory of regular expressions"
"Far from being just a practical tool invented by Unix hackers, regular expressions were studied formally before computer programs were written to process them." $nl
"A regular language is a set of strings that is matched by a regular expression, which is defined to have characters and the empty string, along with the operations concatenation, disjunction and Kleene star. Another way to define the class of regular languages is as the class of languages which can be recognized with constant space overhead, ie with a DFA. These two definitions are provably equivalent." $nl
"One basic result in the theory of regular language is that the complement of a regular language is regular. In other words, for any regular expression, there exists another regular expression which matches exactly the strings that the first one doesn't match." $nl
"This implies, by DeMorgan's law, that, if you have two regular languages, their intersection is also regular. That is, for any two regular expressions, there exists a regular expression which matches strings that match both inputs." $nl
"Traditionally, regular expressions on computer support an additional operation: backreferences. For example, the Perl regexp " { $snippet "/(.*)$1/" } " matches a string repated twice. If a backreference refers to a string with a predetermined maximum length, then the resulting language is still regular." $nl
"But, if not, the language is not regular. There is strong evidence that there is no efficient way to parse with backreferences in the general case. Perl uses a naive backtracking algorithm which has pathological behavior in some cases, taking exponential time to match even if backreferences aren't used. Additionally, expressions with backreferences don't have the properties with negation and intersection described above." $nl
"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-split1 }
{ $subsection re-split }
{ $subsection re-replace }
{ $subsection count-matches }
{ $subsection re-replace } ;
HELP: <regexp>
{ $values { "string" string } { "regexp" regexp } }
{ $description "Compiles a regular expression into a DFA and returns this object. Regular expressions only have to be compiled once and can then be used multiple times to match input strings." } ;
{ $description "Creates a regular expression object, given a string in regular expression syntax. When it is first used for matching, a DFA is compiled, and this DFA is stored for reuse so it is only compiled once." } ;
HELP: <optioned-regexp>
{ $values { "string" string } { "options" string } { "regexp" regexp } }
{ $description "Given a string in regular expression syntax, and a string of options, creates a regular expression object. When it is first used for matching, a DFA is compiled, and this DFA is stored for reuse so it is only compiled once." } ;
HELP: R/
{ $syntax "R/ foo.*|[a-zA-Z]bar/i" }
{ $description "Literal syntax for a regular expression. When this syntax is used, the DFA is compiled at compile-time, rather than on first use." } ;
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" } }
{ $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 } }
{ $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" } }
{ $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 } }
{ $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" } }
{ $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 } }
{ $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 } "." } ;

238
basis/regexp/regexp-tests.factor
View File

@ -1,9 +1,13 @@
USING: regexp tools.test kernel sequences regexp.parser
regexp.traversal eval strings multiline ;
! 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 ;
IN: regexp-tests
\ <regexp> must-infer
\ matches? must-infer
! the following don't compile because [ ] with-compilation-unit doesn't compile
! \ compile-regexp must-infer
! \ matches? must-infer
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
[ t ] [ "" "a*" <regexp> matches? ] unit-test
@ -21,8 +25,8 @@ IN: regexp-tests
[ t ] [ "b" "b|" <regexp> matches? ] unit-test
[ t ] [ "" "b|" <regexp> matches? ] unit-test
[ t ] [ "" "b|" <regexp> matches? ] unit-test
[ f ] [ "" "|" <regexp> matches? ] unit-test
[ f ] [ "" "|||||||" <regexp> matches? ] unit-test
[ t ] [ "" "|" <regexp> matches? ] unit-test
[ t ] [ "" "|||||||" <regexp> matches? ] unit-test
[ f ] [ "aa" "a|b|c" <regexp> matches? ] unit-test
[ f ] [ "bb" "a|b|c" <regexp> matches? ] unit-test
@ -44,9 +48,9 @@ IN: regexp-tests
! Dotall mode -- when on, . matches newlines.
! Off by default.
[ f ] [ "\n" "." <regexp> matches? ] unit-test
[ t ] [ "\n" "(?s)." <regexp> matches? ] unit-test
[ t ] [ "\n" "(?s:.)" <regexp> matches? ] unit-test
[ t ] [ "\n" R/ ./s matches? ] unit-test
[ f ] [ "\n\n" "(?s).(?-s)." <regexp> matches? ] unit-test
[ f ] [ "\n\n" "(?s:.)." <regexp> matches? ] unit-test
[ f ] [ "" ".+" <regexp> matches? ] unit-test
[ t ] [ "a" ".+" <regexp> matches? ] unit-test
@ -76,8 +80,6 @@ IN: regexp-tests
[ t ] [ "bar" "foo|bar" <regexp> matches? ] unit-test
[ f ] [ "foobar" "foo|bar" <regexp> matches? ] unit-test
/*
! FIXME
[ f ] [ "" "(a)" <regexp> matches? ] unit-test
[ t ] [ "a" "(a)" <regexp> matches? ] unit-test
[ f ] [ "aa" "(a)" <regexp> matches? ] unit-test
@ -85,7 +87,6 @@ IN: regexp-tests
[ f ] [ "aababaaabbac" "(a|b)+" <regexp> matches? ] unit-test
[ t ] [ "ababaaabba" "(a|b)+" <regexp> matches? ] unit-test
*/
[ f ] [ "" "a{1}" <regexp> matches? ] unit-test
[ t ] [ "a" "a{1}" <regexp> matches? ] unit-test
@ -168,12 +169,9 @@ IN: regexp-tests
[ f ] [ "0" "[^\\d]" <regexp> matches? ] unit-test
[ t ] [ "a" "[^\\d]" <regexp> matches? ] unit-test
/*
! FIXME
[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" <regexp> matches? ] unit-test
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" <regexp> matches? ] unit-test
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" <regexp> matches? ] unit-test
*/
[ t ] [ "1000" "\\d{4,6}" <regexp> matches? ] unit-test
[ t ] [ "1000" "[0-9]{4,6}" <regexp> matches? ] unit-test
@ -185,7 +183,7 @@ IN: regexp-tests
[ f ] [ "abc" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
[ t ] [ "ABC" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
[ f ] [ "" "\\Q\\E" <regexp> matches? ] unit-test
[ t ] [ "" "\\Q\\E" <regexp> matches? ] unit-test
[ f ] [ "a" "\\Q\\E" <regexp> matches? ] unit-test
[ t ] [ "|*+" "\\Q|*+\\E" <regexp> matches? ] unit-test
[ f ] [ "abc" "\\Q|*+\\E" <regexp> matches? ] unit-test
@ -195,8 +193,8 @@ IN: regexp-tests
[ t ] [ "SXY" "\\0123XY" <regexp> matches? ] unit-test
[ t ] [ "x" "\\x78" <regexp> matches? ] unit-test
[ f ] [ "y" "\\x78" <regexp> matches? ] unit-test
[ t ] [ "x" "\\u000078" <regexp> matches? ] unit-test
[ f ] [ "y" "\\u000078" <regexp> matches? ] unit-test
[ t ] [ "x" "\\u0078" <regexp> matches? ] unit-test
[ f ] [ "y" "\\u0078" <regexp> matches? ] unit-test
[ t ] [ "ab" "a+b" <regexp> matches? ] unit-test
[ f ] [ "b" "a+b" <regexp> matches? ] unit-test
@ -214,8 +212,8 @@ IN: regexp-tests
[ f ] [ "aaaxb" "a+ab" <regexp> matches? ] unit-test
[ t ] [ "aaacb" "a+cb" <regexp> matches? ] unit-test
[ 3 ] [ "aaacb" "a*" <regexp> match-head ] unit-test
[ 2 ] [ "aaacb" "aa?" <regexp> match-head ] unit-test
[ 3 ] [ "aaacb" "a*" <regexp> match-index-head ] unit-test
[ 2 ] [ "aaacb" "aa?" <regexp> match-index-head ] unit-test
[ t ] [ "aaa" R/ AAA/i matches? ] unit-test
[ f ] [ "aax" R/ AAA/i matches? ] unit-test
@ -226,15 +224,15 @@ IN: regexp-tests
[ t ] [ "c" R/ [A-Z]/i matches? ] unit-test
[ f ] [ "3" R/ [A-Z]/i matches? ] unit-test
[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
[ t ] [ "a" "(?i:a)" <regexp> matches? ] unit-test
[ t ] [ "a" "(?i:a)" <regexp> matches? ] unit-test
[ t ] [ "A" "(?i:a)" <regexp> matches? ] unit-test
[ t ] [ "A" "(?i:a)" <regexp> matches? ] unit-test
[ t ] [ "a" R/ (?-i)a/i matches? ] unit-test
[ t ] [ "a" R/ (?-i)a/i matches? ] unit-test
[ f ] [ "A" R/ (?-i)a/i matches? ] unit-test
[ f ] [ "A" R/ (?-i)a/i matches? ] unit-test
[ t ] [ "a" R/ (?-i:a)/i matches? ] unit-test
[ t ] [ "a" R/ (?-i:a)/i matches? ] unit-test
[ f ] [ "A" R/ (?-i:a)/i matches? ] unit-test
[ f ] [ "A" R/ (?-i:a)/i matches? ] unit-test
[ f ] [ "A" "[a-z]" <regexp> matches? ] unit-test
[ t ] [ "A" R/ [a-z]/i matches? ] unit-test
@ -242,9 +240,11 @@ IN: regexp-tests
[ f ] [ "A" "\\p{Lower}" <regexp> matches? ] unit-test
[ t ] [ "A" R/ \p{Lower}/i matches? ] unit-test
[ t ] [ "abc" <reversed> R/ abc/r matches? ] unit-test
[ t ] [ "abc" <reversed> R/ a[bB][cC]/r matches? ] unit-test
! [ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/ matches? ] unit-test ! FIXME
[ t ] [ "abc" reverse R/ abc/r matches? ] unit-test
[ t ] [ "abc" reverse R/ a[bB][cC]/r matches? ] unit-test
[ t ] [ 3 "xabc" R/ abc/ <reverse-matcher> match-index-from >boolean ] unit-test
[ t ] [ 3 "xabc" R/ a[bB][cC]/ <reverse-matcher> match-index-from >boolean ] unit-test
[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
@ -253,8 +253,6 @@ IN: regexp-tests
[ t ] [ "abc*" "[^\\*]*\\*" <regexp> matches? ] unit-test
[ t ] [ "bca" "[^a]*a" <regexp> matches? ] unit-test
/*
! FIXME
[ ] [
"(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
<regexp> drop
@ -271,18 +269,13 @@ IN: regexp-tests
[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test
[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> match-head >string ] unit-test
[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> match-head >string ] unit-test
[ "ab" ] [ "ab" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
[ "ab" ] [ "ab" "(ab|a)(bc)?" <regexp> match-head >string ] unit-test
[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> match-head >string ] unit-test
[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
*/
! [ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
! [ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> match-head >string ] unit-test
[ { "1" "2" "3" "4" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
@ -308,90 +301,129 @@ IN: regexp-tests
[ "-- title --" ] [ "== title ==" R/ =/ "-" re-replace ] unit-test
/*
! FIXME
[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
[ "" ] [ "ab" "a(?!b)" <regexp> match-head >string ] unit-test
[ "a" ] [ "ac" "a(?!b)" <regexp> match-head >string ] unit-test
[ t ] [ "fxxbar" ".{3}(?!foo)bar" <regexp> matches? ] unit-test
[ t ] [ "foobar" ".{3}(?!foo)bar" <regexp> matches? ] unit-test
[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
[ "a" ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match >string ] unit-test
[ "a" ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match >string ] unit-test
[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> match-head >string ] unit-test
[ "a" ] [ "ba" "(?<=b)(?<=b)a" <regexp> match-head >string ] unit-test
[ "a" ] [ "cab" "(?<=c)a(?=b)" <regexp> match-head >string ] unit-test
[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
*/
[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-index-head ] unit-test
[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-index-head ] unit-test
! Bug in parsing word
[ t ] [ "a" R' a' matches? ] unit-test
! Convert to lowercase until E
[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test
[ t ] [ "aa" R/ \LAA\E/ matches? ] unit-test
! Testing negation
[ f ] [ "a" R/ (?~a)/ matches? ] unit-test
[ t ] [ "aa" R/ (?~a)/ matches? ] unit-test
[ t ] [ "bb" R/ (?~a)/ matches? ] unit-test
[ t ] [ "" R/ (?~a)/ matches? ] unit-test
! Convert to uppercase until E
[ t ] [ "AA" R/ \Uaa\E/ matches? ] unit-test
[ f ] [ "aa" R/ \Uaa\E/ matches? ] unit-test
[ f ] [ "a" R/ (?~a+|b)/ matches? ] unit-test
[ f ] [ "aa" R/ (?~a+|b)/ matches? ] unit-test
[ t ] [ "bb" R/ (?~a+|b)/ matches? ] unit-test
[ f ] [ "b" R/ (?~a+|b)/ matches? ] unit-test
[ t ] [ "" R/ (?~a+|b)/ matches? ] unit-test
! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
! Intersecting classes
[ t ] [ "ab" R/ ac|\p{Lower}b/ matches? ] unit-test
[ t ] [ "ab" R/ ac|[a-z]b/ matches? ] unit-test
[ t ] [ "ac" R/ ac|\p{Lower}b/ matches? ] unit-test
[ t ] [ "ac" R/ ac|[a-z]b/ matches? ] unit-test
[ t ] [ "ac" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
[ t ] [ "ab" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
[ t ] [ "πb" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
[ f ] [ "πc" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
[ f ] [ "Ab" R/ [a-zA-Z]c|\p{Lower}b/ matches? ] unit-test
! [ t ] [ "a" R/ ^a/ matches? ] unit-test
! [ f ] [ "\na" R/ ^a/ matches? ] unit-test
! [ f ] [ "\r\na" R/ ^a/ matches? ] unit-test
! [ f ] [ "\ra" R/ ^a/ matches? ] unit-test
[ t ] [ "aaaa" R/ .*a./ matches? ] unit-test
! [ t ] [ "a" R/ a$/ matches? ] unit-test
! [ f ] [ "a\n" R/ a$/ matches? ] unit-test
! [ f ] [ "a\r" R/ a$/ matches? ] unit-test
! [ f ] [ "a\r\n" R/ a$/ matches? ] unit-test
! DFA is compiled when needed, or when literal
[ f ] [ "foo" <regexp> dfa>> >boolean ] unit-test
[ t ] [ R/ foo/ dfa>> >boolean ] unit-test
! [ t ] [ "a" R/ a$|b$/ matches? ] unit-test
! [ t ] [ "b" R/ a$|b$/ matches? ] unit-test
! [ t ] [ "ab" R/ a$|b$/ matches? ] unit-test
! [ t ] [ "ba" R/ ba$|b$/ matches? ] unit-test
[ t ] [ "a" R/ ^a/ matches? ] unit-test
[ f ] [ "\na" R/ ^a/ matches? ] unit-test
[ f ] [ "\r\na" R/ ^a/ matches? ] unit-test
[ f ] [ "\ra" R/ ^a/ matches? ] unit-test
! [ t ] [ "a" R/ \Aa/ matches? ] unit-test
! [ f ] [ "\na" R/ \Aaa/ matches? ] unit-test
! [ f ] [ "\r\na" R/ \Aa/ matches? ] unit-test
! [ f ] [ "\ra" R/ \Aa/ matches? ] unit-test
[ 1 ] [ "a" R/ ^a/ count-matches ] unit-test
[ 0 ] [ "\na" R/ ^a/ count-matches ] unit-test
[ 0 ] [ "\r\na" R/ ^a/ count-matches ] unit-test
[ 0 ] [ "\ra" R/ ^a/ count-matches ] unit-test
! [ t ] [ "a" R/ \Aa/m matches? ] unit-test
! [ f ] [ "\na" R/ \Aaa/m matches? ] unit-test
! [ f ] [ "\r\na" R/ \Aa/m matches? ] unit-test
! [ f ] [ "\ra" R/ \Aa/m matches? ] unit-test
[ t ] [ "a" R/ a$/ matches? ] unit-test
[ f ] [ "a\n" R/ a$/ matches? ] unit-test
[ f ] [ "a\r" R/ a$/ matches? ] unit-test
[ f ] [ "a\r\n" R/ a$/ matches? ] unit-test
! [ t ] [ "\r\n\n\n\nam" R/ ^am/m matches? ] unit-test
[ 1 ] [ "a" R/ a$/ count-matches ] unit-test
[ 0 ] [ "a\n" R/ a$/ count-matches ] unit-test
[ 0 ] [ "a\r" R/ a$/ count-matches ] unit-test
[ 0 ] [ "a\r\n" R/ a$/ count-matches ] unit-test
! [ t ] [ "a" R/ \Aa\z/m matches? ] unit-test
! [ f ] [ "a\n" R/ \Aa\z/m matches? ] unit-test
[ t ] [ "a" R/ a$|b$/ matches? ] unit-test
[ t ] [ "b" R/ a$|b$/ matches? ] unit-test
[ f ] [ "ab" R/ a$|b$/ matches? ] unit-test
[ t ] [ "ba" R/ ba$|b$/ matches? ] unit-test
! [ t ] [ "a\r\n" R/ \Aa\Z/m matches? ] unit-test
! [ t ] [ "a\n" R/ \Aa\Z/m matches? ] unit-test
[ t ] [ "a" R/ \Aa/ matches? ] unit-test
[ f ] [ "\na" R/ \Aaa/ matches? ] unit-test
[ f ] [ "\r\na" R/ \Aa/ matches? ] unit-test
[ f ] [ "\ra" R/ \Aa/ matches? ] unit-test
! [ t ] [ "a" R/ \Aa\Z/m matches? ] unit-test
! [ f ] [ "\na" R/ \Aaa\Z/m matches? ] unit-test
! [ f ] [ "\r\na" R/ \Aa\Z/m matches? ] unit-test
! [ f ] [ "\ra" R/ \Aa\Z/m matches? ] unit-test
[ t ] [ "a" R/ \Aa/m matches? ] unit-test
[ f ] [ "\na" R/ \Aaa/m matches? ] unit-test
[ f ] [ "\r\na" R/ \Aa/m matches? ] unit-test
[ f ] [ "\ra" R/ \Aa/m matches? ] unit-test
[ 0 ] [ "\ra" R/ \Aa/m count-matches ] unit-test
! [ t ] [ "a" R/ ^a/m matches? ] unit-test
! [ t ] [ "\na" R/ ^a/m matches? ] unit-test
! [ t ] [ "\r\na" R/ ^a/m matches? ] unit-test
! [ t ] [ "\ra" R/ ^a/m matches? ] unit-test
[ f ] [ "\r\n\n\n\nam" R/ ^am/m matches? ] unit-test
[ 1 ] [ "\r\n\n\n\nam" R/ ^am/m count-matches ] unit-test
! [ t ] [ "a" "a$" R/ a$/m matches? ] unit-test
! [ t ] [ "a\n" "a$" R/ a$/m matches? ] unit-test
! [ t ] [ "a\r" "a$" R/ a$/m matches? ] unit-test
! [ t ] [ "a\r\n" "a$" R/ a$/m matches? ] unit-test
[ t ] [ "a" R/ \Aa\z/m matches? ] unit-test
[ f ] [ "a\n" R/ \Aa\z/m matches? ] unit-test
! [ f ] [ "foobxr" "foo\\z" <regexp> match-head ] unit-test
! [ 3 ] [ "foo" "foo\\z" <regexp> match-head ] unit-test
[ f ] [ "a\r\n" R/ \Aa\Z/m matches? ] unit-test
[ f ] [ "a\n" R/ \Aa\Z/m matches? ] unit-test
[ 1 ] [ "a\r\n" R/ \Aa\Z/m count-matches ] unit-test
[ 1 ] [ "a\n" R/ \Aa\Z/m count-matches ] unit-test
[ t ] [ "a" R/ \Aa\Z/m matches? ] unit-test
[ f ] [ "\na" R/ \Aaa\Z/m matches? ] unit-test
[ f ] [ "\r\na" R/ \Aa\Z/m matches? ] unit-test
[ f ] [ "\ra" R/ \Aa\Z/m matches? ] unit-test
[ 1 ] [ "a" R/ \Aa\Z/m count-matches ] unit-test
[ 0 ] [ "\na" R/ \Aaa\Z/m count-matches ] unit-test
[ 0 ] [ "\r\na" R/ \Aa\Z/m count-matches ] unit-test
[ 0 ] [ "\ra" R/ \Aa\Z/m count-matches ] unit-test
[ t ] [ "a" R/ ^a/m matches? ] unit-test
[ f ] [ "\na" R/ ^a/m matches? ] unit-test
[ 1 ] [ "\na" R/ ^a/m count-matches ] unit-test
[ 1 ] [ "\r\na" R/ ^a/m count-matches ] unit-test
[ 1 ] [ "\ra" R/ ^a/m count-matches ] unit-test
[ t ] [ "a" R/ a$/m matches? ] unit-test
[ f ] [ "a\n" R/ a$/m matches? ] unit-test
[ 1 ] [ "a\n" R/ a$/m count-matches ] unit-test
[ 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" <regexp> match-index-head ] unit-test
[ 3 ] [ "foo" "foo\\z" <regexp> match-index-head ] unit-test
! [ t ] [ "foo" "\\bfoo\\b" <regexp> matches? ] unit-test
! [ t ] [ "afoob" "\\Bfoo\\B" <regexp> matches? ] unit-test
! [ t ] [ "afoob" "\\bfoo\\b" <regexp> matches? ] unit-test
! [ f ] [ "foo" "\\Bfoo\\B" <regexp> matches? ] unit-test
! [ 3 ] [ "foo bar" "foo\\b" <regexp> match-head ] unit-test
! [ 3 ] [ "foo bar" "foo\\b" <regexp> match-index-head ] unit-test
! [ f ] [ "fooxbar" "foo\\b" <regexp> matches? ] unit-test
! [ t ] [ "foo" "foo\\b" <regexp> matches? ] unit-test
! [ t ] [ "foo bar" "foo\\b bar" <regexp> matches? ] unit-test
@ -399,18 +431,18 @@ IN: regexp-tests
! [ f ] [ "foo" "foo\\bbar" <regexp> matches? ] unit-test
! [ f ] [ "foo bar" "foo\\B" <regexp> matches? ] unit-test
! [ 3 ] [ "fooxbar" "foo\\B" <regexp> match-head ] unit-test
! [ 3 ] [ "fooxbar" "foo\\B" <regexp> match-index-head ] unit-test
! [ t ] [ "foo" "foo\\B" <regexp> matches? ] unit-test
! [ f ] [ "foo bar" "foo\\B bar" <regexp> matches? ] unit-test
! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
! [ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
! [ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
! [ 1 ] [ "aaacb" "a+?" <regexp> match-index-head ] unit-test
! [ 1 ] [ "aaacb" "aa??" <regexp> match-index-head ] unit-test
! [ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
! [ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
! [ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
! [ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
! [ 3 ] [ "aacb" "aa?c" <regexp> match-index-head ] unit-test
! [ 3 ] [ "aacb" "aa??c" <regexp> match-index-head ] unit-test
! "ab" "a(?=b*)" <regexp> match
! "abbbbbc" "a(?=b*c)" <regexp> match

161
basis/regexp/regexp.factor
View File

@ -1,87 +1,75 @@
! Copyright (C) 2008 Doug Coleman.
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! 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 regexp.backend regexp.utils
regexp.parser regexp.nfa regexp.dfa regexp.traversal
regexp.transition-tables splitting sorting ;
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 ;
IN: regexp
: default-regexp ( string -- regexp )
regexp new
swap >>raw
<transition-table> >>nfa-table
<transition-table> >>dfa-table
<transition-table> >>minimized-table
H{ } clone >>nfa-traversal-flags
H{ } clone >>dfa-traversal-flags
H{ } clone >>options
H{ } clone >>matchers
reset-regexp ;
TUPLE: regexp
{ raw read-only }
{ parse-tree read-only }
{ options read-only }
dfa reverse-dfa ;
: construct-regexp ( regexp -- regexp' )
{
[ parse-regexp ]
[ construct-nfa ]
[ construct-dfa ]
[ ]
} cleave ;
: make-regexp ( string ast -- regexp )
f f <options> 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
: (match) ( string regexp -- dfa-traverser )
<dfa-traverser> do-match ; inline
: <optioned-regexp> ( string options -- regexp )
[ dup parse-regexp ] [ string>options ] bi*
f f regexp boa ;
: match ( string regexp -- slice/f )
(match) return-match ;
: <regexp> ( string -- regexp ) "" <optioned-regexp> ;
: match* ( string regexp -- slice/f captured-groups )
(match) [ return-match ] [ captured-groups>> ] bi ;
: matches? ( string regexp -- ? )
dupd match
[ [ length ] bi@ = ] [ drop f ] if* ;
: match-head ( string regexp -- end/f ) match [ length ] [ f ] if* ;
: match-at ( string m regexp -- n/f finished? )
[
2dup swap length > [ 2drop f f ] [ tail-slice t ] if
] dip swap [ match-head f ] [ 2drop f t ] if ;
: match-range ( string m regexp -- a/f b/f )
3dup match-at over [
drop nip rot drop dupd +
] [
[ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if
] if ;
: first-match ( string regexp -- slice/f )
dupd 0 swap match-range rot over [ <slice> ] [ 3drop f ] if ;
: re-cut ( string regexp -- end/f start )
dupd first-match
[ split1-slice swap ] [ "" like f swap ] if* ;
: (re-split) ( string regexp -- )
over [ [ re-cut , ] keep (re-split) ] [ 2drop ] if ;
: re-split ( string regexp -- seq )
[ (re-split) ] { } make ;
: re-replace ( string regexp replacement -- result )
[ re-split ] dip join ;
: next-match ( string regexp -- end/f match/f )
dupd first-match dup
[ [ split1-slice nip ] keep ] [ 2drop f f ] if ;
: all-matches ( string regexp -- seq )
[ dup ] swap '[ _ next-match ] produce nip harvest ;
: count-matches ( string regexp -- n )
all-matches length ;
TUPLE: reverse-matcher regexp ;
C: <reverse-matcher> reverse-matcher
! Reverse matchers won't work properly with most combinators, for now
<PRIVATE
: get-ast ( regexp -- ast )
[ parse-tree>> ] [ options>> ] bi <with-options> ;
: compile-regexp ( regexp -- regexp )
dup '[ [ _ get-ast ast>dfa dfa>quotation ] unless* ] change-dfa ;
: <reversed-option> ( ast -- reversed )
"r" string>options <with-options> ;
: 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 -- ? )
[
<reversed-option>
ast>dfa dfa>reverse-shortest-quotation
[ [ 1- ] dip ] prepose
] maybe-negated ;
: compile-reverse ( regexp -- regexp )
dup '[
[
_ get-ast <reversed-option>
ast>dfa dfa>reverse-quotation
] unless*
] change-reverse-dfa ;
M: regexp match-index-from
compile-regexp dfa>> <quot-matcher> match-index-from ;
M: reverse-matcher match-index-from
regexp>> compile-reverse reverse-dfa>>
<quot-matcher> match-index-from ;
! The following two should do some caching
: find-regexp-syntax ( string -- prefix suffix )
{
{ "R/ " "/" }
@ -97,28 +85,19 @@ IN: regexp
{ "R| " "|" }
} swap [ subseq? not nip ] curry assoc-find drop ;
: string>options ( string -- options )
[ ch>option dup ] H{ } map>assoc ;
: take-until ( end lexer -- string )
dup skip-blank [
[ index-from ] 2keep
[ swapd subseq ]
[ 2drop 1+ ] 3bi
] change-lexer-column ;
: options>string ( options -- string )
keys [ option>ch ] map natural-sort >string ;
PRIVATE>
: <optioned-regexp> ( string option-string -- regexp )
[ default-regexp ] [ string>options ] bi* >>options
construct-regexp ;
: <regexp> ( string -- regexp ) "" <optioned-regexp> ;
<PRIVATE
: parse-noblank-token ( lexer -- str/f )
dup still-parsing-line? [ (parse-token) ] [ drop f ] if ;
: parsing-regexp ( accum end -- accum )
lexer get dup skip-blank
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
lexer get dup still-parsing-line?
[ (parse-token) ] [ drop f ] if
<optioned-regexp> parsed ;
lexer get [ take-until ] [ parse-noblank-token ] bi
<optioned-regexp> compile-regexp parsed ;
PRIVATE>

65
basis/regexp/transition-tables/transition-tables.factor
View File

@ -1,32 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry hashtables kernel sequences
vectors regexp.utils ;
vectors locals regexp.classes ;
IN: regexp.transition-tables
TUPLE: transition from to obj ;
TUPLE: literal-transition < transition ;
TUPLE: class-transition < transition ;
TUPLE: default-transition < transition ;
TUPLE: literal obj ;
TUPLE: class obj ;
TUPLE: default ;
: make-transition ( from to obj class -- obj )
new
swap >>obj
swap >>to
swap >>from ;
: <literal-transition> ( from to obj -- transition )
literal-transition make-transition ;
: <class-transition> ( from to obj -- transition )
class-transition make-transition ;
: <default-transition> ( from to -- transition )
t default-transition make-transition ;
TUPLE: transition-table transitions start-state final-states ;
: <transition-table> ( -- transition-table )
@ -35,14 +12,38 @@ TUPLE: transition-table transitions start-state final-states ;
H{ } clone >>final-states ;
: maybe-initialize-key ( key hashtable -- )
! Why do we have to do this?
2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ;
: set-transition ( transition hash -- )
#! set the state as a key
2dup [ to>> ] dip maybe-initialize-key
[ [ to>> ] [ obj>> ] [ from>> ] tri ] dip
2dup at* [ 2nip insert-at ]
[ drop [ H{ } clone [ insert-at ] keep ] 2dip set-at ] if ;
:: (set-transition) ( from to obj hash -- )
to condition? [ to hash maybe-initialize-key ] unless
from hash at
[ [ to obj ] dip set-at ]
[ to obj associate from hash set-at ] if* ;
: add-transition ( transition transition-table -- )
transitions>> set-transition ;
: set-transition ( from to obj transition-table -- )
transitions>> (set-transition) ;
:: (add-transition) ( from to obj hash -- )
to hash maybe-initialize-key
from hash at
[ [ to obj ] dip push-at ]
[ to 1vector obj associate from hash set-at ] if* ;
: add-transition ( from to obj transition-table -- )
transitions>> (add-transition) ;
: map-set ( assoc quot -- new-assoc )
'[ drop @ dup ] assoc-map ; inline
: number-transitions ( transitions numbering -- new-transitions )
dup '[
[ _ at ]
[ [ _ condition-at ] assoc-map ] bi*
] assoc-map ;
: transitions-at ( transition-table assoc -- transition-table )
[ clone ] dip
[ '[ _ condition-at ] change-start-state ]
[ '[ [ _ at ] map-set ] change-final-states ]
[ '[ _ number-transitions ] change-transitions ] tri ;

164
basis/regexp/traversal/traversal.factor
View File

@ -1,178 +1,56 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators kernel math
quotations sequences regexp.parser regexp.classes fry arrays
combinators.short-circuit regexp.utils prettyprint regexp.nfa ;
quotations sequences regexp.classes fry arrays regexp.matchers
combinators.short-circuit prettyprint regexp.nfa ;
IN: regexp.traversal
TUPLE: dfa-traverser
dfa-table
traversal-flags
traverse-forward
lookahead-counters
lookbehind-counters
capture-counters
captured-groups
capture-group-index
last-state current-state
current-state
text
match-failed?
start-index current-index
matches ;
current-index
match-index ;
: <dfa-traverser> ( text regexp -- match )
[ dfa-table>> ] [ dfa-traversal-flags>> ] bi
: <dfa-traverser> ( start-index text dfa -- match )
dfa-traverser new
swap >>traversal-flags
swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
swap >>text
t >>traverse-forward
0 >>start-index
0 >>current-index
0 >>capture-group-index
V{ } clone >>matches
V{ } clone >>capture-counters
V{ } clone >>lookbehind-counters
V{ } clone >>lookahead-counters
H{ } clone >>captured-groups ;
swap >>current-index ;
: final-state? ( dfa-traverser -- ? )
[ current-state>> ]
[ dfa-table>> final-states>> ] bi key? ;
: beginning-of-text? ( dfa-traverser -- ? )
current-index>> 0 <= ; inline
: end-of-text? ( dfa-traverser -- ? )
[ current-index>> ] [ text>> length ] bi >= ; inline
: text-finished? ( dfa-traverser -- ? )
{
[ current-state>> empty? ]
[ current-state>> not ]
[ end-of-text? ]
[ match-failed?>> ]
} 1|| ;
: save-final-state ( dfa-straverser -- )
[ current-index>> ] [ matches>> ] bi push ;
: save-final-state ( dfa-traverser -- dfa-traverser )
dup current-index>> >>match-index ;
: match-done? ( dfa-traverser -- ? )
dup final-state? [
dup save-final-state
] when text-finished? ;
: previous-text-character ( dfa-traverser -- ch )
[ text>> ] [ current-index>> 1- ] bi nth ;
: current-text-character ( dfa-traverser -- ch )
[ text>> ] [ current-index>> ] bi nth ;
: next-text-character ( dfa-traverser -- ch )
[ text>> ] [ current-index>> 1+ ] bi nth ;
GENERIC: flag-action ( dfa-traverser flag -- )
M: beginning-of-input flag-action ( dfa-traverser flag -- )
drop
dup beginning-of-text? [ t >>match-failed? ] unless drop ;
M: end-of-input flag-action ( dfa-traverser flag -- )
drop
dup end-of-text? [ t >>match-failed? ] unless drop ;
M: beginning-of-line flag-action ( dfa-traverser flag -- )
drop
dup {
[ beginning-of-text? ]
[ previous-text-character terminator-class class-member? ]
} 1|| [ t >>match-failed? ] unless drop ;
M: end-of-line flag-action ( dfa-traverser flag -- )
drop
dup {
[ end-of-text? ]
[ next-text-character terminator-class class-member? ]
} 1|| [ t >>match-failed? ] unless drop ;
M: word-boundary flag-action ( dfa-traverser flag -- )
drop
dup {
[ end-of-text? ]
[ current-text-character terminator-class class-member? ]
} 1|| [ t >>match-failed? ] unless drop ;
M: lookahead-on flag-action ( dfa-traverser flag -- )
drop
lookahead-counters>> 0 swap push ;
M: lookahead-off flag-action ( dfa-traverser flag -- )
drop
dup lookahead-counters>>
[ drop ] [ pop '[ _ - ] change-current-index drop ] if-empty ;
M: lookbehind-on flag-action ( dfa-traverser flag -- )
drop
f >>traverse-forward
[ 2 - ] change-current-index
lookbehind-counters>> 0 swap push ;
M: lookbehind-off flag-action ( dfa-traverser flag -- )
drop
t >>traverse-forward
dup lookbehind-counters>>
[ drop ] [ pop '[ _ + 2 + ] change-current-index drop ] if-empty ;
M: capture-group-on flag-action ( dfa-traverser flag -- )
drop
[ current-index>> 0 2array ]
[ capture-counters>> ] bi push ;
M: capture-group-off flag-action ( dfa-traverser flag -- )
drop
dup capture-counters>> empty? [
drop
] [
{
[ capture-counters>> pop first2 dupd + ]
[ text>> <slice> ]
[ [ 1+ ] change-capture-group-index capture-group-index>> ]
[ captured-groups>> set-at ]
} cleave
] if ;
: process-flags ( dfa-traverser -- )
[ [ 1+ ] map ] change-lookahead-counters
[ [ 1+ ] map ] change-lookbehind-counters
[ [ first2 1+ 2array ] map ] change-capture-counters
! dup current-state>> .
dup [ current-state>> ] [ traversal-flags>> ] bi
at [ flag-action ] with each ;
dup final-state? [ save-final-state ] when text-finished? ;
: increment-state ( dfa-traverser state -- dfa-traverser )
[
dup traverse-forward>>
[ [ 1+ ] change-current-index ]
[ [ 1- ] change-current-index ] if
dup current-state>> >>last-state
] [ first ] bi* >>current-state ;
>>current-state
[ 1 + ] change-current-index ;
: match-literal ( transition from-state table -- to-state/f )
transitions>> at at ;
: match-class ( transition from-state table -- to-state/f )
transitions>> at* [
[ drop class-member? ] assoc-with assoc-find [ nip ] [ drop ] if
swap '[ drop _ swap class-member? ] assoc-find spin ?
] [ drop ] if ;
: match-default ( transition from-state table -- to-state/f )
[ drop ] 2dip transitions>> at t swap at ;
: match-transition ( obj from-state dfa -- to-state/f )
{ [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
{ [ match-literal ] [ match-class ] } 3|| ;
: setup-match ( match -- obj state dfa-table )
[ [ current-index>> ] [ text>> ] bi nth ]
@ -180,16 +58,12 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
[ dfa-table>> ] tri ;
: do-match ( dfa-traverser -- dfa-traverser )
dup process-flags
dup match-done? [
dup setup-match match-transition
[ increment-state do-match ] when*
] unless ;
: return-match ( dfa-traverser -- slice/f )
dup matches>>
[ drop f ]
[
[ [ text>> ] [ start-index>> ] bi ]
[ peek ] bi* rot <slice>
] if-empty ;
TUPLE: dfa-matcher dfa ;
C: <dfa-matcher> dfa-matcher
M: dfa-matcher match-index-from
dfa>> <dfa-traverser> do-match match-index>> ;

4
basis/regexp/utils/utils-tests.factor
View File

@ -1,4 +0,0 @@
USING: regexp.utils tools.test ;
IN: regexp.utils.tests
[ [ ] [ ] while-changes ] must-infer

64
basis/regexp/utils/utils.factor
View File

@ -1,64 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs io kernel math math.order
namespaces regexp.backend sequences unicode.categories
math.ranges fry combinators.short-circuit vectors ;
IN: regexp.utils
: (while-changes) ( obj quot: ( obj -- obj' ) pred: ( obj -- <=> ) pred-ret -- obj )
[ [ dup slip ] dip pick over call ] dip dupd =
[ 3drop ] [ (while-changes) ] if ; inline recursive
: while-changes ( obj quot pred -- obj' )
pick over call (while-changes) ; inline
: assoc-with ( param assoc quot -- assoc curry )
swapd [ [ -rot ] dip call ] 2curry ; inline
: insert-at ( value key hash -- )
2dup at* [
2nip push
] [
drop
[ dup vector? [ 1vector ] unless ] 2dip set-at
] if ;
: ?insert-at ( value key hash/f -- hash )
[ H{ } clone ] unless* [ insert-at ] keep ;
ERROR: bad-octal number ;
ERROR: bad-hex number ;
: check-octal ( octal -- octal ) dup 255 > [ bad-octal ] when ;
: check-hex ( hex -- hex ) dup number? [ bad-hex ] unless ;
: ascii? ( n -- ? ) 0 HEX: 7f between? ;
: octal-digit? ( n -- ? ) CHAR: 0 CHAR: 7 between? ;
: decimal-digit? ( n -- ? ) CHAR: 0 CHAR: 9 between? ;
: hex-digit? ( n -- ? )
[
[ decimal-digit? ]
[ CHAR: a CHAR: f between? ]
[ CHAR: A CHAR: F between? ]
] 1|| ;
: control-char? ( n -- ? )
[
[ 0 HEX: 1f between? ]
[ HEX: 7f = ]
] 1|| ;
: punct? ( n -- ? )
"!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
: c-identifier-char? ( ch -- ? )
[ [ alpha? ] [ CHAR: _ = ] ] 1|| ;
: java-blank? ( n -- ? )
{
CHAR: \s CHAR: \t CHAR: \n
HEX: b HEX: 7 CHAR: \r
} member? ;
: java-printable? ( n -- ? )
[ [ alpha? ] [ punct? ] ] 1|| ;

15
basis/xmode/catalog/catalog.factor
View File

@ -1,13 +1,14 @@
USING: xmode.loader xmode.utilities xmode.rules namespaces
strings splitting assocs sequences kernel io.files xml memoize
words globs combinators io.encodings.utf8 sorting accessors xml.data ;
words globs combinators io.encodings.utf8 sorting accessors xml.data
xml.traversal xml.syntax ;
IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ;
<TAGS: parse-mode-tag ( modes tag -- )
TAGS: parse-mode-tag ( modes tag -- )
TAG: MODE
TAG: MODE parse-mode-tag
dup "NAME" attr [
mode new {
{ "FILE" f (>>file) }
@ -17,11 +18,9 @@ TAG: MODE
] dip
rot set-at ;
TAGS>
: parse-modes-tag ( tag -- modes )
H{ } clone [
swap child-tags [ parse-mode-tag ] with each
swap children-tags [ parse-mode-tag ] with each
] keep ;
MEMO: modes ( -- modes )
@ -97,8 +96,8 @@ ERROR: mutually-recursive-rulesets ruleset ;
] if ;
: finalize-mode ( rulesets -- )
rule-sets [
dup [ nip finalize-rule-set ] assoc-each
dup rule-sets [
[ nip finalize-rule-set ] assoc-each
] with-variable ;
: load-mode ( name -- rule-sets )

36
basis/xmode/loader/loader.factor
View File

@ -1,56 +1,54 @@
USING: xmode.loader.syntax xmode.tokens xmode.rules
xmode.keyword-map xml.data xml.traversal xml assocs kernel
combinators sequences math.parser namespaces parser
xmode.utilities parser-combinators.regexp io.files accessors ;
xmode.utilities regexp io.files accessors xml.syntax ;
IN: xmode.loader
! Based on org.gjt.sp.jedit.XModeHandler
! RULES and its children
<TAGS: parse-rule-tag ( rule-set tag -- )
TAGS: parse-rule-tag ( rule-set tag -- )
TAG: PROPS
TAG: PROPS parse-rule-tag
parse-props-tag >>props drop ;
TAG: IMPORT
TAG: IMPORT parse-rule-tag
"DELEGATE" attr swap import-rule-set ;
TAG: TERMINATE
TAG: TERMINATE parse-rule-tag
"AT_CHAR" attr string>number >>terminate-char drop ;
RULE: SEQ seq-rule
RULE: SEQ seq-rule parse-rule-tag
shared-tag-attrs delegate-attr literal-start ;
RULE: SEQ_REGEXP seq-rule
RULE: SEQ_REGEXP seq-rule parse-rule-tag
shared-tag-attrs delegate-attr regexp-attr regexp-start ;
RULE: SPAN span-rule
RULE: SPAN span-rule parse-rule-tag
shared-tag-attrs delegate-attr match-type-attr span-attrs parse-begin/end-tags init-span-tag ;
RULE: SPAN_REGEXP span-rule
RULE: SPAN_REGEXP span-rule parse-rule-tag
shared-tag-attrs delegate-attr match-type-attr span-attrs regexp-attr parse-begin/end-tags init-span-tag ;
RULE: EOL_SPAN eol-span-rule
RULE: EOL_SPAN eol-span-rule parse-rule-tag
shared-tag-attrs delegate-attr match-type-attr literal-start init-eol-span-tag ;
RULE: EOL_SPAN_REGEXP eol-span-rule
RULE: EOL_SPAN_REGEXP eol-span-rule parse-rule-tag
shared-tag-attrs delegate-attr match-type-attr regexp-attr regexp-start init-eol-span-tag ;
RULE: MARK_FOLLOWING mark-following-rule
RULE: MARK_FOLLOWING mark-following-rule parse-rule-tag
shared-tag-attrs match-type-attr literal-start ;
RULE: MARK_PREVIOUS mark-previous-rule
RULE: MARK_PREVIOUS mark-previous-rule parse-rule-tag
shared-tag-attrs match-type-attr literal-start ;
TAG: KEYWORDS ( rule-set tag -- key value )
TAG: KEYWORDS parse-rule-tag
rule-set get ignore-case?>> <keyword-map>
swap child-tags [ over parse-keyword-tag ] each
swap children-tags [ over parse-keyword-tag ] each
swap (>>keywords) ;
TAGS>
: ?<regexp> ( string/f -- regexp/f )
dup [ rule-set get ignore-case?>> <regexp> ] when ;
dup [ rule-set get ignore-case?>> <?insensitive-regexp> ] when ;
: (parse-rules-tag) ( tag -- rule-set )
<rule-set> dup rule-set set
@ -66,7 +64,7 @@ TAGS>
: parse-rules-tag ( tag -- rule-set )
[
[ (parse-rules-tag) ] [ child-tags ] bi
[ (parse-rules-tag) ] [ children-tags ] bi
[ parse-rule-tag ] with each
rule-set get
] with-scope ;

24
basis/xmode/loader/syntax/syntax.factor
View File

@ -3,7 +3,7 @@
USING: accessors xmode.tokens xmode.rules xmode.keyword-map
xml.data xml.traversal xml assocs kernel combinators sequences
math.parser namespaces make parser lexer xmode.utilities
parser-combinators.regexp io.files splitting arrays ;
regexp io.files splitting arrays xml.syntax xml.syntax.private ;
IN: xmode.loader.syntax
! Rule tag parsing utilities
@ -11,9 +11,10 @@ IN: xmode.loader.syntax
new swap init-from-tag swap add-rule ; inline
: RULE:
scan scan-word
parse-definition { } make
swap [ (parse-rule-tag) ] 2curry (TAG:) ; parsing
scan scan-word scan-word [
parse-definition { } make
swap [ (parse-rule-tag) ] 2curry
] dip swap define-tag ; parsing
! Attribute utilities
: string>boolean ( string -- ? ) "TRUE" = ;
@ -32,7 +33,7 @@ IN: xmode.loader.syntax
[ "NAME" attr ] [ "VALUE" attr ] bi ;
: parse-props-tag ( tag -- assoc )
child-tags
children-tags
[ parse-prop-tag ] H{ } map>assoc ;
: position-attrs ( tag -- at-line-start? at-whitespace-end? at-word-start? )
@ -46,7 +47,8 @@ IN: xmode.loader.syntax
swap position-attrs <matcher> ;
: parse-regexp-matcher ( tag -- matcher )
dup children>string rule-set get ignore-case?>> <regexp>
dup children>string
rule-set get ignore-case?>> <?insensitive-regexp>
swap position-attrs <matcher> ;
: shared-tag-attrs ( -- )
@ -79,22 +81,20 @@ IN: xmode.loader.syntax
[ parse-literal-matcher >>end drop ] , ;
! SPAN's children
<TAGS: parse-begin/end-tag ( rule tag -- )
TAGS: parse-begin/end-tag ( rule tag -- )
TAG: BEGIN
TAG: BEGIN parse-begin/end-tag
! XXX
parse-literal-matcher >>start drop ;
TAG: END
TAG: END parse-begin/end-tag
! XXX
parse-literal-matcher >>end drop ;
TAGS>
: parse-begin/end-tags ( -- )
[
! XXX: handle position attrs on span tag itself
child-tags [ parse-begin/end-tag ] with each
children-tags [ parse-begin/end-tag ] with each
] , ;
: init-span-tag ( -- ) [ drop init-span ] , ;

19
basis/xmode/marker/marker.factor
View File

@ -4,9 +4,24 @@ 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
parser-combinators.regexp splitting parser-combinators ascii
regexp splitting ascii unicode.case regexp.matchers
ascii combinators.short-circuit accessors ;
! Next two words copied from parser-combinators
! Just like head?, but they optionally ignore case
: string= ( str1 str2 ignore-case -- ? )
[ [ >upper ] bi@ ] when sequence= ;
: string-head? ( str1 str2 ignore-case -- ? )
2over shorter?
[ 3drop f ] [
[
[ nip ]
[ length head-slice ] 2bi
] dip string=
] if ;
! Based on org.gjt.sp.jedit.syntax.TokenMarker
: current-keyword ( -- string )
@ -150,7 +165,7 @@ M: escape-rule handle-rule-start
process-escape? get [
escaped? [ not ] change
position [ + ] change
] [ 2drop ] if ;
] [ drop ] if ;
M: seq-rule handle-rule-start
?end-rule

4
basis/xmode/rules/rules.factor
View File

@ -1,6 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors xmode.tokens xmode.keyword-map kernel
sequences vectors assocs strings memoize unicode.case
parser-combinators.regexp ;
regexp ;
IN: xmode.rules
TUPLE: string-matcher string ignore-case? ;

45
basis/xmode/utilities/utilities-tests.factor
View File

@ -1,45 +1,2 @@
USING: assocs xmode.utilities tools.test ;
IN: xmode.utilities.tests
USING: accessors xmode.utilities tools.test xml xml.data kernel
strings vectors sequences io.files prettyprint assocs
unicode.case ;
TUPLE: company employees type ;
: <company> V{ } clone f company boa ;
: add-employee employees>> push ;
<TAGS: parse-employee-tag
TUPLE: employee name description ;
TAG: employee
employee new
{ { "name" f (>>name) } { f (>>description) } }
init-from-tag swap add-employee ;
TAGS>
\ parse-employee-tag see
: parse-company-tag
[
<company>
{ { "type" >upper (>>type) } }
init-from-tag dup
] keep
children>> [ tag? ] filter
[ parse-employee-tag ] with each ;
[
T{ company f
V{
T{ employee f "Joe" "VP Sales" }
T{ employee f "Jane" "CFO" }
}
"PUBLIC"
}
] [
"vocab:xmode/utilities/test.xml"
file>xml parse-company-tag
] unit-test

24
basis/xmode/utilities/utilities.factor
View File

@ -1,11 +1,10 @@
USING: accessors sequences assocs kernel quotations namespaces
xml.data xml.traversal combinators macros parser lexer words fry ;
xml.data xml.traversal combinators macros parser lexer words fry
regexp ;
IN: xmode.utilities
: implies ( x y -- z ) [ not ] dip or ; inline
: child-tags ( tag -- seq ) children>> [ tag? ] filter ;
: tag-init-form ( spec -- quot )
{
{ [ dup quotation? ] [ [ object get tag get ] prepose ] }
@ -33,20 +32,5 @@ MACRO: (init-from-tag) ( specs -- )
: init-from-tag ( tag tuple specs -- tuple )
over [ (init-from-tag) ] dip ; inline
SYMBOL: tag-handlers
SYMBOL: tag-handler-word
: <TAGS:
CREATE tag-handler-word set
H{ } clone tag-handlers set ; parsing
: (TAG:) ( name quot -- ) swap tag-handlers get set-at ;
: TAG:
scan parse-definition
(TAG:) ; parsing
: TAGS>
tag-handler-word get
tag-handlers get >alist [ [ dup main>> ] dip case ] curry
define ; parsing
: <?insensitive-regexp> ( string ? -- regexp )
"i" "" ? <optioned-regexp> ;

2
core/assocs/assocs.factor
View File

@ -41,7 +41,7 @@ M: assoc assoc-like drop ;
: substituter ( assoc -- quot )
[ ?at drop ] curry ; inline
: with-assoc ( assoc quot: ( value key -- assoc ) -- quot: ( key value -- ) )
: with-assoc ( assoc quot: ( value key assoc -- ) -- quot: ( key value -- ) )
curry [ swap ] prepose ; inline
PRIVATE>

4
extra/benchmark/regex-dna/regex-dna.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors regexp prettyprint io io.encodings.ascii
io.files kernel sequences assocs namespaces ;
USING: accessors regexp.matchers prettyprint io io.encodings.ascii
io.files kernel sequences assocs namespaces regexp ;
IN: benchmark.regex-dna
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=regexdna&lang=ruby&id=1