Merge commit 'erg/master'

extra/regexp/regexp-tests.factor

@@ -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
+

extra/regexp/regexp.factor

@@ -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