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

New tuple syntax

db4
Slava Pestov 2008-09-05 20:39:45 -05:00
parent d7709d33c4
commit 57ca685e26
16 changed files with 172 additions and 184 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 USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string 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 multiline xml xml.data xml.writer xml.utilities
html.forms html.forms
html.elements 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 USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize parser lexer classes.tuple assocs splitting words arrays memoize parser lexer
io io.files io.encodings.utf8 io.streams.string 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 multiline xml xml.data xml.writer xml.utilities
html.elements html.elements
html.components html.components

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

@ -1,5 +1,5 @@
USING: http.client http.client.private http tools.test USING: http.client http.client.private http tools.test
tuple-syntax namespaces urls ; namespaces urls ;
[ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" 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 [ "www.arc.com" ] [ "http://www.arc.com////" download-name ] unit-test
[ [
TUPLE{ request T{ request
url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" } { url T{ url { protocol "http" } { host "www.apple.com" } { port 80 } { path "/index.html" } } }
method: "GET" { method "GET" }
version: "1.1" { version "1.1" }
cookies: V{ } { cookies V{ } }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } } { header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } }
} }
] [ ] [
"http://www.apple.com/index.html" "http://www.apple.com/index.html"
@ -22,12 +22,12 @@ tuple-syntax namespaces urls ;
] unit-test ] unit-test
[ [
TUPLE{ request T{ request
url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" } { url T{ url { protocol "https" } { host "www.amazon.com" } { port 443 } { path "/index.html" } } }
method: "GET" { method "GET" }
version: "1.1" { version "1.1" }
cookies: V{ } { cookies V{ } }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } } { header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } }
} }
] [ ] [
"https://www.amazon.com/index.html" "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 USING: http http.server http.client tools.test multiline
tuple-syntax io.streams.string io.encodings.utf8 io.streams.string io.encodings.utf8 io.encodings.8-bit
io.encodings.8-bit io.encodings.binary io.encodings.string io.encodings.binary io.encodings.string kernel arrays splitting
kernel arrays splitting sequences assocs io.sockets db db.sqlite sequences assocs io.sockets db db.sqlite continuations urls
continuations urls hashtables accessors ; hashtables accessors ;
IN: http.tests IN: http.tests
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test [ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
@ -24,13 +24,13 @@ blah
; ;
[ [
TUPLE{ request T{ request
url: TUPLE{ url path: "/bar" } { url T{ url path: "/bar" } }
method: "POST" { method "POST" }
version: "1.1" { version "1.1" }
header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } { 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" } { post-data T{ post-data { content "blah" } { raw "blah" } { content-type "application/octet-stream" } } }
cookies: V{ } { cookies V{ } }
} }
] [ ] [
read-request-test-1 lf>crlf [ read-request-test-1 lf>crlf [
@ -62,12 +62,12 @@ Host: www.sex.com
; ;
[ [
TUPLE{ request T{ request
url: TUPLE{ url host: "www.sex.com" path: "/bar" } { url T{ url host: "www.sex.com" path: "/bar" } }
method: "HEAD" { method "HEAD" }
version: "1.1" { version "1.1" }
header: H{ { "host" "www.sex.com" } } { header H{ { "host" "www.sex.com" } } }
cookies: V{ } { cookies V{ } }
} }
] [ ] [
read-request-test-2 lf>crlf [ read-request-test-2 lf>crlf [
@ -103,14 +103,14 @@ blah
; ;
[ [
TUPLE{ response T{ response
version: "1.1" { version "1.1" }
code: 404 { code 404 }
message: "not found" { message "not found" }
header: H{ { "content-type" "text/html; charset=UTF-8" } } { header H{ { "content-type" "text/html; charset=UTF-8" } } }
cookies: { } { cookies { } }
content-type: "text/html" { content-type "text/html" }
content-charset: utf8 { content-charset utf8 }
} }
] [ ] [
read-response-test-1 lf>crlf read-response-test-1 lf>crlf

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

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

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

@ -91,4 +91,8 @@ must-fail-with
] with-compilation-unit ] with-compilation-unit
] unit-test ] 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. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sets namespaces sequences parser 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 IN: classes.tuple.parser
: slot-names ( slots -- seq ) : slot-names ( slots -- seq )
@ -59,9 +60,30 @@ ERROR: invalid-slot-name name ;
dup check-duplicate-slots dup check-duplicate-slots
3dup check-slot-shadowing ; 3dup check-slot-shadowing ;
: literal>tuple ( seq -- tuple ) : parse-slot-value ( -- )
{ scan scan-object 2array , scan "}" assert= ;
{ [ dup length 1 = ] [ first new ] }
{ [ dup second not ] [ [ 2 tail ] [ first ] bi slots>tuple ] } : (parse-slot-values) ( -- )
[ "Not implemented" throw ] parse-slot-value
} cond ; 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 ] 2each
] if-bootstrapping ; inline ] if-bootstrapping ; inline
PRIVATE>
: initial-values ( class -- slots ) : initial-values ( class -- slots )
all-slots [ initial>> ] map ; all-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class ) : pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline [ initial-values over length tail append ] keep ; inline
PRIVATE>
: tuple>array ( tuple -- array ) : tuple>array ( tuple -- array )
prepare-tuple>array prepare-tuple>array
>r copy-tuple-slots r> >r copy-tuple-slots r>

2
core/effects/effects.factor
View File

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

2
core/syntax/syntax.factor
View File

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