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

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

db4
Doug Coleman 2008-09-06 00:02:21 -05:00
parent eb5710e009 18cc66f64e
commit 24f0957f96
17 changed files with 196 additions and 187 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/html/templates/chloe/chloe.factor
View File

@ -3,7 +3,7 @@
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
unicode.case tuple-syntax mirrors fry math urls present
unicode.case mirrors fry math urls present
multiline xml xml.data xml.writer xml.utilities
html.forms
html.elements

2
basis/html/templates/chloe/syntax/syntax.factor
View File

@ -4,7 +4,7 @@ IN: html.templates.chloe.syntax
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize parser lexer
io io.files io.encodings.utf8 io.streams.string
unicode.case tuple-syntax mirrors fry math urls
unicode.case mirrors fry math urls
multiline xml xml.data xml.writer xml.utilities
html.elements
html.components

26
basis/http/client/client-tests.factor
View File

@ -1,5 +1,5 @@
USING: http.client http.client.private http tools.test
tuple-syntax namespaces urls ;
namespaces urls ;
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
@ -9,12 +9,12 @@ tuple-syntax namespaces urls ;
[ "www.arc.com" ] [ "http://www.arc.com////" download-name ] unit-test
[
TUPLE{ request
url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" }
method: "GET"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
T{ request
{ url T{ url { protocol "http" } { host "www.apple.com" } { port 80 } { path "/index.html" } } }
{ method "GET" }
{ version "1.1" }
{ cookies V{ } }
{ header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } }
}
] [
"http://www.apple.com/index.html"
@ -22,12 +22,12 @@ tuple-syntax namespaces urls ;
] unit-test
[
TUPLE{ request
url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" }
method: "GET"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
T{ request
{ url T{ url { protocol "https" } { host "www.amazon.com" } { port 443 } { path "/index.html" } } }
{ method "GET" }
{ version "1.1" }
{ cookies V{ } }
{ header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } }
}
] [
"https://www.amazon.com/index.html"

50
basis/http/http-tests.factor
View File

@ -1,8 +1,8 @@
USING: http http.server http.client tools.test multiline
tuple-syntax io.streams.string io.encodings.utf8
io.encodings.8-bit io.encodings.binary io.encodings.string
kernel arrays splitting sequences assocs io.sockets db db.sqlite
continuations urls hashtables accessors ;
io.streams.string io.encodings.utf8 io.encodings.8-bit
io.encodings.binary io.encodings.string kernel arrays splitting
sequences assocs io.sockets db db.sqlite continuations urls
hashtables accessors ;
IN: http.tests
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
@ -24,13 +24,13 @@ blah
;
[
TUPLE{ request
url: TUPLE{ url path: "/bar" }
method: "POST"
version: "1.1"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" }
cookies: V{ }
T{ request
{ url T{ url path: "/bar" } }
{ method "POST" }
{ version "1.1" }
{ header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
{ post-data T{ post-data { content "blah" } { raw "blah" } { content-type "application/octet-stream" } } }
{ cookies V{ } }
}
] [
read-request-test-1 lf>crlf [
@ -62,12 +62,12 @@ Host: www.sex.com
;
[
TUPLE{ request
url: TUPLE{ url host: "www.sex.com" path: "/bar" }
method: "HEAD"
version: "1.1"
header: H{ { "host" "www.sex.com" } }
cookies: V{ }
T{ request
{ url T{ url host: "www.sex.com" path: "/bar" } }
{ method "HEAD" }
{ version "1.1" }
{ header H{ { "host" "www.sex.com" } } }
{ cookies V{ } }
}
] [
read-request-test-2 lf>crlf [
@ -103,14 +103,14 @@ blah
;
[
TUPLE{ response
version: "1.1"
code: 404
message: "not found"
header: H{ { "content-type" "text/html; charset=UTF-8" } }
cookies: { }
content-type: "text/html"
content-charset: utf8
T{ response
{ version "1.1" }
{ code 404 }
{ message "not found" }
{ header H{ { "content-type" "text/html; charset=UTF-8" } } }
{ cookies { } }
{ content-type "text/html" }
{ content-charset utf8 }
}
] [
read-response-test-1 lf>crlf

191
basis/urls/urls-tests.factor
View File

@ -1,7 +1,6 @@
IN: urls.tests
USING: urls urls.private tools.test
tuple-syntax arrays kernel assocs
present accessors ;
arrays kernel assocs present accessors ;
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
@ -30,78 +29,78 @@ present accessors ;
: urls
{
{
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path"
query: H{ { "a" "b" } }
anchor: "foo"
T{ url
{ protocol "http" }
{ host "www.apple.com" }
{ port 1234 }
{ path "/a/path" }
{ query H{ { "a" "b" } } }
{ anchor "foo" }
}
"http://www.apple.com:1234/a/path?a=b#foo"
}
{
TUPLE{ url
protocol: "http"
host: "www.apple.com"
path: "/a/path"
query: H{ { "a" "b" } }
anchor: "foo"
T{ url
{ protocol "http" }
{ host "www.apple.com" }
{ path "/a/path" }
{ query H{ { "a" "b" } } }
{ anchor "foo" }
}
"http://www.apple.com/a/path?a=b#foo"
}
{
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/another/fine/path"
anchor: "foo"
T{ url
{ protocol "http" }
{ host "www.apple.com" }
{ port 1234 }
{ path "/another/fine/path" }
{ anchor "foo" }
}
"http://www.apple.com:1234/another/fine/path#foo"
}
{
TUPLE{ url
path: "/a/relative/path"
anchor: "foo"
T{ url
{ path "/a/relative/path" }
{ anchor "foo" }
}
"/a/relative/path#foo"
}
{
TUPLE{ url
path: "/a/relative/path"
T{ url
{ path "/a/relative/path" }
}
"/a/relative/path"
}
{
TUPLE{ url
path: "a/relative/path"
T{ url
{ path "a/relative/path" }
}
"a/relative/path"
}
{
TUPLE{ url
path: "bar"
query: H{ { "a" "b" } }
T{ url
{ path "bar" }
{ query H{ { "a" "b" } } }
}
"bar?a=b"
}
{
TUPLE{ url
protocol: "ftp"
host: "ftp.kernel.org"
username: "slava"
path: "/"
T{ url
{ protocol "ftp" }
{ host "ftp.kernel.org" }
{ username "slava" }
{ path "/" }
}
"ftp://slava@ftp.kernel.org/"
}
{
TUPLE{ url
protocol: "ftp"
host: "ftp.kernel.org"
username: "slava"
password: "secret"
path: "/"
T{ url
{ protocol "ftp" }
{ host "ftp.kernel.org" }
{ username "slava" }
{ password "secret" }
{ path "/" }
}
"ftp://slava:secret@ftp.kernel.org/"
}
@ -128,94 +127,94 @@ urls [
[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path"
T{ url
{ protocol "http" }
{ host "www.apple.com" }
{ port 1234 }
{ path "/a/path" }
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/foo"
T{ url
{ protocol "http" }
{ host "www.apple.com" }
{ port 1234 }
{ path "/foo" }
}
TUPLE{ url
path: "/a/path"
T{ url
{ path "/a/path" }
}
derive-url
] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
T{ url
{ protocol "http" }
{ host "www.apple.com" }
{ port 1234 }
{ path "/a/path/relative/path" }
{ query H{ { "a" "b" } } }
{ anchor "foo" }
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/"
T{ url
{ protocol "http" }
{ host "www.apple.com" }
{ port 1234 }
{ path "/a/path/" }
}
TUPLE{ url
path: "relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
T{ url
{ path "relative/path" }
{ query H{ { "a" "b" } } }
{ anchor "foo" }
}
derive-url
] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
T{ url
{ protocol "http" }
{ host "www.apple.com" }
{ port 1234 }
{ path "/a/path/relative/path" }
{ query H{ { "a" "b" } } }
{ anchor "foo" }
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/"
T{ url
{ protocol "http" }
{ host "www.apple.com" }
{ port 1234 }
{ path "/a/path/" }
}
TUPLE{ url
path: "relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
T{ url
{ path "relative/path" }
{ query H{ { "a" "b" } } }
{ anchor "foo" }
}
derive-url
] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
path: "/xxx/baz"
T{ url
{ protocol "http" }
{ host "www.apple.com" }
{ path "/xxx/baz" }
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
path: "/xxx/bar"
T{ url
{ protocol "http" }
{ host "www.apple.com" }
{ path "/xxx/bar" }
}
TUPLE{ url
path: "baz"
T{ url
{ path "baz" }
}
derive-url

4
core/classes/tuple/parser/parser-tests.factor
View File

@ -91,4 +91,8 @@ must-fail-with
] with-compilation-unit
] unit-test
TUPLE: syntax-test bar baz ;
[ T{ syntax-test } ] [ T{ syntax-test } ] unit-test
[ T{ syntax-test f { 2 3 } { 4 { 5 } } } ]
[ T{ syntax-test { bar { 2 3 } } { baz { 4 { 5 } } } } ] unit-test

36
core/classes/tuple/parser/parser.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sets namespaces sequences parser
lexer combinators words classes.parser classes.tuple arrays ;
lexer combinators words classes.parser classes.tuple arrays
slots math assocs ;
IN: classes.tuple.parser
: slot-names ( slots -- seq )
@ -59,9 +60,30 @@ ERROR: invalid-slot-name name ;
dup check-duplicate-slots
3dup check-slot-shadowing ;
: literal>tuple ( seq -- tuple )
{
{ [ dup length 1 = ] [ first new ] }
{ [ dup second not ] [ [ 2 tail ] [ first ] bi slots>tuple ] }
[ "Not implemented" throw ]
} cond ;
: parse-slot-value ( -- )
scan scan-object 2array , scan "}" assert= ;
: (parse-slot-values) ( -- )
parse-slot-value
scan {
{ "{" [ (parse-slot-values) ] }
{ "}" [ ] }
} case ;
: parse-slot-values ( -- )
[ (parse-slot-values) ] { } make ;
: boa>tuple ( class slots -- tuple )
swap prefix >tuple ;
: assoc>tuple ( class slots -- tuple )
[ [ ] [ initial-values ] [ all-slots ] tri ] dip
swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map
[ dup <enum> ] dip update boa>tuple ;
: parse-tuple-literal ( -- tuple )
scan-word scan {
{ "f" [ \ } parse-until boa>tuple ] }
{ "{" [ parse-slot-values assoc>tuple ] }
{ "}" [ new ] }
} case ;

4
core/classes/tuple/tuple.factor
View File

@ -48,14 +48,14 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
] 2each
] if-bootstrapping ; inline
PRIVATE>
: initial-values ( class -- slots )
all-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
PRIVATE>
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>

2
core/effects/effects.factor
View File

@ -65,5 +65,5 @@ M: effect clone
: shuffled-values ( shuffle -- values )
out>> [ get ] map ;
: shuffle* ( stack shuffle -- newstack )
: shuffle ( stack shuffle -- newstack )
[ [ load-shuffle ] keep shuffled-values ] with-scope ;

27
core/syntax/syntax-docs.factor
View File

@ -284,10 +284,31 @@ HELP: C{
HELP: T{
{ $syntax "T{ class slots... }" }
{ $values { "class" "a tuple class word" } { "slots" "list of objects" } }
{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } "."
{ $values { "class" "a tuple class word" } { "slots" "slot values" } }
{ $description "Marks the beginning of a literal tuple."
$nl
"The class word must always be specified. If an insufficient number of values is given after the class word, the remaining slots of the tuple are set to " { $link f } ". If too many values are given, they are ignored." } ;
"Three literal syntax forms are recognized:"
{ $list
{ "empty tuple form: if no slot values are specified, then the literal tuple will have all slots set to their initial values (see " { $link "slot-initial-values" } ")." }
{ "BOA-form: if the first element of " { $snippet "slots" } " is " { $snippet "f" } ", then the remaining elements are slot values corresponding to slots in the order in which they are defined in the " { $link POSTPONE: TUPLE: } " form." }
{ "assoc-form: otherwise, " { $snippet "slots" } " is interpreted as a sequence of " { $snippet "{ slot-name value }" } " pairs. The " { $snippet "slot-name" } " should not be quoted." }
}
"BOA form is more concise, whereas assoc form is more readable for larger tuples with many slots, or if only a few slots are to be specified."
$nl
"With BOA form, specifying an insufficient number of values is given after the class word, the remaining slots of the tuple are set to their initial values (see " { $link "slot-initial-values" } "). If too many values are given, an error will be raised." }
{ $examples
"An empty tuple; since vectors have their own literal syntax, the above is equivalent to " { $snippet "V{ }" } ""
{ $code "T{ vector }" }
"A BOA-form tuple:"
{ $code
"USE: colors"
"T{ rgba f 1.0 0.0 0.5 }"
}
"An assoc-form tuple equal to the above:"
{ $code
"USE: colors"
"T{ rgba { red 1.0 } { green 0.0 } { blue 0.5 } }"
} } ;
HELP: W{
{ $syntax "W{ object }" }

2
core/syntax/syntax.factor
View File

@ -83,7 +83,7 @@ IN: bootstrap.syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"T{" [ \ } [ literal>tuple ] parse-literal ] define-syntax
"T{" [ parse-tuple-literal parsed ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
"POSTPONE:" [ scan-word parsed ] define-syntax

1
extra/tuple-syntax/authors.txt
View File

@ -1 +0,0 @@
Daniel Ehrenberg

1
extra/tuple-syntax/summary.txt
View File

@ -1 +0,0 @@
Tuple literals with named slots

1
extra/tuple-syntax/tags.txt
View File

@ -1 +0,0 @@
reflection

8
extra/tuple-syntax/tuple-syntax-docs.factor
View File

@ -1,8 +0,0 @@
USING: help.markup help.syntax ;
IN: tuple-syntax
HELP: TUPLE{
{ $syntax "TUPLE{ class slot-name: value... }" }
{ $values { "class" "a tuple class word" } { "slot-name" "the name of a slot, without the tuple class name" } { "value" "the value for a slot" } }
{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } ". The class word must be specified. Slots which aren't specified are set to f. If slot names are duplicated, the latest one is used." }
{ $see-also POSTPONE: T{ } ;

8
extra/tuple-syntax/tuple-syntax-tests.factor
View File

@ -1,8 +0,0 @@
USING: tools.test tuple-syntax ;
IN: tuple-syntax.tests
TUPLE: foo bar baz ;
[ T{ foo } ] [ TUPLE{ foo } ] unit-test
[ T{ foo f { 2 3 } { 4 { 5 } } } ]
[ TUPLE{ foo bar: { 2 3 } baz: { 4 { 5 } } } ] unit-test

18
extra/tuple-syntax/tuple-syntax.factor
View File

@ -1,18 +0,0 @@
USING: classes.tuple accessors kernel sequences slots parser
lexer words classes slots.private mirrors ;
IN: tuple-syntax
! TUPLE: foo bar baz ;
! TUPLE{ foo bar: 1 baz: 2 }
: parse-slot-writer ( tuple -- slot# )
scan dup "}" = [ 2drop f ] [
but-last swap class all-slots slot-named offset>>
] if ;
: parse-slots ( accum tuple -- accum tuple )
dup parse-slot-writer
[ scan-object pick rot set-slot parse-slots ] when* ;
: TUPLE{
scan-word new parse-slots parsed ; parsing