Merge commit 'erg/master'

extra/http/parser/analyzer/analyzer.factor

@@ -1,15 +1,23 @@
-USING: assocs browser.parser kernel math sequences strings ;
+USING: assocs http.parser kernel math sequences strings ;
-IN: browser.analyzer
+IN: http.parser.analyzer
 
-: remove-blank-text ( vector -- vector )
+: remove-blank-text ( vector -- vector' )
     [
         dup tag-name text = [
-            tag-text [ blank? not ] all?
+            tag-text [ blank? ] all? not
         ] [
             drop t
         ] if
     ] subset ;
 
+: trim-text ( vector -- vector' )
+    [
+        dup tag-name text = [
+            [ tag-text [ blank? ] trim ] keep
+            [ set-tag-text ] keep
+        ] when
+    ] map ;
+
 : find-by-id ( id vector -- vector )
     [ tag-attributes "id" swap at = ] curry* subset ;
 

extra/http/parser/parser.factor

@@ -1,8 +1,7 @@
-USING: arrays browser.utils hashtables io kernel namespaces
+USING: arrays http.parser.utils hashtables io kernel
-prettyprint quotations
+namespaces prettyprint quotations
 sequences splitting state-parser strings ;
-USE: tools.interpreter
+IN: http.parser
-IN: browser.parser
 
 TUPLE: tag name attributes text matched? closing? ;
 

extra/http/parser/printer/printer.factor

@@ -1,9 +1,9 @@
-USING: assocs browser.parser browser.utils combinators
+USING: assocs http.parser browser.utils combinators
 continuations hashtables
 hashtables.private io kernel math
 namespaces prettyprint quotations sequences splitting
 state-parser strings ;
-IN: browser.printer
+IN: http.parser.printer
 
 SYMBOL: no-section
 SYMBOL: html

extra/http/parser/utils/utils.factor

@@ -2,8 +2,8 @@ USING: assocs circular combinators continuations hashtables
 hashtables.private io kernel math
 namespaces prettyprint quotations sequences splitting
 state-parser strings ;
-USING: browser.parser ;
+USING: http.parser ;
-IN: browser.utils
+IN: http.parser.utils
 
 : string-parse-end?
     get-next not ;

extra/parser-combinators/parser-combinators-tests.factor

@@ -151,3 +151,7 @@ IN: scratchpad
 ] unit-test
 
 
+[ "a"  "a" token <!> parse-1 ] unit-test-fails
+[ t ] [ "b"  "a" token <!> parse-1 >boolean ] unit-test
+[ t ] [ "b"  "ab" token <!> parse-1 >boolean ] unit-test
+

extra/parser-combinators/parser-combinators.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: lazy-lists promises kernel sequences strings math
-arrays splitting ;
+arrays splitting quotations combinators ;
 IN: parser-combinators
 
 ! Parser combinator protocol
@@ -21,6 +21,15 @@ TUPLE: parse-result parsed unparsed ;
 
 C: <parse-result> parse-result
 
+: parse-result-parsed-slice ( parse-result -- slice )
+    dup parse-result-parsed empty? [
+        parse-result-unparsed 0 0 rot <slice>
+    ] [
+        dup parse-result-unparsed
+        dup slice-from [ rot parse-result-parsed length - ] keep
+        rot slice-seq <slice>
+    ] if ;
+
 TUPLE: token-parser string ;
 
 C: token token-parser ( string -- parser )
@@ -280,3 +289,19 @@ LAZY: <(+)> ( parser -- parser )
 
 LAZY: surrounded-by ( parser start end -- parser' )
     [ token ] 2apply swapd pack ;
+
+: predicates>cond ( seq -- quot )
+    #! Takes an array of quotation predicates/objects and makes a cond
+    #! Makes a predicate of each obj like so:  [ dup obj = ]
+    #! Leaves quotations alone
+    #! The cond returns a boolean, t if one of the predicates matches
+    [
+        dup callable? [ [ = ] curry ] unless
+        [ dup ] swap compose [ drop t ] 2array
+    ] map { [ t ] [ drop f ] } add [ cond ] curry ;
+
+GENERIC: parser>predicate ( obj -- quot )
+
+M: satisfy-parser parser>predicate ( obj -- quot )
+    satisfy-parser-quot ;
+

extra/regexp/regexp-tests.factor

@@ -29,7 +29,7 @@ IN: regexp-tests
 [ f ] [ "" "." matches? ] unit-test
 [ t ] [ "a" "." matches? ] unit-test
 [ t ] [ "." "." matches? ] unit-test
-[ f ] [ "\n" "." matches? ] unit-test
+! [ f ] [ "\n" "." matches? ] unit-test
 
 [ f ] [ "" ".+" matches? ] unit-test
 [ t ] [ "a" ".+" matches? ] unit-test
@@ -95,7 +95,7 @@ IN: regexp-tests
 [ t ] [ "]" "[]]" matches? ] unit-test
 [ f ] [ "]" "[^]]" matches? ] unit-test
 
-[ "^" "[^]" matches? ] unit-test-fails
+! [ "^" "[^]" matches? ] unit-test-fails
 [ t ] [ "^" "[]^]" matches? ] unit-test
 [ t ] [ "]" "[]^]" matches? ] unit-test
 
@@ -139,5 +139,18 @@ IN: regexp-tests
 [ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" matches? ] unit-test
 
 [ t ] [ "1000" "\\d{4,6}" matches? ] unit-test
-! [ t ] [ "1000" "[0-9]{4,6}" matches? ] unit-test
+[ t ] [ "1000" "[0-9]{4,6}" matches? ] unit-test
+
+[ t ] [ "abc" "\\p{Lower}{3}" matches? ] unit-test
+[ f ] [ "ABC" "\\p{Lower}{3}" matches? ] unit-test
+[ t ] [ "ABC" "\\p{Upper}{3}" matches? ] unit-test
+[ f ] [ "abc" "\\p{Upper}{3}" matches? ] unit-test
+
+[ f ] [ "abc" "[\\p{Upper}]{3}" matches? ] unit-test
+[ t ] [ "ABC" "[\\p{Upper}]{3}" matches? ] unit-test
+
+[ t ] [ "" "\\Q\\E" matches? ] unit-test
+[ f ] [ "a" "\\Q\\E" matches? ] unit-test
+[ t ] [ "|*+" "\\Q|*+\\E" matches? ] unit-test
+[ f ] [ "abc" "\\Q|*+\\E" matches? ] unit-test
 

extra/regexp/regexp.factor

@@ -4,34 +4,129 @@ promises quotations sequences sequences.lib strings ;
 USING: continuations io prettyprint ;
 IN: regexp
 
-: 'any-char'
+: 1satisfy ( n -- parser )
-    "." token [ drop any-char-parser ] <@ ;
+    [ = ] curry satisfy ;
 
-: escaped-char
+: satisfy-token ( string quot -- parser )
+    >r token r> [ satisfy ] curry [ drop ] swap compose <@ ;
+
+: octal-digit? ( n -- ? ) CHAR: 0 CHAR: 7 between? ; inline
+
+: decimal-digit? ( n -- ? ) CHAR: 0 CHAR: 9 between? ; inline
+
+: hex-digit? ( n -- ? )
+    dup decimal-digit?
+    swap CHAR: a CHAR: f between? or ;
+
+: octal? ( str -- ? ) [ octal-digit? ] all? ;
+
+: decimal? ( str -- ? ) [ decimal-digit? ] all? ;
+
+: hex? ( str -- ? ) [ hex-digit? ] all? ;
+
+: control-char? ( n -- ? )
+    dup 0 HEX: 1f between?
+    swap HEX: 7f = or ;
+
+: punct? ( n -- ? )
+    "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
+
+: c-identifier-char? ( ch -- ? )
+    dup alpha? swap CHAR: _ = or ; inline
+
+: c-identifier? ( str -- ? )
+    [ c-identifier-char? ] all? ;
+
+: java-blank? ( n -- ? )
     {
-        { CHAR: d [ [ digit? ] ] }
+        CHAR: \t CHAR: \n CHAR: \r
-        { CHAR: D [ [ digit? not ] ] }
+        HEX: c HEX: 7 HEX: 1b
-        { CHAR: s [ [ blank? ] ] }
+    } member? ;
-        { CHAR: S [ [ blank? not ] ] }
-        { CHAR: \\ [ [ CHAR: \\ = ] ] }
-        [ "bad \\, use \\\\ to match a literal \\" throw ]
-    } case ;
 
-: 'escaped-char'
+: java-printable? ( n -- ? )
-    "\\" token any-char-parser &> [ escaped-char ] <@ ;
+    dup alpha? swap punct? or ;
 
-! Must escape to use as literals
-! : meta-chars "[\\^$.|?*+()" ;
 
-: 'ordinary-char'
+: 'ordinary-char' ( -- parser )
-    [ "\\^*+?|(){}[" member? not ] satisfy ;
+    [ "\\^*+?|(){}[" member? not ] satisfy [ 1satisfy ] <@ ;
 
-: 'char' 'escaped-char' 'ordinary-char' <|> ;
+: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
+
+: 'octal' ( -- parser )
+    "\\0" token
+    'octal-digit'
+    'octal-digit' 'octal-digit' <&> <|>
+    [ CHAR: 0 CHAR: 3 between? ] satisfy
+    'octal-digit' <&> 'octal-digit' <:&> <|>
+    &> just [ oct> 1satisfy ] <@ ;
+
+: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ;
+
+: 'hex' ( -- parser )
+    "\\x" token 'hex-digit' 'hex-digit' <&> &>
+    "\\u" token 'hex-digit' 'hex-digit' <&>
+    'hex-digit' <:&> 'hex-digit' <:&> &> <|> [ hex> 1satisfy ] <@ ;
+
+: 'control-character' ( -- parser )
+    "\\c" token [ LETTER? ] satisfy &> [ 1satisfy ] <@ ;
+
+: 'simple-escape-char' ( -- parser )
+    {
+        { "\\\\" [ CHAR: \\ = ] }
+        { "\\t" [ CHAR: \t = ] }
+        { "\\n" [ CHAR: \n = ] }
+        { "\\r" [ CHAR: \r = ] }
+        { "\\f" [ HEX: c = ] }
+        { "\\a" [ HEX: 7 = ] }
+        { "\\e" [ HEX: 1b = ] }
+    } [ first2 satisfy-token ] [ <|> ] map-reduce ;
+
+: 'predefined-char-class' ( -- parser )
+    {
+        { "." [ drop any-char-parser ] }
+        { "\\d" [ digit? ] }
+        { "\\D" [ digit? not ] }
+        { "\\s" [ java-blank? ] }
+        { "\\S" [ java-blank? not ] }
+        { "\\w" [ c-identifier? ] }
+        { "\\W" [ c-identifier? not ] }
+    } [ first2 satisfy-token ] [ <|> ] map-reduce ;
+
+: 'posix-character-class' ( -- parser )
+    {
+        { "\\p{Lower}" [ letter? ] }
+        { "\\p{Upper}" [ LETTER? ] }
+        { "\\p{ASCII}" [ 0 HEX: 7f between? ] }
+        { "\\p{Alpha}" [ Letter? ] }
+        { "\\p{Digit}" [ digit? ] }
+        { "\\p{Alnum}" [ alpha? ] }
+        { "\\p{Punct}" [ punct? ] }
+        { "\\p{Graph}" [ java-printable? ] }
+        { "\\p{Print}" [ java-printable? ] }
+        { "\\p{Blank}" [ " \t" member? ] }
+        { "\\p{Cntrl}" [ control-char? ] }
+        { "\\p{XDigit}" [ hex-digit? ] }
+        { "\\p{Space}" [ java-blank? ] }
+    } [ first2 satisfy-token ] [ <|> ] map-reduce ;
+
+: 'escaped-seq' ( -- parser )
+    "\\Q" token
+    any-char-parser <*> [ token ] <@ &>
+    "\\E" token <& ;
+
+: 'escape-seq' ( -- parser )
+    'simple-escape-char'
+    'predefined-char-class' <|>
+    'octal' <|>
+    'hex' <|>
+    'escaped-seq' <|>
+    'control-character' <|>
+    'posix-character-class' <|> ;
+
+: 'char' 'escape-seq' 'ordinary-char' <|> ;
 
 : 'string'
-    'char' <+> [
+    'char' <+> [ [ <&> ] reduce* ] <@ ;
-        [ dup quotation? [ satisfy ] [ 1token ] if ] [ <&> ] map-reduce
-    ] <@ ;
 
 : exactly-n ( parser n -- parser' )
     swap <repetition> and-parser construct-boa ;
@@ -72,28 +167,30 @@ C: <group-result> group-result
         [ dup ] swap compose [ drop t ] 2array
     ] map { [ t ] [ drop f ] } add [ cond ] curry ;
 
-: 'range'
+: 'range' ( -- parser )
     any-char-parser "-" token <& any-char-parser <&>
-    [ first2 [ between? ] 2curry ] <@ ;
+    [ first2 [ between? ] 2curry satisfy ] <@ ;
 
-: 'character-class-contents'
+: 'character-class-contents' ( -- parser )
-    'escaped-char'
+    'escape-seq'
     'range' <|>
-    [ "\\]" member? not ] satisfy <|> ;
+    [ "\\]" member? not ] satisfy [ 1satisfy ] <@ <|> ;
 
-: 'character-class'
+: make-character-class ( seq ? -- )
+    >r [ parser>predicate ] map predicates>cond r>
+    [ [ not ] compose ] when satisfy ;
+
+: 'character-class' ( -- parser )
     "[" token
-    "^" token 'character-class-contents' <+> <&:>
+    "^" token 'character-class-contents' <+> &> [ t make-character-class ] <@
-        [ predicates>cond [ not ] compose satisfy ] <@
+    "]" token [ first 1satisfy ] <@ 'character-class-contents' <*> <&:>
-    "]" token [ first ] <@ 'character-class-contents' <*> <&:>
+        [ f make-character-class ] <@ <|>
-        [ predicates>cond satisfy ] <@ <|>
+    'character-class-contents' <+> [ f make-character-class ] <@ <|>
-    'character-class-contents' <+> [ predicates>cond satisfy ] <@ <|>
     &>
     "]" token <& ;
 
-: 'term'
+: 'term' ( -- parser )
-    'any-char'
+    'string'
-    'string' <|>
     'grouping' <|>
     'character-class' <|>
     <+> [
@@ -101,7 +198,7 @@ C: <group-result> group-result
         [ first ] [ and-parser construct-boa ] if
     ] <@ ;
 
-: 'interval'
+: 'interval' ( -- parser )
     'term' "{" token <& 'integer' <&> "}" token <& [ first2 exactly-n ] <@
     'term' "{" token <& 'integer' <&> "," token <& "}" token <&
         [ first2 at-least-n ] <@ <|>
@@ -110,7 +207,7 @@ C: <group-result> group-result
     'term' "{" token <& 'integer' <&> "," token <& 'integer' <:&> "}" token <&
         [ first3 from-m-to-n ] <@ <|> ;
 
-: 'repetition'
+: 'repetition' ( -- parser )
     'term'
     [ "*+?" member? ] satisfy <&> [
         first2 {

extra/sequences/lib/lib-tests.factor

@@ -39,3 +39,6 @@ math.functions tools.test ;
 
 [ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test
 [ V{ } [ delete-random drop ] keep length ] unit-test-fails
+
+[ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test
+[ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test

extra/sequences/lib/lib.factor

@@ -62,3 +62,15 @@ IN: sequences.lib
 
 : delete-random ( seq -- value )
     [ length random ] keep [ nth ] 2keep delete-nth ;
+
+: (map-until) ( quot pred -- quot )
+    [ dup ] swap 3compose
+    [ [ drop t ] [ , f ] if ] compose [ find 2drop ] curry ;
+
+: map-until ( seq quot pred -- newseq )
+    (map-until) { } make ;
+
+: take-while ( seq quot -- newseq )
+    [ not ] compose
+    [ find drop [ head-slice ] when* ] curry
+    [ dup ] swap compose keep like ;