From d3350bcfdf71b0c1856f30a54a78d9a504a21e9b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 29 Nov 2007 11:18:46 -0600
Subject: [PATCH 1/7] Rename extra/browser to extra/http/parser
---
.../parser}/analyzer/analyzer.factor | 14 +++++++++++---
extra/{browser => http}/parser/parser-tests.factor | 0
extra/{browser => http}/parser/parser.factor | 6 +++---
.../parser}/printer/printer.factor | 4 ++--
.../parser}/utils/utils-tests.factor | 0
extra/{browser => http/parser}/utils/utils.factor | 2 +-
6 files changed, 17 insertions(+), 9 deletions(-)
rename extra/{browser => http/parser}/analyzer/analyzer.factor (88%)
mode change 100644 => 100755
rename extra/{browser => http}/parser/parser-tests.factor (100%)
rename extra/{browser => http}/parser/parser.factor (96%)
rename extra/{browser => http/parser}/printer/printer.factor (97%)
rename extra/{browser => http/parser}/utils/utils-tests.factor (100%)
rename extra/{browser => http/parser}/utils/utils.factor (97%)
diff --git a/extra/browser/analyzer/analyzer.factor b/extra/http/parser/analyzer/analyzer.factor
old mode 100644
new mode 100755
similarity index 88%
rename from extra/browser/analyzer/analyzer.factor
rename to extra/http/parser/analyzer/analyzer.factor
index 2384252e5a..8619377886
--- a/extra/browser/analyzer/analyzer.factor
+++ b/extra/http/parser/analyzer/analyzer.factor
@@ -1,15 +1,23 @@
USING: assocs browser.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 ;
diff --git a/extra/browser/parser/parser-tests.factor b/extra/http/parser/parser-tests.factor
similarity index 100%
rename from extra/browser/parser/parser-tests.factor
rename to extra/http/parser/parser-tests.factor
diff --git a/extra/browser/parser/parser.factor b/extra/http/parser/parser.factor
similarity index 96%
rename from extra/browser/parser/parser.factor
rename to extra/http/parser/parser.factor
index 9ef6113e63..441094ab87 100644
--- a/extra/browser/parser/parser.factor
+++ b/extra/http/parser/parser.factor
@@ -1,8 +1,8 @@
-USING: arrays browser.utils hashtables io kernel namespaces
-prettyprint quotations
+USING: arrays http.parser.utils hashtables io kernel
+namespaces prettyprint quotations
sequences splitting state-parser strings ;
USE: tools.interpreter
-IN: browser.parser
+IN: http.parser
TUPLE: tag name attributes text matched? closing? ;
diff --git a/extra/browser/printer/printer.factor b/extra/http/parser/printer/printer.factor
similarity index 97%
rename from extra/browser/printer/printer.factor
rename to extra/http/parser/printer/printer.factor
index a68d588afb..3df1a76991 100644
--- a/extra/browser/printer/printer.factor
+++ b/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
diff --git a/extra/browser/utils/utils-tests.factor b/extra/http/parser/utils/utils-tests.factor
similarity index 100%
rename from extra/browser/utils/utils-tests.factor
rename to extra/http/parser/utils/utils-tests.factor
diff --git a/extra/browser/utils/utils.factor b/extra/http/parser/utils/utils.factor
similarity index 97%
rename from extra/browser/utils/utils.factor
rename to extra/http/parser/utils/utils.factor
index 827c60d11d..d9fa5cf58a 100644
--- a/extra/browser/utils/utils.factor
+++ b/extra/http/parser/utils/utils.factor
@@ -3,7 +3,7 @@ hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings ;
USING: browser.parser ;
-IN: browser.utils
+IN: http.parser.utils
: string-parse-end?
get-next not ;
From 566326a01ed7671246f06ea199105249b2b04041 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 29 Nov 2007 11:36:30 -0600
Subject: [PATCH 2/7] Let http.parser load
---
extra/http/parser/analyzer/analyzer.factor | 2 +-
extra/http/parser/parser.factor | 1 -
extra/http/parser/utils/utils.factor | 2 +-
3 files changed, 2 insertions(+), 3 deletions(-)
diff --git a/extra/http/parser/analyzer/analyzer.factor b/extra/http/parser/analyzer/analyzer.factor
index 8619377886..ffae26eb8a 100755
--- a/extra/http/parser/analyzer/analyzer.factor
+++ b/extra/http/parser/analyzer/analyzer.factor
@@ -1,4 +1,4 @@
-USING: assocs browser.parser kernel math sequences strings ;
+USING: assocs http.parser kernel math sequences strings ;
IN: http.parser.analyzer
: remove-blank-text ( vector -- vector' )
diff --git a/extra/http/parser/parser.factor b/extra/http/parser/parser.factor
index 441094ab87..77a0580132 100644
--- a/extra/http/parser/parser.factor
+++ b/extra/http/parser/parser.factor
@@ -1,7 +1,6 @@
USING: arrays http.parser.utils hashtables io kernel
namespaces prettyprint quotations
sequences splitting state-parser strings ;
-USE: tools.interpreter
IN: http.parser
TUPLE: tag name attributes text matched? closing? ;
diff --git a/extra/http/parser/utils/utils.factor b/extra/http/parser/utils/utils.factor
index d9fa5cf58a..c8d10a0a2b 100644
--- a/extra/http/parser/utils/utils.factor
+++ b/extra/http/parser/utils/utils.factor
@@ -2,7 +2,7 @@ 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: http.parser.utils
: string-parse-end?
From 22eb4def9d1fe8df9dc24aeaf28f464465707a41 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 30 Nov 2007 19:20:02 -0600
Subject: [PATCH 3/7] Redo escape characters Add octal, hex, control chars,
\t\n\r\f\a\e\w\W, posix character classes
---
extra/regexp/regexp-tests.factor | 14 ++-
extra/regexp/regexp.factor | 168 ++++++++++++++++++++++++-------
2 files changed, 143 insertions(+), 39 deletions(-)
diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor
index 5ebd6dc4d3..c5f8699123 100644
--- a/extra/regexp/regexp-tests.factor
+++ b/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,13 @@ 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
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index 8fdc1bed8b..b5e186b58f 100644
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -4,34 +4,123 @@ promises quotations sequences sequences.lib strings ;
USING: continuations io prettyprint ;
IN: regexp
-: 'any-char'
- "." token [ drop any-char-parser ] <@ ;
+: 1satisfy ( n -- 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: D [ [ digit? not ] ] }
- { CHAR: s [ [ blank? ] ] }
- { CHAR: S [ [ blank? not ] ] }
- { CHAR: \\ [ [ CHAR: \\ = ] ] }
- [ "bad \\, use \\\\ to match a literal \\" throw ]
- } case ;
+ CHAR: \t CHAR: \n CHAR: \r
+ HEX: c HEX: 7 HEX: 1b
+ } member? ;
-: 'escaped-char'
- "\\" token any-char-parser &> [ escaped-char ] <@ ;
+: java-printable? ( n -- ? )
+ dup alpha? swap punct? or ;
-! Must escape to use as literals
-! : meta-chars "[\\^$.|?*+()" ;
-: 'ordinary-char'
- [ "\\^*+?|(){}[" member? not ] satisfy ;
+: 'ordinary-char' ( -- parser )
+ [ "\\^*+?|(){}[" 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 ;
+
+: 'escape-seq' ( -- parser )
+ 'simple-escape-char'
+ 'predefined-char-class' <|>
+ 'octal' <|>
+ 'hex' <|>
+ 'control-character' <|>
+ 'posix-character-class' <|> ;
+
+: 'char' 'escape-seq' 'ordinary-char' <|> ;
: 'string'
- 'char' <+> [
- [ dup quotation? [ satisfy ] [ 1token ] if ] [ <&> ] map-reduce
- ] <@ ;
+ 'char' <+> [ [ <&> ] reduce* ] <@ ;
: exactly-n ( parser n -- parser' )
swap <repetition> and-parser construct-boa ;
@@ -72,28 +161,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'
- 'escaped-char'
+: 'character-class-contents' ( -- parser )
+ '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' <+> <&:>
- [ predicates>cond [ not ] compose satisfy ] <@
- "]" token [ first ] <@ 'character-class-contents' <*> <&:>
- [ predicates>cond satisfy ] <@ <|>
- 'character-class-contents' <+> [ predicates>cond satisfy ] <@ <|>
+ "^" token 'character-class-contents' <+> &> [ t make-character-class ] <@
+ "]" token [ first 1satisfy ] <@ 'character-class-contents' <*> <&:>
+ [ f make-character-class ] <@ <|>
+ 'character-class-contents' <+> [ f make-character-class ] <@ <|>
&>
"]" token <& ;
-: 'term'
- 'any-char'
- 'string' <|>
+: 'term' ( -- parser )
+ 'string'
'grouping' <|>
'character-class' <|>
<+> [
@@ -101,7 +192,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 +201,7 @@ C: <group-result> group-result
'term' "{" token <& 'integer' <&> "," token <& 'integer' <:&> "}" token <&
[ first3 from-m-to-n ] <@ <|> ;
-: 'repetition'
+: 'repetition' ( -- parser )
'term'
[ "*+?" member? ] satisfy <&> [
first2 {
@@ -148,3 +239,8 @@ M: object >regexp ;
: R" CHAR: " parse-regexp ; parsing
: R' CHAR: ' parse-regexp ; parsing
: R` CHAR: ` parse-regexp ; parsing
+
+! \Q \E
+! Must escape to use as literals
+! : meta-chars "[\\^$.|?*+()" ;
+
From cc3e56c1228ebac0e9ea1516bb5b97edb10be6be Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 30 Nov 2007 19:20:38 -0600
Subject: [PATCH 4/7] Add generic to get a predicate out of a parser-combinator
---
.../parser-combinators-tests.factor | 4 +++
.../parser-combinators.factor | 27 ++++++++++++++++++-
2 files changed, 30 insertions(+), 1 deletion(-)
diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor
index 59ef383c87..546eb84c98 100644
--- a/extra/parser-combinators/parser-combinators-tests.factor
+++ b/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
+
diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor
index 04032db19f..7256ad18dd 100755
--- a/extra/parser-combinators/parser-combinators.factor
+++ b/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 ;
+
From 8fadc570fcf720927ba2ee78acec9d1a143748b9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 30 Nov 2007 19:34:17 -0600
Subject: [PATCH 5/7] Add \Q...\E (escape all characters between \Q and \E)
---
extra/regexp/regexp-tests.factor | 5 +++++
extra/regexp/regexp.factor | 11 ++++++-----
2 files changed, 11 insertions(+), 5 deletions(-)
diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor
index c5f8699123..94f9ad172f 100644
--- a/extra/regexp/regexp-tests.factor
+++ b/extra/regexp/regexp-tests.factor
@@ -149,3 +149,8 @@ IN: regexp-tests
[ 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
+
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index b5e186b58f..ba1bd6c32d 100644
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -109,11 +109,17 @@ IN: regexp
{ "\\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' <|> ;
@@ -239,8 +245,3 @@ M: object >regexp ;
: R" CHAR: " parse-regexp ; parsing
: R' CHAR: ' parse-regexp ; parsing
: R` CHAR: ` parse-regexp ; parsing
-
-! \Q \E
-! Must escape to use as literals
-! : meta-chars "[\\^$.|?*+()" ;
-
From db3fbb52b2b5696ca824b690b04ccfcf1bf5c88a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 30 Nov 2007 20:01:59 -0600
Subject: [PATCH 6/7] Add map-until and a unit test for it
---
extra/sequences/lib/lib-tests.factor | 2 ++
extra/sequences/lib/lib.factor | 8 ++++++++
2 files changed, 10 insertions(+)
diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor
index c170a0d20a..e1257748b3 100644
--- a/extra/sequences/lib/lib-tests.factor
+++ b/extra/sequences/lib/lib-tests.factor
@@ -39,3 +39,5 @@ 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
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 33cfe80fcc..0de90b74d6 100644
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -62,3 +62,11 @@ IN: sequences.lib
: delete-random ( seq -- value )
[ length random ] keep [ nth ] 2keep delete-nth ;
+
+: (map-until) ( quot pred -- )
+ [ dup ] swap 3compose
+ [ [ drop t ] [ , f ] if ] compose [ find 2drop ] curry ;
+
+: map-until ( seq quot pred -- )
+ #! Example: { 1 3 5 6 } [ sq ] [ even? ] map-until . -> { 1 9 25 }
+ (map-until) { } make ;
From 159dd697e4726298e17058a70ac46f9608335e5b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 30 Nov 2007 20:23:27 -0600
Subject: [PATCH 7/7] Fix stack effects Add take-while
---
extra/sequences/lib/lib-tests.factor | 1 +
extra/sequences/lib/lib.factor | 10 +++++++---
2 files changed, 8 insertions(+), 3 deletions(-)
diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor
index e1257748b3..82e2b911c3 100644
--- a/extra/sequences/lib/lib-tests.factor
+++ b/extra/sequences/lib/lib-tests.factor
@@ -41,3 +41,4 @@ math.functions tools.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
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 0de90b74d6..e090feffea 100644
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -63,10 +63,14 @@ IN: sequences.lib
: delete-random ( seq -- value )
[ length random ] keep [ nth ] 2keep delete-nth ;
-: (map-until) ( quot pred -- )
+: (map-until) ( quot pred -- quot )
[ dup ] swap 3compose
[ [ drop t ] [ , f ] if ] compose [ find 2drop ] curry ;
-: map-until ( seq quot pred -- )
- #! Example: { 1 3 5 6 } [ sq ] [ even? ] map-until . -> { 1 9 25 }
+: 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 ;