"tuple-layout" "classes.tuple.private" create register-builtin
! Catch-all class for providing a default method.
-! "object" "kernel" create
-! [ f builtins get [ ] filter f union-class define-class ]
-! [ [ drop t ] "predicate" set-word-prop ]
-! bi
-
"object" "kernel" create
[ f f { } intersection-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]
: load-components ( -- )
"include" "exclude"
- [ get-global " " split [ empty? not ] filter ] bi@
+ [ get-global " " split harvest ] bi@
diff
[ "bootstrap." prepend require ] each ;
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
- ] { } make { t } split [ empty? not ] filter ;
+ ] { } make { t } split harvest ;
: flatten-large-struct ( type -- )
heap-size cell align
: balanced? ( in out -- ? )
[ dup [ length - ] [ 2drop f ] if ] 2map
- [ ] filter all-equal? ;
+ sift all-equal? ;
TUPLE: unbalanced-branches-error quots in out ;
2dup balanced? [
over supremum -rot
[ >r dupd r> unify-inputs ] 2map
- [ ] filter unify-stacks
+ sift unify-stacks
rot drop
] [
unbalanced-branches-error
: add-use ( seq -- ) [ use+ ] each ;
: set-use ( seq -- )
- [ vocab-words ] map [ ] filter >vector use set ;
+ [ vocab-words ] V{ } map-as sift use set ;
: check-vocab-string ( name -- name )
dup string?
dup forward-reference? [
drop
use get
- [ at ] with map [ ] filter
+ [ at ] with map sift
[ forward-reference? not ] find nip
] [
nip
2dup 1+ swap ?nth next set
swap nth dup split-before dup , split-after
] with each
- ] { } make { t } split [ empty? not ] filter ;
+ ] { } make { t } split harvest ;
: break-group? ( seq -- ? )
[ first section-fits? ] [ peek section-fits? not ] bi and ;
: remove ( obj seq -- newseq )
[ = not ] with filter ;
+: sift ( seq -- newseq )
+ [ ] filter ;
+
+: harvest ( seq -- newseq )
+ [ empty? not ] filter ;
+
: cache-nth ( i seq quot -- elt )
2over ?nth dup [
>r 3drop r>
{ [ over string? ] [ >r dupd r> short-slot ] }\r
{ [ over array? ] [ long-slot ] }\r
} cond\r
- ] 2map [ ] filter nip ;\r
+ ] 2map sift nip ;\r
\r
: slot-of-reader ( reader specs -- spec/f )\r
[ slot-spec-reader eq? ] with find nip ;\r
: words-named ( str -- seq )
dictionary get values
[ vocab-words at ] with map
- [ ] filter ;
+ sift ;
: child-vocab? ( prefix name -- ? )
2dup = pick empty? or
[ <bunny-fixed-pipeline> ]
[ <bunny-cel-shaded> ]
[ <bunny-outlined> ] tri 3array
- [ ] filter >>draw-seq
+ sift >>draw-seq
0 >>draw-n
drop ;
IN: bunny.model
: numbers ( str -- seq )
- " " split [ string>number ] map [ ] filter ;
+ " " split [ string>number ] map sift ;
: (parse-model) ( vs is -- vs is )
readln [
: parse-list ( ftp-response -- ftp-response )
dup strings>>
- [ " " split [ empty? not ] filter ] map
+ [ " " split harvest ] map
dup length {
{ 9 [ parse-list-9 ] }
{ 8 [ parse-list-8 ] }
: uname ( -- seq )
65536 "char" <c-array> [ (uname) io-error ] keep
- "\0" split [ empty? not ] filter [ >string ] map
+ "\0" split harvest [ >string ] map
6 "" pad-right ;
: sysname ( -- string ) uname first ;
: domainname ( -- string ) uname 5 swap nth ;
: kernel-version ( -- seq )
- release ".-" split [ ] filter 5 "" pad-right ;
+ release ".-" split harvest 5 "" pad-right ;
{ $index [ all-errors ] } ;
ARTICLE: "type-index" "Type index"
-{ $index [ builtins get [ ] filter ] } ;
+{ $index [ builtins get sift ] } ;
ARTICLE: "class-index" "Class index"
{ $index [ classes ] } ;
":vars - list all variables at error time" print ;
: :help ( -- )
- error get delegates [ error-help ] map [ ] filter
+ error get delegates [ error-help ] map sift
{
{ [ dup empty? ] [ (:help-none) ] }
{ [ dup length 1 = ] [ first help ] }
: find-by-attribute-key ( key vector -- vector )
>r >lower r>
[ tag-attributes at ] with filter
- [ ] filter ;
+ sift ;
: find-by-attribute-key-value ( value key vector -- vector )
>r >lower r>
[ tag-attributes at over = ] with filter nip
- [ ] filter ;
+ sift ;
: find-first-attribute-key-value ( value key vector -- i/f tag/f )
>r >lower r>
USING: http.client http.client.private http tools.test
tuple-syntax namespaces ;
-[ "localhost" 80 ] [ "localhost" parse-host ] unit-test
+[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
-[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test
-[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
[ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test
[
TUPLE{ request
+ protocol: http
method: "GET"
host: "www.apple.com"
- path: "/index.html"
port: 80
+ path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } }
<get-request>
] with-scope
] unit-test
+
+[
+ TUPLE{ request
+ protocol: https
+ method: "GET"
+ host: "www.amazon.com"
+ port: 443
+ path: "/index.html"
+ version: "1.1"
+ cookies: V{ }
+ header: H{ { "connection" "close" } }
+ }
+] [
+ [
+ "https://www.amazon.com/index.html"
+ <get-request>
+ ] with-scope
+] unit-test
<PRIVATE
-: parse-url ( url -- resource host port )
- "http://" ?head [ "Only http:// supported" throw ] unless
- "/" split1 [ "/" prepend ] [ "/" ] if*
- swap parse-host ;
-
-: store-path ( request path -- request )
- "?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
-
-: request-with-url ( request url -- request )
- parse-url >r >r store-path r> >>host r> >>port ;
-
SYMBOL: redirects
-: absolute-url? ( url -- ? )
- [ "http://" head? ] [ "https://" head? ] bi or ;
-
: do-redirect ( response data -- response data )
over code>> 300 399 between? [
drop
redirects get max-redirects < [
request get
swap "location" header dup absolute-url?
- [ request-with-url ] [ store-path ] if
+ [ request-with-url ] [ request-with-path ] if
"GET" >>method http-request
] [
too-many-redirects
math.parser calendar calendar.format
io io.streams.string io.encodings.utf8 io.encodings.string
-io.sockets
+io.sockets io.sockets.secure
unicode.case unicode.categories qualified ;
IN: http
-: http-port 80 ; inline
+SINGLETON: http
-: https-port 443 ; inline
+SINGLETON: https
+
+GENERIC: http-port ( protocol -- port )
+
+M: http http-port drop 80 ;
+
+M: https http-port drop 443 ;
+
+GENERIC: protocol>string ( protocol -- string )
+
+M: http protocol>string drop "http" ;
+
+M: https protocol>string drop "https" ;
+
+: string>protocol ( string -- protocol )
+ {
+ { "http" [ http ] }
+ { "https" [ https ] }
+ [ "Unknown protocol: " swap append throw ]
+ } case ;
+
+: absolute-url? ( url -- ? )
+ [ "http://" head? ] [ "https://" head? ] bi or ;
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
[ unparse-cookie ] map concat "; " join ;
TUPLE: request
+protocol
host
port
method
: <request>
request new
"1.1" >>version
- http-port >>port
+ http >>protocol
H{ } clone >>header
H{ } clone >>query
V{ } clone >>cookies
pick query>> set-at ;
: chop-hostname ( str -- str' )
+ ":" split1 nip
CHAR: / over index over length or tail
dup empty? [ drop "/" ] when ;
#! Technically, only proxies are meant to support hostnames
#! in HTTP requests, but IE sends these sometimes so we
#! just chop the hostname part.
- url-decode "http://" ?head [ chop-hostname ] when ;
+ url-decode
+ dup { "http://" "https://" } [ head? ] with contains?
+ [ chop-hostname ] when ;
: read-method ( request -- request )
" " read-until [ "Bad request: method" throw ] unless
: parse-host ( string -- host port )
"." ?tail drop ":" split1
- [ string>number ] [ http-port ] if* ;
+ dup [ string>number ] when ;
: extract-host ( request -- request )
- dup "host" header parse-host >r >>host r> >>port ;
+ dup [ "host" header parse-host ] keep protocol>> http-port or
+ [ >>host ] [ >>port ] bi* ;
: extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ;
dup "cookie" header [ parse-cookies >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes )
- " " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ;
+ " " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
"application/x-www-form-urlencoded" >>post-data-type
] if ;
+GENERIC: protocol-addr ( request protocol -- addr )
+
+M: object protocol-addr
+ drop [ host>> ] [ port>> ] bi <inet> ;
+
+M: https protocol-addr
+ call-next-method <ssl> ;
+
: request-addr ( request -- addr )
- [ host>> ] [ port>> ] bi <inet> ;
+ dup protocol>> protocol-addr ;
: request-host ( request -- string )
- [ host>> ] [ port>> ] bi
- dup 80 = [ drop ] [ ":" swap number>string 3append ] if ;
+ [ host>> ] [ port>> ] bi dup http http-port =
+ [ drop ] [ ":" swap number>string 3append ] if ;
: write-request-header ( request -- request )
dup header>> >hashtable
flush
drop ;
+: request-with-path ( request path -- request )
+ [ "/" prepend ] [ "/" ] if*
+ "?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ;
+
+: request-with-url ( request url -- request )
+ ":" split1
+ [ string>protocol >>protocol ]
+ [
+ "//" ?head [ "Invalid URL" throw ] unless
+ "/" split1
+ [
+ parse-host [ >>host ] [ >>port ] bi*
+ dup protocol>> http-port '[ , or ] change-port
+ ]
+ [ request-with-path ]
+ bi*
+ ] bi* ;
+
: request-url ( request -- url )
[
[
dup host>> [
- [ "http://" write host>> url-encode write ]
- [ ":" write port>> number>string write ]
- bi
+ [ protocol>> protocol>string write "://" write ]
+ [ host>> url-encode write ":" write ]
+ [ port>> number>string write ]
+ tri
] [ drop ] if
]
[ path>> "/" head? [ "/" write ] unless ]
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
: split-path ( string -- path )
- "/" split [ empty? not ] filter ;
+ "/" split harvest ;
: init-request ( -- )
H{ } clone base-paths set
: nth-basis-elt ( generators n -- elt )
over length [
3dup bit? [ nth ] [ 2drop f ] if
- ] map [ ] filter 2nip ;
+ ] map sift 2nip ;
: basis ( generators -- seq )
natural-sort dup length 2^ [ nth-basis-elt ] with map ;
write bl write ": " write print ;\r
\r
: write-message ( msg word-name level -- )\r
- rot [ empty? not ] filter {\r
+ rot harvest {\r
{ [ dup empty? ] [ 3drop ] }\r
{ [ dup length 1 = ] [ first -rot f (write-message) ] }\r
[\r
: search ( string parser -- seq )
any-char-parser [ drop f ] action 2array choice repeat0 parse dup [
- parse-result-ast [ ] filter
+ parse-result-ast sift
] [
drop { }
] if ;
: (replace) ( string parser -- seq )
- any-char-parser 2array choice repeat0 parse parse-result-ast [ ] filter ;
+ any-char-parser 2array choice repeat0 parse parse-result-ast sift ;
: replace ( string parser -- result )
[ (replace) [ tree-write ] each ] with-string-writer ;
>r dup length swap r>
[ = [ ] [ drop f ] if ] curry
2map
- [ ] filter ;
+ sift ;
<PRIVATE
: (attempt-each-integer) ( i n quot -- result )
: vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words r> map
[ [ word? ] filter [ word-vocabulary ] map ] map>set
- remove [ ] filter [ vocab ] map ; inline
+ remove sift [ vocab ] map ; inline
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
: normalized-sizes ( track -- seq )
track-sizes
- [ [ ] filter sum ] keep [ dup [ over / ] when ] map nip ;
+ [ sift sum ] keep [ dup [ over / ] when ] map nip ;
: <track> ( orientation -- track )
<pack> V{ } clone
[ ] [ "w" get com-scroll-down ] unit-test
[ t ] [
"w" get workspace-book gadget-children
- [ tool-scroller ] map [ ] filter [ scroller? ] all?
+ [ tool-scroller ] map sift [ scroller? ] all?
] unit-test
[ ] [ "w" get hide-popup ] unit-test
[ ] [ <gadget> "w" get show-popup ] unit-test
[ blank? ] right-trim ;
: process-other-extend ( lines -- set )
- [ "#" split1 drop ";" split1 drop trim-blank ] map
- [ empty? not ] filter
+ [ "#" split1 drop ";" split1 drop trim-blank ] map harvest
[ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map
concat unique ;
] assoc-map >hashtable ;
: multihex ( hexstring -- string )
- " " split [ hex> ] map [ ] filter ;
+ " " split [ hex> ] map sift ;
TUPLE: code-point lower title upper ;
: parse-script ( stream -- assoc )
! assoc is code point/range => name
- lines [ "#" split1 drop ] map [ empty? not ] filter [
+ lines [ "#" split1 drop ] map harvest [
";" split1 [ [ blank? ] trim ] bi@
] H{ } map>assoc ;
<com-function-definition> ;
: parse-com-functions ( -- functions )
- ";" parse-tokens { ")" } split
- [ empty? not ] filter
+ ";" parse-tokens { ")" } split harvest
[ (parse-com-function) ] map ;
: (iid-word) ( definition -- word )
SYMBOL: width
: line-chunks ( string -- words-lines )
- "\n" split [ " \t" split [ empty? not ] filter ] map ;
+ "\n" split [ " \t" split harvest ] map ;
: (split-chunk) ( words -- )
-1 over [ length + 1+ dup width get > ] find drop nip
projects / factor.git / commitdiff