sift and harvest words added

core/bootstrap/primitives.factor

@@ -160,11 +160,6 @@ bootstrapping? on
 "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 ]

core/bootstrap/stage2.factor

@@ -23,7 +23,7 @@ SYMBOL: bootstrap-time
 
 : load-components ( -- )
     "include" "exclude"
-    [ get-global " " split [ empty? not ] filter ] bi@
+    [ get-global " " split harvest ] bi@
     diff
     [ "bootstrap." prepend require ] each ;
 

core/cpu/x86/64/64.factor

@@ -184,7 +184,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
 : 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

core/inference/backend/backend.factor

@@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ;
 
 : balanced? ( in out -- ? )
     [ dup [ length - ] [ 2drop f ] if ] 2map
-    [ ] filter all-equal? ;
+    sift all-equal? ;
 
 TUPLE: unbalanced-branches-error quots in out ;
 
@@ -281,7 +281,7 @@ 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

core/parser/parser.factor

@@ -207,7 +207,7 @@ SYMBOL: in
 : 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?
@@ -278,7 +278,7 @@ M: no-word-error summary
     dup forward-reference? [
         drop
         use get
-        [ at ] with map [ ] filter
+        [ at ] with map sift
         [ forward-reference? not ] find nip
     ] [
         nip

core/prettyprint/sections/sections.factor

@@ -309,7 +309,7 @@ M: f section-end-group? drop f ;
             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 ;

core/sequences/sequences.factor

@@ -445,6 +445,12 @@ PRIVATE>
 : 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>

core/slots/deprecated/deprecated.factor

@@ -86,7 +86,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
             { [ over string? ] [ >r dupd r> short-slot ] }
             { [ over array? ] [ long-slot ] }
         } cond
-    ] 2map [ ] filter nip ;
+    ] 2map sift nip ;
 
 : slot-of-reader ( reader specs -- spec/f )
     [ slot-spec-reader eq? ] with find nip ;

core/vocabs/vocabs.factor

@@ -76,7 +76,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
 : words-named ( str -- seq )
     dictionary get values
     [ vocab-words at ] with map
-    [ ] filter ;
+    sift ;
 
 : child-vocab? ( prefix name -- ? )
     2dup = pick empty? or

extra/bunny/bunny.factor

@@ -33,7 +33,7 @@ M: bunny-gadget graft* ( gadget -- )
     [ <bunny-fixed-pipeline> ]
     [ <bunny-cel-shaded> ]
     [ <bunny-outlined> ] tri 3array
-    [ ] filter >>draw-seq
+    sift >>draw-seq
     0 >>draw-n
     drop ;
 

extra/bunny/model/model.factor

@@ -6,7 +6,7 @@ float-arrays continuations namespaces sequences.lib accessors ;
 IN: bunny.model
 
 : numbers ( str -- seq )
-    " " split [ string>number ] map [ ] filter ;
+    " " split [ string>number ] map sift ;
 
 : (parse-model) ( vs is -- vs is )
     readln [

extra/ftp/client/client.factor

@@ -130,7 +130,7 @@ TUPLE: remote-file
 
 : 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 ] }

extra/hardware-info/linux/linux.factor

@@ -7,7 +7,7 @@ IN: hardware-info.linux
 
 : 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 ;
@@ -18,4 +18,4 @@ IN: hardware-info.linux
 : domainname ( -- string ) uname 5 swap nth ;
 
 : kernel-version ( -- seq )
-    release ".-" split [ ] filter 5 "" pad-right ;
+    release ".-" split harvest 5 "" pad-right ;

extra/help/handbook/handbook.factor

@@ -238,7 +238,7 @@ ARTICLE: "error-index" "Error index"
 { $index [ all-errors ] } ;
 
 ARTICLE: "type-index" "Type index"
-{ $index [ builtins get [ ] filter ] } ;
+{ $index [ builtins get sift ] } ;
 
 ARTICLE: "class-index" "Class index"
 { $index [ classes ] } ;

extra/help/help.factor

@@ -135,7 +135,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
     ":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 ] }

extra/html/parser/analyzer/analyzer.factor

@@ -77,12 +77,12 @@ IN: html.parser.analyzer
 : 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>

extra/http/client/client-tests.factor

@@ -1,9 +1,7 @@
 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
@@ -12,10 +10,11 @@ tuple-syntax namespaces ;
 
 [
     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" } }
@@ -26,3 +25,21 @@ tuple-syntax namespaces ;
         <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

extra/http/client/client.factor

@@ -19,22 +19,8 @@ DEFER: http-request
 
 <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
@@ -42,7 +28,7 @@ SYMBOL: redirects
         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

extra/http/http.factor

@@ -7,7 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays
 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 ;
 
@@ -15,9 +15,31 @@ EXCLUDE: fry => , ;
 
 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
@@ -212,6 +234,7 @@ TUPLE: cookie name value path domain expires max-age http-only ;
     [ unparse-cookie ] map concat "; " join ;
 
 TUPLE: request
+protocol
 host
 port
 method
@@ -229,7 +252,7 @@ cookies ;
 : <request>
     request new
         "1.1" >>version
-        http-port >>port
+        http >>protocol
         H{ } clone >>header
         H{ } clone >>query
         V{ } clone >>cookies
@@ -242,6 +265,7 @@ cookies ;
     pick query>> set-at ;
 
 : chop-hostname ( str -- str' )
+    ":" split1 nip
     CHAR: / over index over length or tail
     dup empty? [ drop "/" ] when ;
 
@@ -249,7 +273,9 @@ cookies ;
     #! 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
@@ -298,10 +324,11 @@ SYMBOL: max-post-request
 
 : 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 ;
@@ -314,7 +341,7 @@ SYMBOL: max-post-request
     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 ;
@@ -353,12 +380,20 @@ SYMBOL: max-post-request
         "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
+    [ host>> ] [ port>> ] bi dup http http-port =
-    dup 80 = [ drop ] [ ":" swap number>string 3append ] if ;
+    [ drop ] [ ":" swap number>string 3append ] if ;
 
 : write-request-header ( request -- request )
     dup header>> >hashtable
@@ -381,13 +416,32 @@ SYMBOL: max-post-request
     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 ]
+                [ protocol>> protocol>string write "://" write ]
-                [ ":" write port>> number>string write ]
+                [ host>> url-encode write ":" write ]
-                bi
+                [ port>> number>string write ]
+                tri
             ] [ drop ] if
         ]
         [ path>> "/" head? [ "/" write ] unless ]

extra/http/server/server.factor

@@ -240,7 +240,7 @@ SYMBOL: exit-continuation
     '[ exit-continuation set @ ] callcc1 exit-continuation off ;
 
 : split-path ( string -- path )
-    "/" split [ empty? not ] filter ;
+    "/" split harvest ;
 
 : init-request ( -- )
     H{ } clone base-paths set

extra/koszul/koszul.factor

@@ -148,7 +148,7 @@ DEFER: (d)
 : 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 ;

extra/logging/server/server.factor

@@ -37,7 +37,7 @@ SYMBOL: log-files
     write bl write ": " write print ;
 
 : write-message ( msg word-name level -- )
-    rot [ empty? not ] filter {
+    rot harvest {
         { [ dup empty? ] [ 3drop ] }
         { [ dup length 1 = ] [ first -rot f (write-message) ] }
         [

extra/peg/search/search.factor

@@ -17,14 +17,14 @@ MEMO: any-char-parser ( -- parser )
 
 : 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 ;

extra/sequences/lib/lib.factor

@@ -216,7 +216,7 @@ USE: continuations
   >r dup length swap r>
   [ = [ ] [ drop f ] if ] curry
   2map
-  [ ] filter ;
+  sift ;
 
 <PRIVATE
 : (attempt-each-integer) ( i n quot -- result )

extra/tools/vocabs/browser/browser.factor

@@ -106,7 +106,7 @@ C: <vocab-author> vocab-author
 : 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 ;
 

extra/ui/gadgets/tracks/tracks.factor

@@ -8,7 +8,7 @@ TUPLE: track sizes ;
 
 : 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

extra/ui/tools/tools-tests.factor

@@ -17,7 +17,7 @@ IN: ui.tools.tests
 [ ] [ "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

extra/unicode/breaks/breaks.factor

@@ -24,8 +24,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
     [ blank? ] right-trim ;
 
 : process-other-extend ( lines -- set )
-    [ "#" split1 drop ";" split1 drop trim-blank ] map
+    [ "#" split1 drop ";" split1 drop trim-blank ] map harvest
-    [ empty? not ] filter
     [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map
     concat unique ;
 

extra/unicode/data/data.factor

@@ -89,7 +89,7 @@ IN: unicode.data
     ] assoc-map >hashtable ;
 
 : multihex ( hexstring -- string )
-    " " split [ hex> ] map [ ] filter ;
+    " " split [ hex> ] map sift ;
 
 TUPLE: code-point lower title upper ;
 

extra/unicode/script/script.factor

@@ -10,7 +10,7 @@ SYMBOL: interned
 
 : 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 ;
 

extra/windows/com/syntax/syntax.factor

@@ -45,8 +45,7 @@ unless
     <com-function-definition> ;
 
 : parse-com-functions ( -- functions )
-    ";" parse-tokens { ")" } split
+    ";" parse-tokens { ")" } split harvest
-    [ empty? not ] filter
     [ (parse-com-function) ] map ;
 
 : (iid-word) ( definition -- word )

extra/wrap/wrap.factor

@@ -8,7 +8,7 @@ IN: wrap
 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