initial checkin of regexps
Doug Coleman
parent
a342542bc5
commit
a019a64407
|
|
@ -0,0 +1,77 @@
|
|||
USING: regexp tools.test ;
|
||||
IN: regexp-tests
|
||||
|
||||
[ f ] [ "b" "a*" matches? ] unit-test
|
||||
[ t ] [ "" "a*" matches? ] unit-test
|
||||
[ t ] [ "a" "a*" matches? ] unit-test
|
||||
[ t ] [ "aaaaaaa" "a*" matches? ] unit-test
|
||||
[ f ] [ "ab" "a*" matches? ] unit-test
|
||||
|
||||
[ t ] [ "abc" "abc" matches? ] unit-test
|
||||
[ t ] [ "a" "a|b|c" matches? ] unit-test
|
||||
[ t ] [ "b" "a|b|c" matches? ] unit-test
|
||||
[ t ] [ "c" "a|b|c" matches? ] unit-test
|
||||
[ f ] [ "c" "d|e|f" matches? ] unit-test
|
||||
|
||||
[ f ] [ "aa" "a|b|c" matches? ] unit-test
|
||||
[ f ] [ "bb" "a|b|c" matches? ] unit-test
|
||||
[ f ] [ "cc" "a|b|c" matches? ] unit-test
|
||||
[ f ] [ "cc" "d|e|f" matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "a+" matches? ] unit-test
|
||||
[ t ] [ "a" "a+" matches? ] unit-test
|
||||
[ t ] [ "aa" "a+" matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "a?" matches? ] unit-test
|
||||
[ t ] [ "a" "a?" matches? ] unit-test
|
||||
[ f ] [ "aa" "a?" matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "." matches? ] unit-test
|
||||
[ t ] [ "a" "." matches? ] unit-test
|
||||
[ t ] [ "." "." matches? ] unit-test
|
||||
|
||||
[ f ] [ "" ".+" matches? ] unit-test
|
||||
[ t ] [ "a" ".+" matches? ] unit-test
|
||||
[ t ] [ "ab" ".+" matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "a|b*|c+|d?" matches? ] unit-test
|
||||
[ t ] [ "a" "a|b*|c+|d?" matches? ] unit-test
|
||||
[ t ] [ "c" "a|b*|c+|d?" matches? ] unit-test
|
||||
[ t ] [ "cc" "a|b*|c+|d?" matches? ] unit-test
|
||||
[ f ] [ "ccd" "a|b*|c+|d?" matches? ] unit-test
|
||||
[ t ] [ "d" "a|b*|c+|d?" matches? ] unit-test
|
||||
|
||||
[ t ] [ "foo" "foo|bar" matches? ] unit-test
|
||||
[ t ] [ "bar" "foo|bar" matches? ] unit-test
|
||||
[ f ] [ "foobar" "foo|bar" matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "(a)" matches? ] unit-test
|
||||
[ t ] [ "a" "(a)" matches? ] unit-test
|
||||
[ f ] [ "aa" "(a)" matches? ] unit-test
|
||||
[ t ] [ "aa" "(a*)" matches? ] unit-test
|
||||
|
||||
[ f ] [ "aababaaabbac" "(a|b)+" matches? ] unit-test
|
||||
[ t ] [ "ababaaabba" "(a|b)+" matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "a{1}" matches? ] unit-test
|
||||
[ t ] [ "a" "a{1}" matches? ] unit-test
|
||||
[ f ] [ "aa" "a{1}" matches? ] unit-test
|
||||
|
||||
[ f ] [ "a" "a{2,}" matches? ] unit-test
|
||||
[ t ] [ "aaa" "a{2,}" matches? ] unit-test
|
||||
[ t ] [ "aaaa" "a{2,}" matches? ] unit-test
|
||||
[ t ] [ "aaaaa" "a{2,}" matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "a{,2}" matches? ] unit-test
|
||||
[ t ] [ "a" "a{,2}" matches? ] unit-test
|
||||
[ t ] [ "aa" "a{,2}" matches? ] unit-test
|
||||
[ f ] [ "aaa" "a{,2}" matches? ] unit-test
|
||||
[ f ] [ "aaaa" "a{,2}" matches? ] unit-test
|
||||
[ f ] [ "aaaaa" "a{,2}" matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "a{1,3}" matches? ] unit-test
|
||||
[ t ] [ "a" "a{1,3}" matches? ] unit-test
|
||||
[ t ] [ "aa" "a{1,3}" matches? ] unit-test
|
||||
[ t ] [ "aaa" "a{1,3}" matches? ] unit-test
|
||||
[ f ] [ "aaaa" "a{1,3}" matches? ] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,134 @@
|
|||
USING: combinators kernel lazy-lists math math.parser
|
||||
namespaces parser parser-combinators promises sequences
|
||||
strings ;
|
||||
USING: continuations io prettyprint ;
|
||||
IN: regexp
|
||||
|
||||
: 'any-char'
|
||||
"." token [ drop any-char-parser ] <@ ;
|
||||
|
||||
: 'escaped-char'
|
||||
"\\" token any-char-parser &> ;
|
||||
|
||||
: 'ordinary-char'
|
||||
[ "*+?|(){}" member? not ] satisfy ;
|
||||
|
||||
: 'char' 'escaped-char' 'ordinary-char' <|> ;
|
||||
|
||||
: 'string' 'char' <+> [ >string token ] <@ ;
|
||||
|
||||
: 'integer' [ digit? ] satisfy <+> [ string>number ] <@ ;
|
||||
|
||||
: exactly-n ( parser n -- parser' )
|
||||
swap <repetition> and-parser construct-boa ;
|
||||
|
||||
: at-most-n ( parser n -- parser' )
|
||||
dup zero? [
|
||||
2drop epsilon
|
||||
] [
|
||||
2dup exactly-n
|
||||
-rot 1- at-most-n <|>
|
||||
] if ;
|
||||
|
||||
: at-least-n ( parser n -- parser' )
|
||||
dupd exactly-n swap <*> <&> ;
|
||||
|
||||
: from-m-to-n ( parser m n -- parser' )
|
||||
>r [ exactly-n ] 2keep r> swap - at-most-n <&> ;
|
||||
|
||||
DEFER: 'regexp'
|
||||
|
||||
TUPLE: group-result str ;
|
||||
|
||||
C: <group-result> group-result
|
||||
|
||||
: 'grouping'
|
||||
"(" token
|
||||
'regexp' [ [ <group-result> ] <@ ] <@
|
||||
")" token <& &> ;
|
||||
|
||||
: 'term'
|
||||
'any-char'
|
||||
'string' <|>
|
||||
'grouping' <|>
|
||||
<+> [
|
||||
dup length 1 =
|
||||
[ first ] [ and-parser construct-boa ] if
|
||||
] <@ ;
|
||||
|
||||
: 'interval'
|
||||
'term'
|
||||
"{" token
|
||||
'integer' <?> &>
|
||||
"," token <?> <:&:>
|
||||
'integer' <?> <:&:>
|
||||
"}" token <& <&> [
|
||||
first2 dup length {
|
||||
{ 1 [ first exactly-n ] }
|
||||
{ 2 [ first2 dup integer?
|
||||
[ nip at-most-n ]
|
||||
[ drop at-least-n ] if ] }
|
||||
{ 3 [ first3 nip from-m-to-n ] }
|
||||
} case
|
||||
] <@ ;
|
||||
|
||||
: 'character-range'
|
||||
any-char-parser "-" token <& any-char-parser &> ;
|
||||
|
||||
: 'character-class-inside'
|
||||
any-char-parser
|
||||
'character-range' <|> ;
|
||||
|
||||
: 'character-class-inclusive'
|
||||
"[" token
|
||||
'character-class-inside'
|
||||
"]" token ;
|
||||
|
||||
: 'character-class-exclusive'
|
||||
"[^" token
|
||||
'character-class-inside'
|
||||
"]" token ;
|
||||
|
||||
: 'character-class'
|
||||
'character-class-inclusive'
|
||||
'character-class-exclusive' <|> ;
|
||||
|
||||
: 'repetition'
|
||||
'term'
|
||||
[ "*+?" member? ] satisfy <&> [
|
||||
first2 {
|
||||
{ CHAR: * [ <*> ] }
|
||||
{ CHAR: + [ <+> ] }
|
||||
{ CHAR: ? [ <?> ] }
|
||||
} case
|
||||
] <@ ;
|
||||
|
||||
: 'simple' 'term' 'repetition' <|> 'interval' <|> ;
|
||||
|
||||
LAZY: 'union' ( -- parser )
|
||||
'simple'
|
||||
'simple' "|" token 'union' &> <&> [ first2 <|> ] <@
|
||||
<|> ;
|
||||
|
||||
LAZY: 'regexp' ( -- parser )
|
||||
'repetition' 'union' <|> ;
|
||||
|
||||
: <regexp> 'regexp' just parse-1 ;
|
||||
|
||||
|
||||
GENERIC: >regexp ( obj -- parser )
|
||||
M: string >regexp 'regexp' just parse-1 ;
|
||||
M: object >regexp ;
|
||||
|
||||
: matches? ( string regexp -- ? ) >regexp just parse nil? not ;
|
||||
|
||||
: parse-regexp ( accum end -- accum )
|
||||
lexer get dup skip-blank [
|
||||
[ index* dup 1+ swap ] 2keep swapd subseq swap
|
||||
] change-column <regexp> parsed ;
|
||||
|
||||
: R/ CHAR: / parse-regexp ; parsing
|
||||
: R| CHAR: | parse-regexp ; parsing
|
||||
: R" CHAR: " parse-regexp ; parsing
|
||||
: R' CHAR: ' parse-regexp ; parsing
|
||||
: R` CHAR: ` parse-regexp ; parsing
|
||||
Loading…
Reference in New Issue