diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 3bf1a527ea..747cfa1128 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -36,7 +36,7 @@ PRIVATE> #! pad string with = when not enough bits dup length dup 3 mod - cut [ 3 [ encode3 ] map concat ] - [ dup empty? [ drop "" ] [ >base64-rem ] if ] + [ [ "" ] [ >base64-rem ] if-empty ] bi* append ; : base64> ( base64 -- str ) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 2388d7b8f0..58ea725d1e 100755 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -50,7 +50,7 @@ SYMBOL: bootstrap-time default-image-name "output-image" set-global - "threads math compiler help io random tools ui ui.tools unicode handbook" "include" set-global + "math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global "" "exclude" set-global parse-command-line diff --git a/basis/channels/channels.factor b/basis/channels/channels.factor index 545d8a0e1d..9b8c418634 100755 --- a/basis/channels/channels.factor +++ b/basis/channels/channels.factor @@ -33,10 +33,10 @@ PRIVATE> M: channel to ( value channel -- ) dup receivers>> - dup empty? [ drop dup wait to ] [ nip (to) ] if ; + [ dup wait to ] [ nip (to) ] if-empty ; M: channel from ( channel -- value ) [ notify senders>> - dup empty? [ drop ] [ (from) ] if + [ (from) ] unless-empty ] curry "channel receive" suspend ; diff --git a/basis/checksums/sha1/sha1.factor b/basis/checksums/sha1/sha1.factor index 0ddb429b28..6aa2cfa2eb 100755 --- a/basis/checksums/sha1/sha1.factor +++ b/basis/checksums/sha1/sha1.factor @@ -120,7 +120,7 @@ M: sha1 checksum-stream ( stream -- sha1 ) : seq>2seq ( seq -- seq1 seq2 ) #! { abcdefgh } -> { aceg } { bdfh } - 2 group flip dup empty? [ drop { } { } ] [ first2 ] if ; + 2 group flip [ { } { } ] [ first2 ] if-empty ; : 2seq>seq ( seq1 seq2 -- seq ) #! { aceg } { bdfh } -> { abcdefgh } diff --git a/basis/compiler/generator/iterator/iterator.factor b/basis/compiler/generator/iterator/iterator.factor index 473d59c3e4..203216b1c0 100644 --- a/basis/compiler/generator/iterator/iterator.factor +++ b/basis/compiler/generator/iterator/iterator.factor @@ -28,18 +28,18 @@ DEFER: (tail-call?) [ first #phi? ] [ rest-slice (tail-call?) ] bi and ; : (tail-call?) ( cursor -- ? ) - dup empty? [ drop t ] [ + [ t ] [ [ first [ #return? ] [ #terminate? ] bi or ] [ tail-phi? ] bi or - ] if ; + ] if-empty ; : tail-call? ( -- ? ) node-stack get [ rest-slice - dup empty? [ drop t ] [ + [ t ] [ [ (tail-call?) ] [ first #terminate? not ] bi and - ] if + ] if-empty ] all? ; diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index 0f81e3805a..b712a6e354 100644 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -32,7 +32,7 @@ M: #shuffle check-node* M: #copy check-node* inputs/outputs 2array check-lengths ; : check->r/r> ( node -- ) - inputs/outputs dup empty? [ 2drop ] [ 2array check-lengths ] if ; + inputs/outputs [ drop ] [ 2array check-lengths ] if-empty ; M: #>r check-node* check->r/r> ; diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index cc5f0619cd..44a6a11802 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -37,8 +37,8 @@ GENERIC: cleanup* ( node -- node/nodes ) [ cleanup* ] map flatten ; : cleanup-folding? ( #call -- ? ) - node-output-infos dup empty? - [ drop f ] [ [ literal?>> ] all? ] if ; + node-output-infos + [ f ] [ [ literal?>> ] all? ] if-empty ; : cleanup-folding ( #call -- nodes ) #! Replace a #call having a known result with a #drop of its diff --git a/basis/compiler/tree/escape-analysis/branches/branches.factor b/basis/compiler/tree/escape-analysis/branches/branches.factor index c44861e45f..b728e9a1ba 100644 --- a/basis/compiler/tree/escape-analysis/branches/branches.factor +++ b/basis/compiler/tree/escape-analysis/branches/branches.factor @@ -15,7 +15,7 @@ M: #branch escape-analysis* : (merge-allocations) ( values -- allocation ) [ - dup [ allocation ] map sift dup empty? [ 2drop f ] [ + dup [ allocation ] map sift [ drop f ] [ dup [ t eq? not ] all? [ dup [ length ] map all-equal? [ nip flip @@ -23,7 +23,7 @@ M: #branch escape-analysis* [ record-allocations ] keep ] [ drop add-escaping-values t ] if ] [ drop add-escaping-values t ] if - ] if + ] if-empty ] map ; : merge-allocations ( in-values out-values -- ) diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index 08481726dc..587dd6938b 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -205,5 +205,5 @@ M: node normalize* ; dup [ collect-label-info ] each-node dup count-introductions make-values [ (normalize) ] [ nip ] 2bi - dup empty? [ drop ] [ #introduce prefix ] if + [ #introduce prefix ] unless-empty rename-node-values ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 8f2220aaaf..0891a6629c 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -237,9 +237,8 @@ DEFER: (value-info-union) } cond ; : value-infos-union ( infos -- info ) - dup empty? - [ drop null-info ] - [ dup first [ value-info-union ] reduce ] if ; + [ null-info ] + [ dup first [ value-info-union ] reduce ] if-empty ; : literals<= ( info1 info2 -- ? ) { diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 2bb3fa0cfc..b6c798ca3c 100755 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -185,7 +185,7 @@ M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ; [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ; : ends-with-terminate? ( nodes -- ? ) - dup empty? [ drop f ] [ peek #terminate? ] if ; + [ f ] [ peek #terminate? ] if-empty ; M: vector child-visitor V{ } clone ; M: vector #introduce, #introduce node, ; diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index eba7f69334..63284b28a3 100755 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -87,11 +87,11 @@ M: postgresql-result-null summary ( obj -- str ) { URL [ dup [ present ] when default-param-value ] } [ drop default-param-value ] } case 2array - ] 2map flip dup empty? [ - drop f f + ] 2map flip [ + f f ] [ first2 [ >c-void*-array ] [ >c-uint-array ] bi* - ] if ; + ] if-empty ; : param-formats ( statement -- seq ) in-params>> [ type>> type>param-format ] map >c-uint-array ; diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index d3b99fcff3..c7fbcd859e 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -136,7 +136,7 @@ ERROR: no-sql-type ; : modifiers ( spec -- string ) modifiers>> [ lookup-modifier ] map " " join - dup empty? [ " " prepend ] unless ; + [ "" ] [ " " prepend ] if-empty ; HOOK: bind% db ( spec -- ) HOOK: bind# db ( spec obj -- ) diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 06c410c0e4..4d01567131 100755 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -48,14 +48,12 @@ M: string error. print ; ] "" make print ; : restarts. ( -- ) - restarts get dup empty? [ - drop - ] [ + restarts get [ nl "The following restarts are available:" print nl [ restart. ] each-index - ] if ; + ] unless-empty ; : print-error ( error -- ) [ error. flush ] curry diff --git a/basis/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor index b2b662db82..f2d53d2362 100644 --- a/basis/farkup/farkup-docs.factor +++ b/basis/farkup/farkup-docs.factor @@ -1,6 +1,51 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax strings io ; IN: farkup HELP: convert-farkup -{ $values { "string" "a string" } { "string'" "a string" } } -{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ; +{ $values { "string" string } { "string'" string } } +{ $description "Parse a Farkup string and convert it to an HTML string." } ; + +HELP: write-farkup +{ $values { "string" string } } +{ $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ; + +HELP: farkup ( string -- farkup ) +{ $values { "string" string } { "farkup" "a Farkup syntax tree node" } } +{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ; + +HELP: (write-farkup) +{ $values { "farkup" "a Farkup syntax tree node" } } +{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ; + +ARTICLE: "farkup-ast" "Farkup syntax tree nodes" +"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "." +{ $subsection heading1 } +{ $subsection heading2 } +{ $subsection heading3 } +{ $subsection heading4 } +{ $subsection strong } +{ $subsection emphasis } +{ $subsection superscript } +{ $subsection subscript } +{ $subsection inline-code } +{ $subsection paragraph } +{ $subsection list-item } +{ $subsection list } +{ $subsection table } +{ $subsection table-row } +{ $subsection link } +{ $subsection image } +{ $subsection code } ; + +ARTICLE: "farkup" "Farkup" +"The " { $vocab-link "farkup" } " vocabulary implements Farkup (Factor mARKUP), a simple markup language. Farkup was loosely based on the markup languages employed by MediaWiki and " { $url "http://reddit.com" } "." +$nl +"The main entry points for converting Farkup to HTML:" +{ $subsection convert-farkup } +{ $subsection write-farkup } +"The syntax tree of a piece of Farkup can also be inspected and modified:" +{ $subsection farkup } +{ $subsection (write-farkup) } +{ $subsection "farkup-ast" } ; + +ABOUT: "farkup" diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index 0f96934798..0280c1a08d 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -1,8 +1,11 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: farkup kernel peg peg.ebnf tools.test ; +USING: farkup kernel peg peg.ebnf tools.test namespaces ; IN: farkup.tests +[ "Baz" ] [ "Foo/Bar/Baz" simple-link-title ] unit-test +[ "Baz" ] [ "Baz" simple-link-title ] unit-test + [ ] [ "abcd-*strong*\nasdifj\nweouh23ouh23" "paragraph" \ farkup rule parse drop @@ -81,10 +84,15 @@ IN: farkup.tests [ "
int main()\n
" ] [ "[c{int main()}]" convert-farkup ] unit-test -[ "

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test -[ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test -[ "

lol.com

" ] [ "[[lol.com]]" convert-farkup ] unit-test -[ "

haha

" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test +[ "

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test +[ "

teh lol

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test +[ "

http://lol.com

" ] [ "[[http://lol.com]]" convert-farkup ] unit-test +[ "

haha

" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test +[ "

Bar

" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test + +"/wiki/view/" relative-link-prefix [ + [ "

Bar

" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test +] with-variable [ ] [ "[{}]" convert-farkup drop ] unit-test diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index baf2ccaba2..154ab0db00 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -28,6 +28,12 @@ TUPLE: link href text ; TUPLE: image href text ; TUPLE: code mode string ; +: absolute-url? ( string -- ? ) + { "http://" "https://" "ftp://" } [ head? ] with contains? ; + +: simple-link-title ( string -- string' ) + dup absolute-url? [ "/" last-split1 swap or ] unless ; + EBNF: farkup nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]] 2nl = nl nl @@ -67,7 +73,7 @@ image-link = "[[image:" (!("|") .)+ "|" (!("]]").)+ "]]" => [[ second >string f image boa ]] simple-link = "[[" (!("|]" | "]]") .)+ "]]" - => [[ second >string dup link boa ]] + => [[ second >string dup simple-link-title link boa ]] labelled-link = "[[" (!("|") .)+ "|" (!("]]").)+ "]]" => [[ [ second >string ] [ fourth >string ] bi link boa ]] @@ -102,7 +108,12 @@ list = ((list-item nl)+ list-item? | list-item) code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]" => [[ [ second >string ] [ fourth >string ] bi code boa ]] -stand-alone = (code | heading | list | table | paragraph | nl)* +simple-code + = "[{" (!("}]").)+ "}]" + => [[ second f swap code boa ]] + +stand-alone + = (code | simple-code | heading | list | table | paragraph | nl)* ;EBNF @@ -114,31 +125,26 @@ stand-alone = (code | heading | list | table | paragraph | nl)* { [ dup empty? ] [ drop invalid-url ] } { [ dup [ 127 > ] contains? ] [ drop invalid-url ] } { [ dup first "/\\" member? ] [ drop invalid-url ] } - { [ CHAR: : over member? ] [ - dup { "http://" "https://" "ftp://" } [ head? ] with contains? - [ drop invalid-url ] unless - ] } + { [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] } [ relative-link-prefix get prepend ] } cond ; : escape-link ( href text -- href-esc text-esc ) >r check-url escape-quoted-string r> escape-string ; -: write-link ( text href -- ) +: write-link ( href text -- ) escape-link - "" write write "" write ; + [ ] + [ write ] + bi* ; : write-image-link ( href text -- ) disable-images? get [ - 2drop "Images are not allowed" write + 2drop + "Images are not allowed" write ] [ escape-link - >r " - dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if - "/>" write + [ ] bi* ] if ; : render-code ( string mode -- string' ) @@ -149,32 +155,35 @@ stand-alone = (code | heading | list | table | paragraph | nl)* ] with-string-writer write ; -GENERIC: write-farkup ( obj -- ) +GENERIC: (write-farkup) ( farkup -- ) : ( string -- ) write ; : ( string -- ) write ; : in-tag. ( obj quot string -- ) [ call ] keep ; inline -M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ; -M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ; -M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ; -M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ; -M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ; -M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ; -M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ; -M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ; -M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ; -M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ; -M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ; -M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ; -M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ; -M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ; -M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ; -M: table-row write-farkup ( obj -- ) - obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ; -M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ; -M: fixnum write-farkup ( obj -- ) write1 ; -M: string write-farkup ( obj -- ) write ; -M: vector write-farkup ( obj -- ) [ write-farkup ] each ; -M: f write-farkup ( obj -- ) drop ; +M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ; +M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ; +M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ; +M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ; +M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ; +M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ; +M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ; +M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ; +M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ; +M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ; +M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ; +M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ; +M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ; +M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ; +M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ; +M: table-row (write-farkup) ( obj -- ) + obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ; +M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ; +M: fixnum (write-farkup) ( obj -- ) write1 ; +M: string (write-farkup) ( obj -- ) write ; +M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ; +M: f (write-farkup) ( obj -- ) drop ; + +: write-farkup ( string -- ) + farkup (write-farkup) ; : convert-farkup ( string -- string' ) - farkup [ write-farkup ] with-string-writer ; + farkup [ (write-farkup) ] with-string-writer ; diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index e2feb3cc17..2b84d58d06 100755 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -14,13 +14,13 @@ DEFER: shallow-fry : ((shallow-fry)) ( accum quot adder -- result ) >r shallow-fry r> - append swap dup empty? [ drop ] [ + append swap [ [ prepose ] curry append - ] if ; inline + ] unless-empty ; inline : (shallow-fry) ( accum quot -- result ) - dup empty? [ - drop 1quotation + [ + 1quotation ] [ unclip { { \ , [ [ curry ] ((shallow-fry)) ] } @@ -31,7 +31,7 @@ DEFER: shallow-fry [ swap >r suffix r> (shallow-fry) ] } case - ] if ; + ] if-empty ; : shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ; diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index d42972c360..1370ae95b2 100755 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -23,11 +23,11 @@ SYMBOL: rest : render-validation-messages ( -- ) form get errors>> - dup empty? [ drop ] [ + [ - ] if ; + ] unless-empty ; CHLOE: validation-messages drop render-validation-messages ; @@ -47,11 +47,11 @@ TUPLE: action rest authorize init display validate submit ; 2tri ; : set-nested-form ( form name -- ) - dup empty? [ - drop merge-forms + [ + merge-forms ] [ unclip [ set-nested-form ] nest-form - ] if ; + ] if-empty ; : restore-validation-errors ( -- ) form cget [ diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor index 4487759719..54e936a313 100755 --- a/basis/furnace/auth/auth.factor +++ b/basis/furnace/auth/auth.factor @@ -134,22 +134,21 @@ TUPLE: protected < filter-responder description capabilities ; swap >>responder ; : have-capabilities? ( capabilities -- ? ) - logged-in-user get { - { [ dup not ] [ 2drop f ] } - { [ dup deleted>> 1 = ] [ 2drop f ] } - [ capabilities>> subset? ] - } cond ; + realm get secure>> secure-connection? not and [ drop f ] [ + logged-in-user get { + { [ dup not ] [ 2drop f ] } + { [ dup deleted>> 1 = ] [ 2drop f ] } + [ capabilities>> subset? ] + } cond + ] if ; M: protected call-responder* ( path responder -- response ) - '[ - , , - dup protected set - dup capabilities>> have-capabilities? - [ call-next-method ] [ - [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi* - realm get login-required* - ] if - ] if-secure-realm ; + dup protected set + dup capabilities>> have-capabilities? + [ call-next-method ] [ + [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi* + realm get login-required* + ] if ; : ( responder -- responder' ) { realm "boilerplate" } >>template ; diff --git a/basis/furnace/auth/features/edit-profile/edit-profile.factor b/basis/furnace/auth/features/edit-profile/edit-profile.factor index fb4fbb898f..e6d85809b9 100644 --- a/basis/furnace/auth/features/edit-profile/edit-profile.factor +++ b/basis/furnace/auth/features/edit-profile/edit-profile.factor @@ -42,8 +42,8 @@ IN: furnace.auth.features.edit-profile [ logged-in-user get - "new-password" value dup empty? - [ drop ] [ >>encoded-password ] if + "new-password" value + [ >>encoded-password ] unless-empty "realname" value >>realname "email" value >>email diff --git a/basis/furnace/auth/features/registration/registration.factor b/basis/furnace/auth/features/registration/registration.factor index 20a48d07d2..da58e2b2ed 100644 --- a/basis/furnace/auth/features/registration/registration.factor +++ b/basis/furnace/auth/features/registration/registration.factor @@ -36,7 +36,8 @@ IN: furnace.auth.features.registration URL" $realm" ] >>submit - ; + + ; : allow-registration ( login -- login ) "register" add-responder ; diff --git a/basis/furnace/chloe-tags/chloe-tags-tests.factor b/basis/furnace/chloe-tags/chloe-tags-tests.factor new file mode 100644 index 0000000000..f172ce36f6 --- /dev/null +++ b/basis/furnace/chloe-tags/chloe-tags-tests.factor @@ -0,0 +1,19 @@ +USING: html.forms furnace.chloe-tags tools.test ; +IN: furnace.chloe-tags.tests + +[ f ] [ f parse-query-attr ] unit-test + +[ f ] [ "" parse-query-attr ] unit-test + +[ H{ { "a" "b" } } ] [ + begin-form + "b" "a" set-value + "a" parse-query-attr +] unit-test + +[ H{ { "a" "b" } { "c" "d" } } ] [ + begin-form + "b" "a" set-value + "d" "c" set-value + "a,c" parse-query-attr +] unit-test diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor new file mode 100644 index 0000000000..8822bca519 --- /dev/null +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -0,0 +1,126 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel combinators assocs +namespaces sequences splitting words +fry urls multiline present qualified +xml +xml.data +xml.entities +xml.writer +xml.utilities +html.components +html.elements +html.forms +html.templates +html.templates.chloe +html.templates.chloe.compiler +html.templates.chloe.syntax +http +http.server +http.server.redirection +http.server.responses +furnace ; +QUALIFIED-WITH: assocs a +IN: furnace.chloe-tags + +! Chloe tags +: parse-query-attr ( string -- assoc ) + [ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ; + +: a-url-path ( href rest -- string ) + dup [ value ] when + [ [ "/" ?tail drop "/" ] dip present 3append ] when* ; + +: a-url ( href rest query value-name -- url ) + dup [ >r 3drop r> value ] [ + drop + + swap parse-query-attr >>query + -rot a-url-path >>path + adjust-url relative-to-request + ] if ; + +: compile-a-url ( tag -- ) + { + [ "href" required-attr compile-attr ] + [ "rest" optional-attr compile-attr ] + [ "query" optional-attr compile-attr ] + [ "value" optional-attr compile-attr ] + } cleave [ a-url ] [code] ; + +CHLOE: atom + [ compile-children>string ] [ compile-a-url ] bi + [ add-atom-feed ] [code] ; + +CHLOE: write-atom drop [ write-atom-feeds ] [code] ; + +: compile-link-attrs ( tag -- ) + #! Side-effects current namespace. + attrs>> '[ [ , _ link-attr ] each-responder ] [code] ; + +: a-start-tag ( tag -- ) + [ compile-link-attrs ] [ compile-a-url ] bi + [ ] [code] ; + +: a-end-tag ( tag -- ) + drop [ ] [code] ; + +CHLOE: a + [ + [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri + ] compile-with-scope ; + +: compile-hidden-form-fields ( for -- ) + '[ + , [ "," split [ hidden render ] each ] when* + nested-forms get " " join f like nested-forms-key hidden-form-field + [ modify-form ] each-responder + ] [code] ; + +: compile-form-attrs ( method action attrs -- ) + [
] [code] ; + +: form-start-tag ( tag -- ) + [ + [ "method" optional-attr "post" or ] + [ "action" required-attr ] + [ attrs>> non-chloe-attrs-only ] tri + compile-form-attrs + ] + [ "for" optional-attr compile-hidden-form-fields ] bi ; + +: form-end-tag ( tag -- ) + drop [
] [code] ; + +CHLOE: form + [ + { + [ compile-link-attrs ] + [ form-start-tag ] + [ compile-children ] + [ form-end-tag ] + } cleave + ] compile-with-scope ; + +STRING: button-tag-markup + + + +; + +: add-tag-attrs ( attrs tag -- ) + attrs>> swap update ; + +CHLOE: button + button-tag-markup string>xml body>> + { + [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ] + [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] + [ [ children>> ] dip "button" tag-named (>>children) ] + [ nip ] + } 2cleave compile-chloe-tag ; diff --git a/basis/furnace/conversations/conversations.factor b/basis/furnace/conversations/conversations.factor index 7216978110..26b62f9b07 100644 --- a/basis/furnace/conversations/conversations.factor +++ b/basis/furnace/conversations/conversations.factor @@ -130,7 +130,8 @@ M: conversations call-responder* over post-data>> >>post-data over url>> >>url ] change - url>> path>> split-path + [ url>> url set ] + [ url>> path>> split-path ] bi conversations get responder>> call-responder ; \ end-aside-post DEBUG add-input-logging diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor index fadd398882..b90587fba8 100644 --- a/basis/furnace/furnace.factor +++ b/basis/furnace/furnace.factor @@ -1,30 +1,14 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel combinators assocs -continuations namespaces sequences splitting words -vocabs.loader classes strings -fry urls multiline present -xml -xml.data -xml.entities -xml.writer -html.components -html.elements -html.forms -html.templates -html.templates.chloe -html.templates.chloe.syntax -http -http.server -http.server.redirection -http.server.responses -qualified ; -QUALIFIED-WITH: assocs a -EXCLUDE: xml.utilities => children>string ; +USING: namespaces assocs sequences kernel classes splitting +vocabs.loader accessors strings combinators arrays +continuations present fry +urls html.elements +http http.server http.server.redirection ; IN: furnace : nested-responders ( -- seq ) - responder-nesting get a:values ; + responder-nesting get values ; : each-responder ( quot -- ) nested-responders swap each ; inline @@ -63,10 +47,25 @@ M: url adjust-url M: string adjust-url ; +GENERIC: link-attr ( tag responder -- ) + +M: object link-attr 2drop ; + GENERIC: modify-form ( responder -- ) M: object modify-form drop ; +: hidden-form-field ( value name -- ) + over [ + + ] [ 2drop ] if ; + +: nested-forms-key "__n" ; + : request-params ( request -- assoc ) dup method>> { { "GET" [ url>> query>> ] } @@ -110,99 +109,4 @@ SYMBOL: exit-continuation : with-exit-continuation ( quot -- ) '[ exit-continuation set @ ] callcc1 exit-continuation off ; -! Chloe tags -: parse-query-attr ( string -- assoc ) - dup empty? - [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; - -: a-url-path ( tag -- string ) - [ "href" required-attr ] - [ "rest" optional-attr dup [ value ] when ] bi - [ [ "/" ?tail drop "/" ] dip present 3append ] when* ; - -: a-url ( tag -- url ) - dup "value" optional-attr - [ value ] [ - - swap - [ a-url-path >>path ] - [ "query" optional-attr parse-query-attr >>query ] - bi - adjust-url relative-to-request - ] ?if ; - -CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ; - -CHLOE: write-atom drop write-atom-feeds ; - -GENERIC: link-attr ( tag responder -- ) - -M: object link-attr 2drop ; - -: link-attrs ( tag -- ) - #! Side-effects current namespace. - '[ , _ link-attr ] each-responder ; - -: a-start-tag ( tag -- ) - [ ] with-scope ; - -CHLOE: a - [ a-start-tag ] - [ process-tag-children ] - [ drop ] - tri ; - -: hidden-form-field ( value name -- ) - over [ - - ] [ 2drop ] if ; - -: nested-forms-key "__n" ; - -: form-magic ( tag -- ) - [ modify-form ] each-responder - nested-forms get " " join f like nested-forms-key hidden-form-field - "for" optional-attr [ "," split [ hidden render ] each ] when* ; - -: form-start-tag ( tag -- ) - [ - [ -
> non-chloe-attrs-only print-attrs ] - } cleave - form> - ] - [ form-magic ] bi - ] with-scope ; - -CHLOE: form - [ form-start-tag ] - [ process-tag-children ] - [ drop
] - tri ; - -STRING: button-tag-markup - - - -; - -: add-tag-attrs ( attrs tag -- ) - attrs>> swap update ; - -CHLOE: button - button-tag-markup string>xml body>> - { - [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ] - [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ] - [ [ children>string 1array ] dip "button" tag-named (>>children) ] - [ nip ] - } 2cleave process-chloe-tag ; +"furnace.chloe-tags" require diff --git a/basis/furnace/redirection/redirection.factor b/basis/furnace/redirection/redirection.factor index 83941cd08f..942cafd21a 100644 --- a/basis/furnace/redirection/redirection.factor +++ b/basis/furnace/redirection/redirection.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors combinators namespaces fry -io.servers.connection urls -http http.server http.server.redirection http.server.filters -furnace ; +io.servers.connection urls http http.server +http.server.redirection http.server.responses +http.server.filters furnace ; IN: furnace.redirection : ( url -- response ) @@ -32,10 +32,14 @@ TUPLE: secure-only < filter-responder ; C: secure-only -: if-secure ( quot -- ) - >r url get protocol>> "http" = - [ url get ] - r> if ; inline +: secure-connection? ( -- ? ) url get protocol>> "https" = ; + +: if-secure ( quot -- response ) + { + { [ secure-connection? ] [ call ] } + { [ request get method>> "POST" = ] [ drop <400> ] } + [ drop url get ] + } cond ; inline M: secure-only call-responder* '[ , , call-next-method ] if-secure ; diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index a702f452da..ba53e6c591 100755 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -2,6 +2,16 @@ USING: help.syntax help.markup kernel sequences quotations math arrays ; IN: generalizations +HELP: nsequence +{ $values { "n" integer } { "seq" "an exemplar" } } +{ $description "A generalization of " { $link 2sequence } ", " +{ $link 3sequence } ", and " { $link 4sequence } " " +"that constructs a sequence from the top " { $snippet "n" } " elements of the stack." +} +{ $examples + { $example "USING: generalizations prettyprint ;" "CHAR: f CHAR: i CHAR: s CHAR: h 4 \"\" nsequence ." "\"fish\"" } +} ; + HELP: narray { $values { "n" integer } } { $description "A generalization of " { $link 1array } ", " @@ -9,6 +19,8 @@ HELP: narray "that constructs an array from the top " { $snippet "n" } " elements of the stack." } ; +{ nsequence narray } related-words + HELP: firstn { $values { "n" integer } } { $description "A generalization of " { $link first } ", " @@ -127,11 +139,15 @@ HELP: nkeep { $see-also keep nslip } ; ARTICLE: "generalizations" "Generalized shuffle words and combinators" -"A number of stack shuffling words and combinators for use in " +"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " "macros where the arity of the input quotations depends on an " "input parameter." +$nl +"Generalized sequence operations:" { $subsection narray } +{ $subsection nsequence } { $subsection firstn } +"Generated stack shuffle operations:" { $subsection ndup } { $subsection npick } { $subsection nrot } @@ -139,6 +155,7 @@ ARTICLE: "generalizations" "Generalized shuffle words and combinators" { $subsection nnip } { $subsection ndrop } { $subsection nrev } +"Generalized combinators:" { $subsection ndip } { $subsection nslip } { $subsection nkeep } diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index e4d5249a30..c97e9c7b91 100755 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -5,10 +5,13 @@ USING: kernel sequences sequences.private namespaces math math.ranges combinators macros quotations fry arrays ; IN: generalizations -MACRO: narray ( n -- quot ) - [ ] [ '[ , f ] ] bi +MACRO: nsequence ( n seq -- quot ) + [ drop ] [ '[ , , new-sequence ] ] 2bi [ '[ @ [ , swap set-nth-unsafe ] keep ] ] reduce ; +MACRO: narray ( n -- quot ) + '[ , { } nsequence ] ; + MACRO: firstn ( n -- ) dup zero? [ drop [ drop ] ] [ [ [ '[ , _ nth-unsafe ] ] map ] diff --git a/basis/help/help.factor b/basis/help/help.factor index 7535ba8c1a..b2fff22372 100755 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -72,15 +72,13 @@ M: word article-parent "help-parent" word-prop ; M: word set-article-parent swap "help-parent" set-word-prop ; : $doc-path ( article -- ) - help-path dup empty? [ - drop - ] [ + help-path [ [ help-path-style get [ "Parent topics: " write $links ] with-style ] ($block) - ] if ; + ] unless-empty ; : $title ( topic -- ) title-style get [ @@ -112,8 +110,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; sort-articles [ \ $subsection swap 2array ] map print-element ; : $index ( element -- ) - first call dup empty? - [ drop ] [ ($index) ] if ; + first call [ ($index) ] unless-empty ; : $about ( element -- ) first vocab-help [ 1array $subsection ] when* ; diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index b12dcaa807..4ad9067457 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -136,15 +136,14 @@ M: help-error error. ] with-scope ; : typos. ( assoc -- ) - dup empty? [ - drop + [ "==== ALL CHECKS PASSED" print ] [ [ swap vocab-heading. [ error. nl ] each ] assoc-each - ] if ; + ] if-empty ; : help-lint ( prefix -- ) run-help-lint typos. ; diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index d94b9c4b41..3077a93ed4 100755 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -15,7 +15,7 @@ IN: help.markup ! Element types are words whose name begins with $. PREDICATE: simple-element < array - dup empty? [ drop t ] [ first word? not ] if ; + [ t ] [ first word? not ] if-empty ; SYMBOL: last-element SYMBOL: span @@ -201,8 +201,8 @@ ALIAS: $slot $snippet dup [ "related" set-word-prop ] curry each ; : $related ( element -- ) - first dup "related" word-prop remove dup empty? - [ drop ] [ $see-also ] if ; + first dup "related" word-prop remove + [ $see-also ] unless-empty ; : ($grid) ( style quot -- ) [ diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 28bce0ec42..da6ab96959 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -13,10 +13,10 @@ IN: hints dup length [ (picker) 2array ] 2map [ drop object eq? not ] assoc-filter - dup empty? [ drop [ t ] ] [ + [ [ t ] ] [ [ (make-specializer) ] { } assoc>map unclip [ swap [ f ] \ if 3array append [ ] like ] reduce - ] if ; + ] if-empty ; : specializer-cases ( quot word -- default alist ) dup [ array? ] all? [ 1array ] unless [ diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index b6b7f22b1d..0969dd7ef3 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -156,7 +156,7 @@ M: farkup render* [ [ no-follow>> [ string>boolean link-no-follow? set ] when* ] [ disable-images>> [ string>boolean disable-images? set ] when* ] bi - drop string-lines "\n" join convert-farkup write + drop string-lines "\n" join write-farkup ] with-scope ; ! Inspector component diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index 35e01227b5..89f8b01a19 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -142,6 +142,7 @@ SYMBOL: html "ol" "li" "form" "a" "p" "html" "head" "body" "title" "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea" "script" "div" "span" "select" "option" "style" "input" + "strong" ] [ define-closed-html-word ] each ! Define some open HTML tags @@ -160,6 +161,8 @@ SYMBOL: html "src" "language" "colspan" "onchange" "rel" "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" "media" "title" "multiple" "checked" + "summary" "cellspacing" "align" "scope" "abbr" + "nofollow" "alt" ] [ define-attribute-word ] each >> diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index d21c743dcd..6a15b76bd3 100755 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -88,11 +88,11 @@ TUPLE: html-sub-stream < html-stream style parent ; ] make-css ; : span-tag ( style quot -- ) - over span-css-style dup empty? [ - drop call + over span-css-style [ + call ] [ call - ] if ; inline + ] if-empty ; inline : format-html-span ( string style stream -- ) stream>> [ @@ -121,11 +121,11 @@ M: html-span-stream dispose ] make-css ; : div-tag ( style quot -- ) - swap div-css-style dup empty? [ - drop call + swap div-css-style [ + call ] [
call
- ] if ; inline + ] if-empty ; inline : format-html-div ( string style stream -- ) stream>> [ diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor index 0305b738af..9eb4a5709c 100644 --- a/basis/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -4,22 +4,7 @@ namespaces xml html.components html.forms splitting unicode.categories furnace accessors ; IN: html.templates.chloe.tests -[ f ] [ f parse-query-attr ] unit-test - -[ f ] [ "" parse-query-attr ] unit-test - -[ H{ { "a" "b" } } ] [ - begin-form - "b" "a" set-value - "a" parse-query-attr -] unit-test - -[ H{ { "a" "b" } { "c" "d" } } ] [ - begin-form - "b" "a" set-value - "d" "c" set-value - "a,c" parse-query-attr -] unit-test +reset-templates : run-template with-string-writer [ "\r\n\t" member? not ] filter diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index f40fc43b32..45e59c3b6d 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -1,78 +1,53 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -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 mirrors fry math urls present -multiline xml xml.data xml.writer xml.utilities +USING: accessors kernel sequences combinators kernel fry +namespaces classes.tuple assocs splitting words arrays memoize +io io.files io.encodings.utf8 io.streams.string unicode.case +mirrors math urls present multiline quotations xml xml.data html.forms html.elements html.components html.templates +html.templates.chloe.compiler +html.templates.chloe.components html.templates.chloe.syntax ; IN: html.templates.chloe ! Chloe is Ed's favorite web designer -SYMBOL: tag-stack - TUPLE: chloe path ; C: chloe -DEFER: process-template +CHLOE: chloe compile-children ; -: chloe-attrs-only ( assoc -- assoc' ) - [ drop url>> chloe-ns = ] assoc-filter ; - -: non-chloe-attrs-only ( assoc -- assoc' ) - [ drop url>> chloe-ns = not ] assoc-filter ; - -: chloe-tag? ( tag -- ? ) - dup xml? [ body>> ] when - { - { [ dup tag? not ] [ f ] } - { [ dup url>> chloe-ns = not ] [ f ] } - [ t ] - } cond nip ; - -: process-tag-children ( tag -- ) - [ process-template ] each ; - -CHLOE: chloe process-tag-children ; - -: children>string ( tag -- string ) - [ process-tag-children ] with-string-writer ; - -CHLOE: title children>string set-title ; +CHLOE: title compile-children>string [ set-title ] [code] ; CHLOE: write-title drop "head" tag-stack get member? "title" tag-stack get member? not and - [ write-title ] [ write-title ] if ; + [ write-title ] [ write-title ] ? [code] ; CHLOE: style - dup "include" optional-attr dup [ - swap children>string empty? [ - "style tag cannot have both an include attribute and a body" throw - ] unless - utf8 file-contents + dup "include" optional-attr [ + utf8 file-contents [ add-style ] [code-with] ] [ - drop children>string - ] if add-style ; + compile-children>string [ add-style ] [code] + ] ?if ; CHLOE: write-style - drop ; + drop [ ] [code] ; -CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ; +CHLOE: even + [ "index" value even? swap when ] process-children ; -CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ; +CHLOE: odd + [ "index" value odd? swap when ] process-children ; : (bind-tag) ( tag quot -- ) [ - [ "name" required-attr ] keep - '[ , process-tag-children ] - ] dip call ; inline + [ "name" required-attr compile-attr ] keep + ] dip process-children ; inline CHLOE: each [ with-each-value ] (bind-tag) ; @@ -80,22 +55,23 @@ CHLOE: bind-each [ with-each-object ] (bind-tag) ; CHLOE: bind [ with-form ] (bind-tag) ; -: error-message-tag ( tag -- ) - children>string render-error ; - CHLOE: comment drop ; -CHLOE: call-next-template drop call-next-template ; +CHLOE: call-next-template + drop reset-buffer \ call-next-template , ; : attr>word ( value -- word/f ) ":" split1 swap lookup ; -: if-satisfied? ( tag -- ? ) - [ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ] - [ "value" optional-attr [ value ] [ t ] if* ] - bi and ; +: if>quot ( tag -- quot ) + [ + [ "code" optional-attr [ attr>word [ , ] [ f , ] if* ] [ t , ] if* ] + [ "value" optional-attr [ , \ value , ] [ t , ] if* ] + bi + \ and , + ] [ ] make ; -CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; +CHLOE: if dup if>quot [ swap when ] append process-children ; CHLOE-SINGLETON: label CHLOE-SINGLETON: link @@ -112,51 +88,21 @@ CHLOE-TUPLE: choice CHLOE-TUPLE: checkbox CHLOE-TUPLE: code -: process-chloe-tag ( tag -- ) - dup main>> dup tags get at - [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ; +: read-template ( chloe -- xml ) + path>> ".xml" append utf8 read-xml ; -: process-tag ( tag -- ) - { - [ main>> >lower tag-stack get push ] - [ write-start-tag ] - [ process-tag-children ] - [ write-end-tag ] - [ drop tag-stack get pop* ] - } cleave ; +MEMO: template-quot ( chloe -- quot ) + read-template compile-template ; -: expand-attrs ( tag -- tag ) - dup [ tag? ] [ xml? ] bi or [ - clone [ - [ "@" ?head [ value present ] when ] assoc-map - ] change-attrs - ] when ; +MEMO: nested-template-quot ( chloe -- quot ) + read-template compile-nested-template ; -: process-template ( xml -- ) - expand-attrs - { - { [ dup chloe-tag? ] [ process-chloe-tag ] } - { [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] } - { [ t ] [ write-item ] } - } cond ; - -: process-chloe ( xml -- ) - [ - V{ } clone tag-stack set - - nested-template? get [ - process-template - ] [ - { - [ prolog>> write-prolog ] - [ before>> write-chunk ] - [ process-template ] - [ after>> write-chunk ] - } cleave - ] if - ] with-scope ; +: reset-templates ( -- ) + { template-quot nested-template-quot } [ reset-memoized ] each ; M: chloe call-template* - path>> ".xml" append utf8 read-xml process-chloe ; + nested-template? get + [ nested-template-quot ] [ template-quot ] if + assert-depth ; INSTANCE: chloe template diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor new file mode 100644 index 0000000000..044d2edb90 --- /dev/null +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -0,0 +1,131 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs namespaces kernel sequences accessors combinators +strings splitting io io.streams.string present xml.writer +xml.data xml.entities html.forms html.templates.chloe.syntax ; +IN: html.templates.chloe.compiler + +: chloe-attrs-only ( assoc -- assoc' ) + [ drop url>> chloe-ns = ] assoc-filter ; + +: non-chloe-attrs-only ( assoc -- assoc' ) + [ drop url>> chloe-ns = not ] assoc-filter ; + +: chloe-tag? ( tag -- ? ) + dup xml? [ body>> ] when + { + { [ dup tag? not ] [ f ] } + { [ dup url>> chloe-ns = not ] [ f ] } + [ t ] + } cond nip ; + +SYMBOL: string-buffer + +SYMBOL: tag-stack + +DEFER: compile-element + +: compile-children ( tag -- ) + [ compile-element ] each ; + +: [write] ( string -- ) string-buffer get push-all ; + +: reset-buffer ( -- ) + string-buffer get [ + [ >string , \ write , ] [ delete-all ] bi + ] unless-empty ; + +: [code] ( quot -- ) + reset-buffer % ; + +: [code-with] ( obj quot -- ) + reset-buffer [ , ] [ % ] bi* ; + +: expand-attr ( value -- ) + [ value present write ] [code-with] ; + +: compile-attr ( value -- ) + reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ; + +: compile-attrs ( assoc -- ) + [ + " " [write] + swap name>string [write] + "=\"" [write] + "@" ?head [ expand-attr ] [ escape-quoted-string [write] ] if + "\"" [write] + ] assoc-each ; + +: compile-start-tag ( tag -- ) + "<" [write] + [ name>string [write] ] [ compile-attrs ] bi + ">" [write] ; + +: compile-end-tag ( tag -- ) + "string [write] + ">" [write] ; + +: compile-tag ( tag -- ) + { + [ main>> tag-stack get push ] + [ compile-start-tag ] + [ compile-children ] + [ compile-end-tag ] + [ drop tag-stack get pop* ] + } cleave ; + +: compile-chloe-tag ( tag -- ) + ! "Unknown chloe tag: " prepend throw + dup main>> dup tags get at + [ curry assert-depth ] [ 2drop ] ?if ; + +: compile-element ( element -- ) + { + { [ dup chloe-tag? ] [ compile-chloe-tag ] } + { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] } + { [ dup string? ] [ escape-string [write] ] } + { [ dup comment? ] [ drop ] } + [ [ write-item ] [code-with] ] + } cond ; + +: with-compiler ( quot -- quot' ) + [ + SBUF" " string-buffer set + V{ } clone tag-stack set + call + reset-buffer + ] [ ] make ; inline + +: compile-nested-template ( xml -- quot ) + [ compile-element ] with-compiler ; + +: compile-chunk ( seq -- ) + [ compile-element ] each ; + +: compile-quot ( quot -- ) + reset-buffer + [ + SBUF" " string-buffer set + call + reset-buffer + ] [ ] make , ; inline + +: process-children ( tag quot -- ) + [ [ compile-children ] compile-quot ] [ % ] bi* ; inline + +: compile-children>string ( tag -- ) + [ with-string-writer ] process-children ; + +: compile-with-scope ( quot -- ) + compile-quot [ with-scope ] [code] ; inline + +: compile-template ( xml -- quot ) + [ + { + [ prolog>> [ write-prolog ] [code-with] ] + [ before>> compile-chunk ] + [ compile-element ] + [ after>> compile-chunk ] + } cleave + ] with-compiler ; diff --git a/basis/html/templates/chloe/components/components.factor b/basis/html/templates/chloe/components/components.factor new file mode 100644 index 0000000000..e8703a1235 --- /dev/null +++ b/basis/html/templates/chloe/components/components.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs sequences kernel parser fry quotations +classes.tuple +html.components +html.templates.chloe.compiler +html.templates.chloe.syntax ; +IN: html.templates.chloe.components + +: singleton-component-tag ( tag class -- ) + [ "name" required-attr compile-attr ] + [ literalize [ render ] [code-with] ] + bi* ; + +: CHLOE-SINGLETON: + scan-word + [ name>> ] [ '[ , singleton-component-tag ] ] bi + define-chloe-tag ; + parsing + +: compile-component-attrs ( tag class -- ) + [ attrs>> [ drop main>> "name" = not ] assoc-filter ] dip + [ all-slots swap '[ name>> , at compile-attr ] each ] + [ [ boa ] [code-with] ] + bi ; + +: tuple-component-tag ( tag class -- ) + [ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi + [ render ] [code] ; + +: CHLOE-TUPLE: + scan-word + [ name>> ] [ '[ , tuple-component-tag ] ] bi + define-chloe-tag ; + parsing diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index 65b5cd8790..90c171917b 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -21,7 +21,7 @@ tags global [ H{ } clone or ] change-at : chloe-ns "http://factorcode.org/chloe/1.0" ; inline -MEMO: chloe-name ( string -- name ) +: chloe-name ( string -- name ) name new swap >>main chloe-ns >>url ; @@ -32,30 +32,3 @@ MEMO: chloe-name ( string -- name ) : optional-attr ( tag name -- value ) chloe-name swap at ; - -: singleton-component-tag ( tag class -- ) - [ "name" required-attr ] dip render ; - -: CHLOE-SINGLETON: - scan-word - [ name>> ] [ '[ , singleton-component-tag ] ] bi - define-chloe-tag ; - parsing - -: attrs>slots ( tag tuple -- ) - [ attrs>> ] [ ] bi* - '[ - swap main>> dup "name" = - [ 2drop ] [ , set-at ] if - ] assoc-each ; - -: tuple-component-tag ( tag class -- ) - [ drop "name" required-attr ] - [ new [ attrs>slots ] keep ] - 2bi render ; - -: CHLOE-TUPLE: - scan-word - [ name>> ] [ '[ , tuple-component-tag ] ] bi - define-chloe-tag ; - parsing diff --git a/basis/http/http.factor b/basis/http/http.factor index e450631d94..03cca05ff3 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -113,7 +113,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s { [ dup real? ] [ number>string ] } [ ] } cond - check-cookie-string "=" swap check-cookie-string 3append , + [ check-cookie-string ] bi@ "=" swap 3append , ] } case ; diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor index c8fb7d365a..7b451d5266 100755 --- a/basis/inspector/inspector.factor +++ b/basis/inspector/inspector.factor @@ -50,14 +50,14 @@ SYMBOL: +editable+ : describe* ( obj mirror keys -- ) rot summary. - dup empty? [ - 2drop + [ + drop ] [ dup enum? [ +sequence+ on ] when standard-table-style [ swap [ -rot describe-row ] curry each-index ] tabular-output - ] if ; + ] if-empty ; : describe ( obj -- ) dup make-mirror dup sorted-keys describe* ; diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 1ed83956c3..f789f7b114 100755 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -73,7 +73,7 @@ M: threaded-server handle-client* handler>> call ; ] with-stream ; : thread-name ( server-name addrspec -- string ) - unparse " connection from " swap 3append ; + unparse-short " connection from " swap 3append ; : accept-connection ( threaded-server -- ) [ accept ] [ addr>> ] bi diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 79a1abd49c..8c9f26b1dd 100755 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -95,11 +95,11 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ; [ "Component not a number" throw ] unless* ] B{ } map-as - ] if ; + ] if-empty ; : pad-inet6 ( string1 string2 -- seq ) 2dup [ length ] bi@ + 8 swap - diff --git a/basis/io/unix/sockets/sockets.factor b/basis/io/unix/sockets/sockets.factor index 8e0cb570ef..50952dd217 100755 --- a/basis/io/unix/sockets/sockets.factor +++ b/basis/io/unix/sockets/sockets.factor @@ -67,7 +67,7 @@ M: object ((client)) ( addrspec -- fd ) M: object (server) ( addrspec -- handle ) [ SOCK_STREAM server-socket-fd - dup handle-fd 10 listen io-error + dup handle-fd 128 listen io-error ] with-destructors ; : do-accept ( server addrspec -- fd sockaddr ) diff --git a/basis/lcs/diff2html/diff2html.factor b/basis/lcs/diff2html/diff2html.factor index 754e69a476..b92eeb1250 100644 --- a/basis/lcs/diff2html/diff2html.factor +++ b/basis/lcs/diff2html/diff2html.factor @@ -3,14 +3,14 @@ USING: lcs html.elements kernel qualified ; FROM: accessors => item>> ; FROM: io => write ; -FROM: sequences => each empty? ; +FROM: sequences => each if-empty ; FROM: xml.entities => escape-string ; IN: lcs.diff2html GENERIC: diff-line ( obj -- ) : write-item ( item -- ) - item>> dup empty? [ drop " " ] [ escape-string ] if write ; + item>> [ " " ] [ escape-string ] if-empty write ; M: retain diff-line diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index a37c429471..59ec325f39 100755 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -316,3 +316,17 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; ! [ f ] [ 3 wlet-&&-test ] unit-test ! [ f ] [ 8 wlet-&&-test ] unit-test ! [ t ] [ 12 wlet-&&-test ] unit-test + +[ { 10 } ] [ 10 [| a | { a } ] call ] unit-test +[ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test +[ { 10 20 30 } ] [ 10 20 30 [| a b c | { a b c } ] call ] unit-test + +[ { 10 20 30 } ] [ [let | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test + +[ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test + +[ H{ { 10 "a" } { 20 "b" } { 30 "c" } } ] +[ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test + +[ T{ slice f 0 3 "abc" } ] +[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test \ No newline at end of file diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index 3ba52ea391..af5f6834bc 100755 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -1,12 +1,14 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences sequences.private assocs math -parser words quotations debugger macros arrays macros splitting -combinators prettyprint.backend definitions prettyprint -hashtables prettyprint.sections sets sequences.private effects -effects.parser generic generic.parser compiler.units accessors -locals.backend memoize macros.expander lexer -stack-checker.known-words ; + vectors strings classes.tuple generalizations + parser words quotations debugger macros arrays macros splitting + combinators prettyprint.backend definitions prettyprint + hashtables prettyprint.sections sets sequences.private effects + effects.parser generic generic.parser compiler.units accessors + locals.backend memoize macros.expander lexer + stack-checker.known-words ; + IN: locals ! Inspired by @@ -98,8 +100,8 @@ C: quote UNION: special local quote local-word local-reader local-writer ; : load-locals-quot ( args -- quot ) - dup empty? [ - drop [ ] + [ + [ ] ] [ dup [ local-reader? ] contains? [ [ @@ -108,14 +110,10 @@ UNION: special local quote local-word local-reader local-writer ; ] [ length [ load-locals ] curry >quotation ] if - ] if ; + ] if-empty ; : drop-locals-quot ( args -- quot ) - dup empty? [ - drop [ ] - ] [ - length [ drop-locals ] curry - ] if ; + [ [ ] ] [ length [ drop-locals ] curry ] if-empty ; : point-free-body ( quot args -- newquot ) >r but-last-slice r> [ localize ] curry map concat ; @@ -202,6 +200,66 @@ M: object lambda-rewrite* , ; M: object local-rewrite* , ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Broil is used to support locals in literals + +DEFER: [broil] +DEFER: [broil-hashtable] +DEFER: [broil-tuple] + +: broil-element ( obj -- quot ) + { + { [ dup number? ] [ 1quotation ] } + { [ dup string? ] [ 1quotation ] } + { [ dup sequence? ] [ [broil] ] } + { [ dup hashtable? ] [ [broil-hashtable] ] } + { [ dup tuple? ] [ [broil-tuple] ] } + { [ dup local? ] [ 1quotation ] } + { [ dup word? ] [ literalize 1quotation ] } + { [ t ] [ 1quotation ] } + } + cond ; + +: [broil] ( seq -- quot ) + [ [ broil-element ] map concat >quotation ] + [ length ] + [ ] + tri + [ nsequence ] curry curry compose ; + +MACRO: broil ( seq -- quot ) [broil] ; + +: [broil-hashtable] ( hashtable -- quot ) + >alist + [ [ broil-element ] map concat >quotation ] + [ length ] + [ ] + tri + [ nsequence >hashtable ] curry curry compose ; + +MACRO: broil-hashtable ( hashtable -- quot ) [broil-hashtable] ; + +: [broil-tuple] ( tuple -- quot ) + tuple>array + [ [ broil-element ] map concat >quotation ] + [ length ] + [ ] + tri + [ nsequence >tuple ] curry curry compose ; + +MACRO: broil-tuple ( tuple -- quot ) [broil-tuple] ; + +! Engage broil on arrays and vectors. Can't do it on 'sequence' +! because that will pick up strings and integers. What do do... + +M: array local-rewrite* ( array -- ) [broil] % ; +M: vector local-rewrite* ( vector -- ) [broil] % ; +M: tuple local-rewrite* ( tuple -- ) [broil-tuple] % ; +M: hashtable local-rewrite* ( hashtable -- ) [broil-hashtable] % ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : make-local ( name -- word ) "!" ?tail [ diff --git a/basis/logging/insomniac/insomniac.factor b/basis/logging/insomniac/insomniac.factor index 7810a4afad..79d9410994 100755 --- a/basis/logging/insomniac/insomniac.factor +++ b/basis/logging/insomniac/insomniac.factor @@ -18,14 +18,14 @@ SYMBOL: insomniac-recipients ] "" make ; : (email-log-report) ( service word-names -- ) - dupd ?analyze-log dup empty? [ 2drop ] [ + dupd ?analyze-log [ drop ] [ swap >>body insomniac-recipients get >>to insomniac-sender get >>from swap email-subject >>subject send-email - ] if ; + ] if-empty ; \ (email-log-report) NOTICE add-error-logging diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index 7cc2f3d8d9..aa4e46fad1 100755 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -46,6 +46,7 @@ SYMBOL: log-service dup array? [ dup length 1 = [ first ] when ] when dup string? [ [ + boa-tuples? on string-limit? off 1 line-limit set 3 nesting-limit set diff --git a/basis/models/history/history.factor b/basis/models/history/history.factor index fc90ada35a..caf6f39d5c 100755 --- a/basis/models/history/history.factor +++ b/basis/models/history/history.factor @@ -17,9 +17,8 @@ TUPLE: history < model back forward ; swap value>> dup [ swap push ] [ 2drop ] if ; : go-back/forward ( history to from -- ) - dup empty? - [ 3drop ] - [ >r dupd (add-history) r> pop swap set-model ] if ; + [ 2drop ] + [ >r dupd (add-history) r> pop swap set-model ] if-empty ; : go-back ( history -- ) dup [ forward>> ] [ back>> ] bi go-back/forward ; diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index 561af504c6..856b9ad456 100755 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -37,9 +37,8 @@ PRIVATE> : parse-multiline-string ( end-text -- str ) [ - lexer get column>> swap (parse-multiline-string) - lexer get (>>column) - ] "" make rest but-last ; + lexer get [ swap (parse-multiline-string) ] change-column drop + ] "" make rest-slice but-last ; : <" "\">" parse-multiline-string parsed ; parsing diff --git a/basis/persistent/heaps/heaps.factor b/basis/persistent/heaps/heaps.factor index 81c9959f84..6381b91dc3 100644 --- a/basis/persistent/heaps/heaps.factor +++ b/basis/persistent/heaps/heaps.factor @@ -1,4 +1,4 @@ -USING: kernel accessors multi-methods locals combinators math arrays +USING: kernel accessors locals combinators math arrays assocs namespaces sequences ; IN: persistent.heaps ! These are minheaps @@ -36,14 +36,15 @@ PRIVATE> GENERIC: sift-down ( value prio left right -- heap ) -METHOD: sift-down { empty-heap empty-heap } ; - -METHOD: sift-down { singleton-heap empty-heap } +: singleton-sift-down ( value prio singleton empty -- heap ) 3dup drop prio>> <= [ ] [ drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip ] if ; +M: empty-heap sift-down + over singleton-heap? [ singleton-sift-down ] [ ] if ; + :: reroot-left ( value prio left right -- heap ) left value>> left prio>> value prio left left>> left right>> sift-down @@ -54,7 +55,7 @@ METHOD: sift-down { singleton-heap empty-heap } value prio right left>> right right>> sift-down ; -METHOD: sift-down { branch branch } +M: branch sift-down ! both arguments are branches 3dup [ prio>> <= ] both-with? [ ] [ 2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if ] if ; diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index c52ab18027..3b9d034378 100755 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -38,13 +38,13 @@ IN: prettyprint [ write-in nl ] when* ; : use. ( seq -- ) - dup empty? [ drop ] [ + [ natural-sort [ \ USING: pprint-word [ pprint-vocab ] each \ ; pprint-word ] with-pprint nl - ] if ; + ] unless-empty ; : vocabs. ( in use -- ) dupd remove [ { "syntax" "scratchpad" } member? not ] filter @@ -98,7 +98,7 @@ SYMBOL: -> "word-style" set-word-prop : remove-step-into ( word -- ) - building get dup empty? [ drop ] [ nip pop wrapped>> ] if , ; + building get [ nip pop wrapped>> ] unless-empty , ; : (remove-breakpoints) ( quot -- newquot ) [ diff --git a/basis/random/random.factor b/basis/random/random.factor index d37e2fc2b7..133bf93b61 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -34,14 +34,12 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; ] keep head ; : random ( seq -- elt ) - dup empty? [ - drop f - ] [ + [ f ] [ [ length dup log2 7 + 8 /i random-bytes byte-array>bignum swap mod ] keep nth - ] if ; + ] if-empty ; : delete-random ( seq -- elt ) [ length random ] keep [ nth ] 2keep delete-nth ; diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 4d0fd6d8aa..f4cd2c4a8e 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -11,9 +11,9 @@ IN: stack-checker.backend : push-d ( obj -- ) meta-d get push ; : pop-d ( -- obj ) - meta-d get dup empty? [ - drop dup 1array #introduce, d-in inc - ] [ pop ] if ; + meta-d get [ + dup 1array #introduce, d-in inc + ] [ pop ] if-empty ; : peek-d ( -- obj ) pop-d dup push-d ; @@ -40,7 +40,9 @@ IN: stack-checker.backend : output-r ( seq -- ) meta-r get push-all ; : pop-literal ( -- rstate obj ) - pop-d [ 1array #drop, ] [ literal [ recursion>> ] [ value>> ] bi ] bi ; + pop-d + [ 1array #drop, ] + [ literal [ recursion>> ] [ value>> ] bi ] bi ; GENERIC: apply-object ( obj -- ) @@ -142,8 +144,11 @@ M: object apply-object push-literal ; [ "inferred-effect" set-word-prop ] 2tri ; +: cannot-infer-effect ( word -- * ) + "cannot-infer" word-prop throw ; + : maybe-cannot-infer ( word quot -- ) - [ ] [ t "cannot-infer" set-word-prop ] cleanup ; inline + [ [ "cannot-infer" set-word-prop ] keep throw ] recover ; inline : infer-word ( word -- effect ) [ diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 015e00ef46..4685483103 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -31,10 +31,10 @@ SYMBOL: +bottom+ : unify-values ( values -- phi-out ) remove-bottom - dup empty? [ drop ] [ + [ ] [ [ known ] map dup all-eq? [ first make-known ] [ drop ] if - ] if ; + ] if-empty ; : phi-outputs ( phi-in -- stack ) flip [ unify-values ] map ; @@ -42,12 +42,12 @@ SYMBOL: +bottom+ SYMBOL: quotations : unify-branches ( ins stacks -- in phi-in phi-out ) - zip dup empty? [ drop 0 { } { } ] [ + zip [ 0 { } { } ] [ [ keys supremum ] [ ] [ balanced? ] tri [ dupd phi-inputs dup phi-outputs ] [ quotations get unbalanced-branches-error ] if - ] if ; + ] if-empty ; : branch-variable ( seq symbol -- seq ) '[ , _ at ] map ; diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index ffe7c26943..f4d7c80e13 100644 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -45,11 +45,6 @@ HELP: too-many-r> } } ; -HELP: cannot-infer-effect -{ $values { "word" word } } -{ $description "Throws a " { $link cannot-infer-effect } " error." } -{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ; - HELP: missing-effect { $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Stack effects of words must be declared, with the exception of words which only push literals on the stack." } { $examples @@ -108,7 +103,6 @@ ARTICLE: "inference-errors" "Inference warnings and errors" { $subsection inference-error } "Inference warnings:" { $subsection literal-expected } -{ $subsection cannot-infer-effect } "Inference errors:" { $subsection recursive-quotation-error } { $subsection unbalanced-branches-error } diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index ade47d8e91..3d92aea3e8 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -26,8 +26,8 @@ M: inference-error error-help error>> error-help ; M: inference-error error. [ - rstate>> dup empty? - [ drop ] [ "Nesting:" print stack. ] if + rstate>> + [ "Nesting:" print stack. ] unless-empty ] [ error>> error. ] bi ; TUPLE: literal-expected ; @@ -57,14 +57,6 @@ M: too-many-r> summary drop "Quotation pops retain stack elements which it did not push" ; -TUPLE: cannot-infer-effect word ; - -: cannot-infer-effect ( word -- * ) - \ cannot-infer-effect inference-warning ; - -M: cannot-infer-effect error. - "Unable to infer stack effect of " write word>> . ; - TUPLE: missing-effect word ; M: missing-effect error. diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 2773b8b4e4..d60565e849 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -69,15 +69,15 @@ IN: stack-checker.transforms \ cond [ cond>quot ] 1 define-transform \ case [ - dup empty? [ - drop [ no-case ] + [ + [ no-case ] ] [ dup peek quotation? [ dup peek swap but-last ] [ [ no-case ] swap ] if case>quot - ] if + ] if-empty ] 1 define-transform \ cleave [ cleave>quot ] 1 define-transform diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 723f9461a8..ae4f6a8d62 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -42,9 +42,9 @@ IN: tools.deploy.backend : bootstrap-profile ( -- profile ) { - { "threads" deploy-threads? } { "math" deploy-math? } { "compiler" deploy-compiler? } + { "threads" deploy-threads? } { "ui" deploy-ui? } { "random" deploy-random? } } [ nip get ] assoc-filter keys diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor index 065db4d8c1..0ebda89b15 100755 --- a/basis/tools/deploy/config/config.factor +++ b/basis/tools/deploy/config/config.factor @@ -73,7 +73,7 @@ SYMBOL: deploy-image : deploy-config ( vocab -- assoc ) dup default-config swap dup deploy-config-path vocab-file-contents - parse-fresh dup empty? [ drop ] [ first assoc-union ] if ; + parse-fresh [ first assoc-union ] unless-empty ; : set-deploy-config ( assoc vocab -- ) >r unparse-use string-lines r> diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 3d007e566c..acee098b8f 100755 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -26,7 +26,7 @@ namespaces continuations layouts accessors ; [ t ] [ 1300000 small-enough? ] unit-test -[ "staging.threads-math-compiler-ui-strip.image" ] [ +[ "staging.math-compiler-threads-ui-strip.image" ] [ "hello-ui" deploy-config [ bootstrap-profile staging-image-name file-name ] bind ] unit-test @@ -39,9 +39,9 @@ namespaces continuations layouts accessors ; ! ! [ t ] [ 1500000 small-enough? ] unit-test ! -! [ ] [ "bunny" shake-and-bake ] unit-test -! -! [ t ] [ 2500000 small-enough? ] unit-test +[ ] [ "bunny" shake-and-bake ] unit-test + +[ t ] [ 2500000 small-enough? ] unit-test { "tools.deploy.test.1" diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor index 098e99719e..6846b3b53e 100755 --- a/basis/tools/deploy/test/1/deploy.factor +++ b/basis/tools/deploy/test/1/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-c-types? f } - { deploy-name "tools.deploy.test.1" } - { deploy-io 2 } - { deploy-random? f } - { deploy-math? t } - { deploy-compiler? t } - { deploy-reflection 2 } - { "stop-after-last-window?" t } { deploy-threads? t } + { deploy-random? f } + { deploy-c-types? f } { deploy-ui? f } { deploy-word-props? f } { deploy-word-defs? f } + { deploy-math? t } + { deploy-io 2 } + { deploy-name "tools.deploy.test.1" } + { deploy-compiler? t } + { deploy-reflection 1 } + { "stop-after-last-window?" t } } diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor index c6f46eede6..4c34a77b66 100755 --- a/basis/tools/deploy/test/2/deploy.factor +++ b/basis/tools/deploy/test/2/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-io 2 } - { deploy-ui? f } { deploy-threads? t } + { deploy-random? f } { deploy-c-types? f } + { deploy-ui? f } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-math? t } + { deploy-io 2 } { deploy-name "tools.deploy.test.2" } { deploy-compiler? t } - { deploy-word-props? f } - { deploy-reflection 2 } - { deploy-word-defs? f } + { deploy-reflection 1 } { "stop-after-last-window?" t } - { deploy-random? f } - { deploy-math? t } } diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor index 5f45b87e0d..84347164b6 100755 --- a/basis/tools/deploy/test/3/deploy.factor +++ b/basis/tools/deploy/test/3/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-io 3 } - { deploy-ui? f } { deploy-threads? t } + { deploy-random? f } { deploy-c-types? f } + { deploy-ui? f } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-math? t } + { deploy-io 3 } { deploy-name "tools.deploy.test.3" } { deploy-compiler? t } - { deploy-word-props? f } - { deploy-reflection 2 } - { deploy-word-defs? f } + { deploy-reflection 1 } { "stop-after-last-window?" t } - { deploy-random? f } - { deploy-math? t } } diff --git a/basis/tools/deploy/test/4/deploy.factor b/basis/tools/deploy/test/4/deploy.factor index ea899e64c0..b1a6736bde 100644 --- a/basis/tools/deploy/test/4/deploy.factor +++ b/basis/tools/deploy/test/4/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-io 2 } - { deploy-ui? f } { deploy-threads? t } + { deploy-random? f } { deploy-c-types? f } + { deploy-ui? f } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-math? t } + { deploy-io 2 } { deploy-name "tools.deploy.test.4" } { deploy-compiler? t } - { deploy-word-props? f } - { deploy-reflection 2 } - { deploy-word-defs? f } + { deploy-reflection 1 } { "stop-after-last-window?" t } - { deploy-random? f } - { deploy-math? t } } diff --git a/basis/tools/deploy/test/5/deploy.factor b/basis/tools/deploy/test/5/deploy.factor index 797116e09b..f5f8bc0352 100644 --- a/basis/tools/deploy/test/5/deploy.factor +++ b/basis/tools/deploy/test/5/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-io 3 } - { deploy-ui? f } { deploy-threads? t } + { deploy-random? f } { deploy-c-types? f } + { deploy-ui? f } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-math? t } + { deploy-io 3 } { deploy-name "tools.deploy.test.5" } { deploy-compiler? t } - { deploy-word-props? f } - { deploy-reflection 2 } - { deploy-word-defs? f } + { deploy-reflection 1 } { "stop-after-last-window?" t } - { deploy-random? f } - { deploy-math? t } } diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 8bc9f93bd2..c4cca565c7 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -175,7 +175,11 @@ ERROR: no-vocab vocab ; { [ "IN: " write print nl ] [ interesting-words. ] - [ "ARTICLE: " write unparse dup write bl print ";" print nl ] + [ + [ "ARTICLE: " write unparse dup write bl print ] + [ "{ $vocab-link " write pprint " }" print ] bi + ";" print nl + ] [ "ABOUT: " write unparse print ] } cleave ] with-string-writer ; diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index b2b13a82a8..d3304bbdb1 100755 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -67,8 +67,7 @@ SYMBOL: this-test : test-failures. ( assoc -- ) [ nl - dup empty? [ - drop + [ "==== ALL TESTS PASSED" print ] [ "==== FAILING TESTS:" print @@ -76,16 +75,16 @@ SYMBOL: this-test swap vocab-heading. [ failure. nl ] each ] assoc-each - ] if + ] if-empty ] [ "==== NOTHING TO TEST" print ] if* ; : run-tests ( prefix -- failures ) - child-vocabs dup empty? [ drop f ] [ + child-vocabs [ f ] [ [ dup run-test ] { } map>assoc [ second empty? not ] filter - ] if ; + ] if-empty ; : test ( prefix -- ) run-tests test-failures. ; diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor index a771a35735..c3296df280 100755 --- a/basis/tools/vocabs/browser/browser.factor +++ b/basis/tools/vocabs/browser/browser.factor @@ -36,14 +36,14 @@ IN: tools.vocabs.browser : vocabs. ( assoc -- ) [ - dup empty? [ - 2drop + [ + drop ] [ swap root-heading. standard-table-style [ vocab-headings. [ vocab. ] each ] ($grid) - ] if + ] if-empty ] assoc-each ; : describe-summary ( vocab -- ) @@ -98,10 +98,10 @@ C: vocab-author ] when* ; : describe-words ( vocab -- ) - words dup empty? [ + words [ "Words" $heading - dup natural-sort $links - ] unless drop ; + natural-sort $links + ] unless-empty ; : vocab-xref ( vocab quot -- vocabs ) >r dup vocab-name swap words [ generic? not ] filter r> map @@ -113,16 +113,16 @@ C: vocab-author : vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ; : describe-uses ( vocab -- ) - vocab-uses dup empty? [ + vocab-uses [ "Uses" $heading - dup $vocab-links - ] unless drop ; + $vocab-links + ] unless-empty ; : describe-usage ( vocab -- ) - vocab-usage dup empty? [ + vocab-usage [ "Used by" $heading - dup $vocab-links - ] unless drop ; + $vocab-links + ] unless-empty ; : $describe-vocab ( element -- ) first diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index cc49d283b4..1c7e8d28d2 100755 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -165,11 +165,11 @@ MEMO: vocab-file-contents ( vocab name -- seq ) : vocab-summary ( vocab -- summary ) dup dup vocab-summary-path vocab-file-contents - dup empty? [ - drop vocab-name " vocabulary" append + [ + vocab-name " vocabulary" append ] [ nip first - ] if ; + ] if-empty ; M: vocab summary [ @@ -212,11 +212,9 @@ M: vocab-link summary vocab-summary ; : (all-child-vocabs) ( root name -- vocabs ) [ vocab-dir append-path subdirs ] keep - dup empty? [ - drop - ] [ + [ swap [ "." swap 3append ] with map - ] if ; + ] unless-empty ; : vocabs-in-dir ( root name -- ) dupd (all-child-vocabs) [ diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index 9c6b87b439..c1073eda8c 100755 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -197,7 +197,7 @@ SYMBOL: +stopped+ : step-back-msg ( continuation -- continuation' ) walker-history tget [ pop* ] - [ dup empty? [ drop ] [ nip pop ] if ] bi ; + [ [ nip pop ] unless-empty ] bi ; : walker-suspended ( continuation -- continuation' ) +suspended+ set-status diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 6b53d25ea1..1170ea3fd1 100755 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -108,7 +108,7 @@ SYMBOL: double-click-timeout : drag-gesture ( -- ) hand-buttons get-global - dup empty? [ drop ] [ first button-gesture ] if ; + [ first button-gesture ] unless-empty ; SYMBOL: drag-timer @@ -170,7 +170,7 @@ SYMBOL: drag-timer : modifier ( mod modifiers -- seq ) [ second swap bitand 0 > ] with filter - 0 prune dup empty? [ drop f ] [ >array ] if ; + 0 prune [ f ] [ >array ] if-empty ; : drag-loc ( -- loc ) hand-loc get-global hand-click-loc get-global v- ; diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 683eff9457..4c20abca87 100755 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -72,11 +72,9 @@ M: listener-operation invoke-command ( target command -- ) evaluate-input ; : listener-run-files ( seq -- ) - dup empty? [ - drop - ] [ + [ [ [ run-file ] each ] curry call-listener - ] if ; + ] unless-empty ; : com-end ( listener -- ) input>> interactor-eof ; diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index fe19685b53..e4018e4d20 100755 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -80,10 +80,10 @@ VALUE: grapheme-table nip swap length or 1+ ; : (>graphemes) ( str -- ) - dup empty? [ drop ] [ + [ dup first-grapheme cut-slice swap , (>graphemes) - ] if ; + ] unless-empty ; : >graphemes ( str -- graphemes ) [ (>graphemes) ] { } make ; diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 782ebae516..59b616ecc7 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -100,7 +100,7 @@ unless "windows.com.wrapper.callbacks" create ; : (finish-thunk) ( param-count thunk quot -- thunked-quot ) - [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ] + [ [ drop [ ] ] [ swap 1- '[ , , ndip ] ] if-empty ] dip compose ; : (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words ) diff --git a/basis/xml/generator/generator-tests.factor b/basis/xml/generator/generator-tests.factor index d44b713e55..052e5eab7f 100644 --- a/basis/xml/generator/generator-tests.factor +++ b/basis/xml/generator/generator-tests.factor @@ -1,3 +1,3 @@ -USING: tools.test io.streams.string xml.generator xml.writer ; +USING: tools.test io.streams.string xml.generator xml.writer accessors ; [ "" ] -[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ write-item ] with-string-writer ] unit-test +[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ body>> write-item ] with-string-writer ] unit-test diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor index 2e91c23f60..0c3ef2c1df 100644 --- a/basis/xml/tokenize/tokenize.factor +++ b/basis/xml/tokenize/tokenize.factor @@ -164,7 +164,7 @@ SYMBOL: ns-stack T{ name f "" "encoding" f } T{ name f "" "standalone" f } } diff - dup empty? [ drop ] [ throw ] if ; + [ throw ] unless-empty ; : good-version ( version -- version ) dup { "1.0" "1.1" } member? [ throw ] unless ; diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor new file mode 100644 index 0000000000..acfe4bfe1e --- /dev/null +++ b/basis/xml/writer/writer-tests.factor @@ -0,0 +1,5 @@ +IN: xml.writer.tests +USING: xml.data xml.writer tools.test ; + +[ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test +[ "ns:foo" ] [ T{ name { space "ns" } { main "foo" } } name>string ] unit-test diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 8bda10102d..ae6fddacc3 100644 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -34,13 +34,14 @@ SYMBOL: indenter : ?filter-children ( children -- no-whitespace ) xml-pprint? get [ [ dup string? [ trim-whitespace ] when ] map - [ dup empty? swap string? and not ] filter + [ [ empty? ] [ string? ] bi and not ] filter ] when ; +: name>string ( name -- string ) + [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ; + : print-name ( name -- ) - dup space>> f like - [ write CHAR: : write1 ] when* - main>> write ; + name>string write ; : print-attrs ( assoc -- ) [ diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 0f419678d1..b32bac3a18 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -208,9 +208,9 @@ M: anonymous-complement (classes-intersect?) : min-class ( class seq -- class/f ) over [ classes-intersect? ] curry filter - dup empty? [ 2drop f ] [ + [ drop f ] [ tuck [ class<= ] with all? [ peek ] [ drop f ] if - ] if ; + ] if-empty ; GENERIC: (flatten-class) ( class -- ) diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index b0e4754682..ee687c2939 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -44,11 +44,11 @@ M: builtin-class (classes-intersect?) M: anonymous-intersection (flatten-class) participants>> [ flatten-builtin-class ] map - dup empty? [ - drop builtins get sift [ (flatten-class) ] each + [ + builtins get sift [ (flatten-class) ] each ] [ unclip [ assoc-intersect ] reduce [ swap set ] assoc-each - ] if ; + ] if-empty ; M: anonymous-complement (flatten-class) drop builtins get sift [ (flatten-class) ] each ; diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index bb7e0adc62..55831fcdb4 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -8,14 +8,14 @@ PREDICATE: intersection-class < class "metaclass" word-prop intersection-class eq? ; : intersection-predicate-quot ( members -- quot ) - dup empty? [ - drop [ drop t ] + [ + [ drop t ] ] [ unclip "predicate" word-prop swap [ "predicate" word-prop [ dup ] swap [ not ] 3append [ drop f ] ] { } map>assoc alist>quot - ] if ; + ] if-empty ; : define-intersection-predicate ( class -- ) dup participants intersection-predicate-quot define-predicate ; diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 0865de16c3..531658a5e0 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -26,7 +26,7 @@ ERROR: duplicate-slot-names names ; : check-duplicate-slots ( slots -- ) slot-names duplicates - dup empty? [ drop ] [ duplicate-slot-names ] if ; + [ duplicate-slot-names ] unless-empty ; ERROR: invalid-slot-name name ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index fbb1925363..81a0db52be 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -8,14 +8,14 @@ PREDICATE: union-class < class "metaclass" word-prop union-class eq? ; : union-predicate-quot ( members -- quot ) - dup empty? [ - drop [ drop f ] + [ + [ drop f ] ] [ unclip "predicate" word-prop swap [ "predicate" word-prop [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot - ] if ; + ] if-empty ; : define-union-predicate ( class -- ) dup members union-predicate-quot define-predicate ; diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index bed1c16bcf..154e1c30ac 100755 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -21,7 +21,7 @@ M: object dispose : dispose-each ( seq -- ) [ [ [ dispose ] curry [ , ] recover ] each - ] { } make dup empty? [ drop ] [ peek rethrow ] if ; + ] { } make [ peek rethrow ] unless-empty ; : with-disposal ( object quot -- ) over [ dispose ] curry [ ] cleanup ; inline diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 93405fe7c0..e52799d10a 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -59,7 +59,7 @@ HOOK: (file-appender) io-backend ( path -- stream ) HOOK: root-directory? io-backend ( path -- ? ) M: object root-directory? ( path -- ? ) - dup empty? [ drop f ] [ [ path-separator? ] all? ] if ; + [ f ] [ [ path-separator? ] all? ] if-empty ; ERROR: no-parent-directory path ; @@ -80,7 +80,7 @@ ERROR: no-parent-directory path ; : head-path-separator? ( path1 ? -- ?' ) [ - dup empty? [ drop t ] [ first path-separator? ] if + [ t ] [ first path-separator? ] if-empty ] [ drop f ] if ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index 607076b809..b2b75509e9 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -18,7 +18,7 @@ M: growable stream-flush drop ; swap [ output-stream get ] compose with-output-stream* >string ; inline -M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ; +M: growable stream-read1 [ f ] [ pop ] if-empty ; : harden-as ( seq growble-exemplar -- newseq ) underlying>> like ; @@ -39,13 +39,13 @@ M: growable stream-read-until ] if ; M: growable stream-read - dup empty? [ - 2drop f + [ + drop f ] [ [ length swap - 0 max ] keep [ swap growable-read-until ] 2keep set-length - ] if ; + ] if-empty ; M: growable stream-read-partial stream-read ; diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 3fe1387582..9fded3eb3a 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -3,6 +3,8 @@ sequences tools.test words namespaces layouts classes classes.builtin arrays quotations ; IN: memory.tests +[ [ ] instances ] must-infer + ! Code GC wasn't kicking in when needed : leak-step 800000 f 1quotation call drop ; diff --git a/core/memory/memory.factor b/core/memory/memory.factor index cb5c5bf7e4..42527371f2 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences arrays system ; +USING: kernel continuations sequences vectors arrays system math ; IN: memory : (each-object) ( quot: ( obj -- ) -- ) @@ -9,7 +9,14 @@ IN: memory : each-object ( quot -- ) begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline +: count-instances ( quot -- n ) + 0 swap [ 1 0 ? + ] compose each-object ; inline + : instances ( quot -- seq ) - pusher [ each-object ] dip >array ; inline + #! To ensure we don't need to grow the vector while scanning + #! the heap, we do two scans, the first one just counts the + #! number of objects that satisfy the predicate. + [ count-instances 100 + ] keep swap + [ [ push-if ] 2curry each-object ] keep >array ; inline : save ( -- ) image save-image ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 454c8be6e9..a86715b073 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -182,6 +182,7 @@ SYMBOL: interactive-vocabs "sequences" "slicing" "sorting" + "stack-checker" "strings" "syntax" "tools.annotations" diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 4ada1ece9a..cd0b582cb1 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -335,6 +335,42 @@ HELP: if-empty "6" } ; +HELP: when-empty +{ $values + { "seq" sequence } { "quot" "the first quotation of an " { $link if-empty } } } +{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and the " { $snippet "quot1" } " is called." } +{ $examples "This word is equivalent to " { $link if-empty } " with an empty second quotation:" + { $example + "USING: sequences prettyprint ;" + "{ } [ { 4 5 6 } ] [ ] if-empty ." + "{ 4 5 6 }" + } + { $example + "USING: sequences prettyprint ;" + "{ } [ { 4 5 6 } ] when-empty ." + "{ 4 5 6 }" + } +} ; + +HELP: unless-empty +{ $values + { "seq" sequence } { "quot" "the second quotation of an " { $link if-empty } } } +{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped. Otherwise, the " { $snippet "quot2" } " is called on the sequence." } +{ $examples "This word is equivalent to " { $link if-empty } " with an empty first quotation:" + { $example + "USING: sequences prettyprint ;" + "{ 4 5 6 } [ ] [ sum ] if-empty ." + "15" + } + { $example + "USING: sequences prettyprint ;" + "{ 4 5 6 } [ sum ] unless-empty ." + "15" + } +} ; + +{ if-empty when-empty unless-empty } related-words + HELP: delete-all { $values { "seq" "a resizable sequence" } } { $description "Resizes the sequence to zero length, removing all elements. Not all sequences are resizable." } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index b7f36eb071..9be2db3fd7 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -32,9 +32,9 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; : if-empty ( seq quot1 quot2 -- ) [ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline -: when-empty ( seq quot1 -- ) [ ] if-empty ; inline +: when-empty ( seq quot -- ) [ ] if-empty ; inline -: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline +: unless-empty ( seq quot -- ) [ ] swap if-empty ; inline : delete-all ( seq -- ) 0 swap set-length ; @@ -91,7 +91,7 @@ M: sequence set-nth-unsafe set-nth ; ! The f object supports the sequence protocol trivially M: f length drop 0 ; M: f nth-unsafe nip ; -M: f like drop dup empty? [ drop f ] when ; +M: f like drop [ f ] when-empty ; INSTANCE: f immutable-sequence @@ -630,14 +630,14 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; 0 [ length + ] reduce ; : concat ( seq -- newseq ) - dup empty? [ - drop { } + [ + { } ] [ [ sum-lengths ] keep [ first new-resizable ] keep [ [ over push-all ] each ] keep first like - ] if ; + ] if-empty ; : joined-length ( seq glue -- n ) >r dup sum-lengths swap length 1 [-] r> length * + ; diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index db2c50173c..df397025f6 100755 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -50,9 +50,8 @@ PRIVATE> [ amb-integer ] [ nth ] bi ; : amb ( seq -- elt ) - dup empty? - [ drop fail f ] - [ unsafe-amb ] if ; inline + [ fail f ] + [ unsafe-amb ] if-empty ; inline MACRO: amb-execute ( seq -- quot ) [ length 1 - ] [ [ 1quotation ] assoc-map ] bi diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 66c9c11167..68e3a625a7 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -6,7 +6,7 @@ IN: benchmark.sockets SYMBOL: counter -: number-of-requests 1 ; +: number-of-requests 1000 ; : server-addr ( -- addr ) "127.0.0.1" 7777 ; @@ -31,12 +31,14 @@ SYMBOL: counter ] ignore-errors ; : simple-client ( -- ) - server-addr ascii [ - CHAR: b write1 flush - number-of-requests - [ CHAR: a dup write1 flush read1 assert= ] times - counter get count-down - ] with-client ; + [ + server-addr ascii [ + CHAR: b write1 flush + number-of-requests + [ CHAR: a dup write1 flush read1 assert= ] times + ] with-client + ] try + counter get count-down ; : stop-server ( -- ) server-addr ascii [ @@ -52,8 +54,13 @@ SYMBOL: counter counter get await stop-server yield yield - ] time ; + ] benchmark . flush ; -: socket-benchmarks ; +: socket-benchmarks ( -- ) + 1 clients + 10 clients + 20 clients + 40 clients + 100 clients ; MAIN: socket-benchmarks diff --git a/extra/builder/release/upload/upload.factor b/extra/builder/release/upload/upload.factor index 38f6dcb133..32a27f82fd 100644 --- a/extra/builder/release/upload/upload.factor +++ b/extra/builder/release/upload/upload.factor @@ -1,5 +1,5 @@ -USING: kernel namespaces io io.files +USING: kernel namespaces sequences arrays io io.files builder.util builder.common builder.release.archive ; @@ -8,17 +8,47 @@ IN: builder.release.upload ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: remote-location ( -- dest ) - "factorcode.org:/var/www/factorcode.org/newsite/downloads" - platform - append-path ; +SYMBOL: upload-host -: (upload) ( -- ) - { "scp" archive-name remote-location } to-strings - [ "Error uploading binary to factorcode" print ] - run-or-bail ; +SYMBOL: upload-username + +SYMBOL: upload-directory + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: remote-location ( -- dest ) + upload-directory get platform append ; + +: remote-archive-name ( -- dest ) + remote-location "/" archive-name 3append ; + +: temp-archive-name ( -- dest ) + remote-archive-name ".incomplete" append ; + +: upload-command ( -- args ) + "scp" + archive-name + [ upload-username get % "@" % upload-host get % ":" % temp-archive-name % ] "" make + 3array ; + +: rename-command ( -- args ) + [ + "ssh" , + upload-host get , + "-l" , + upload-username get , + "mv" , + temp-archive-name , + remote-archive-name , + ] { } make ; + +: upload-temp-file ( -- ) + upload-command [ "Error uploading binary to factorcode" print ] run-or-bail ; + +: rename-temp-file ( -- ) + rename-command [ "Error renaming binary on factorcode" print ] run-or-bail ; : upload ( -- ) upload-to-factorcode get - [ (upload) ] + [ upload-temp-file rename-temp-file ] when ; diff --git a/extra/cords/cords.factor b/extra/cords/cords.factor index 52cb9914b4..915744491f 100644 --- a/extra/cords/cords.factor +++ b/extra/cords/cords.factor @@ -27,7 +27,7 @@ M: multi-cord virtual@ [ first - ] [ second ] bi ; M: multi-cord virtual-seq - seqs>> dup empty? [ drop f ] [ first second ] if ; + seqs>> [ f ] [ first second ] if-empty ; : ( seqs -- cord ) dup length 2 = [ diff --git a/extra/game-input/backend/iokit/iokit.factor b/extra/game-input/backend/iokit/iokit.factor index 4a7d251425..5267dd6d6e 100755 --- a/extra/game-input/backend/iokit/iokit.factor +++ b/extra/game-input/backend/iokit/iokit.factor @@ -58,7 +58,7 @@ SINGLETON: iokit-game-input-backend buttons-matching-hash device-elements-matching length ; : ?axis ( device hash -- axis/f ) - device-elements-matching dup empty? [ drop f ] [ first ] if ; + device-elements-matching [ f ] [ first ] if-empty ; : ?x-axis ( device -- ? ) x-axis-matching-hash ?axis ; diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 94a50196a6..ccd225e6e0 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -103,11 +103,9 @@ SYMBOL: tagstack [ get-char CHAR: < = ] take-until ; : parse-text ( -- ) - read-until-< dup empty? [ - drop - ] [ + read-until-< [ make-text-tag push-tag - ] if ; + ] unless-empty ; : (parse-attributes) ( -- ) read-whitespace* diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index c7925b94be..b843c73983 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -34,9 +34,8 @@ M: no-inverse summary drop "The word cannot be used in pattern matching" ; : next ( revquot -- revquot* first ) - dup empty? [ "Badly formed math inverse" throw ] - [ unclip-slice ] if ; + [ unclip-slice ] if-empty ; : constant-word? ( word -- ? ) stack-effect @@ -116,8 +115,7 @@ M: pop-inverse inverse "pop-inverse" word-prop compose call ; : (undo) ( revquot -- ) - dup empty? [ drop ] - [ unclip-slice inverse % (undo) ] if ; + [ unclip-slice inverse % (undo) ] unless-empty ; : [undo] ( quot -- undo ) flatten fold reverse [ (undo) ] [ ] make ; diff --git a/extra/irc/ui/commandparser/commandparser.factor b/extra/irc/ui/commandparser/commandparser.factor index 2835023c0d..163517698a 100755 --- a/extra/irc/ui/commandparser/commandparser.factor +++ b/extra/irc/ui/commandparser/commandparser.factor @@ -8,7 +8,7 @@ IN: irc.ui.commandparser "irc.ui.commands" require : command ( string string -- string command ) - dup empty? [ drop "say" ] when + [ "say" ] when-empty dup "irc.ui.commands" lookup [ nip ] [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ; diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 1aebfcbfcb..457a984820 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -32,8 +32,8 @@ TUPLE: irc-tab < frame listener client window ; : dark-green T{ rgba f 0.0 0.5 0.0 1 } ; : dot-or-parens ( string -- string ) - dup empty? [ drop "." ] - [ "(" prepend ")" append ] if ; + [ "." ] + [ "(" prepend ")" append ] if-empty ; GENERIC: write-irc ( irc-message -- ) diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 2b67a3755e..5bd679d92a 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -115,8 +115,7 @@ DEFER: (d) : x.dy ( x y -- vec ) (d) wedge -1 alt*n ; : (d) ( product -- value ) - dup empty? - [ drop H{ } ] [ unclip swap [ x.dy ] 2keep dx.y alt+ ] if ; + [ H{ } ] [ unclip swap [ x.dy ] 2keep dx.y alt+ ] if-empty ; : linear-op ( vec quot -- vec ) [ @@ -211,7 +210,7 @@ DEFER: (d) : m'.m ( matrix -- matrix' ) dup flip swap m. ; : empty-matrix? ( matrix -- ? ) - dup empty? [ drop t ] [ first empty? ] if ; + [ t ] [ first empty? ] if-empty ; : ?m+ ( m1 m2 -- m3 ) over empty-matrix? [ diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 428e1221da..1b14f5bb34 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings +USING: kernel peg peg.ebnf math.parser sequences arrays strings combinators.lib math fry accessors lists combinators.short-circuit ; IN: lisp.parser diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor index 1883f56929..018b041afd 100644 --- a/extra/math/polynomials/polynomials.factor +++ b/extra/math/polynomials/polynomials.factor @@ -15,7 +15,7 @@ IN: math.polynomials : 2pad-right ( p p n -- p p ) 0 [ pad-right swap ] 2keep pad-right swap ; : pextend ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ; : pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ; -: unempty ( seq -- seq ) dup empty? [ drop { 0 } ] when ; +: unempty ( seq -- seq ) [ { 0 } ] when-empty ; : 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ; PRIVATE> diff --git a/extra/math/primes/factors/factors.factor b/extra/math/primes/factors/factors.factor index aba7e90bc9..83d53c4215 100644 --- a/extra/math/primes/factors/factors.factor +++ b/extra/math/primes/factors/factors.factor @@ -10,11 +10,11 @@ IN: math.primes.factors : (count) ( n d -- n' ) [ (factor) ] { } make - dup empty? [ drop ] [ [ first ] keep length 2array , ] if ; + [ [ first ] keep length 2array , ] unless-empty ; : (unique) ( n d -- n' ) [ (factor) ] { } make - dup empty? [ drop ] [ first , ] if ; + [ first , ] unless-empty ; : (factors) ( quot list n -- ) dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ; diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index b8256533bf..387be4d791 100755 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -57,11 +57,9 @@ SYMBOL: and-needed? : text-with-scale ( index seq -- str ) dupd nth 3digits>text swap - scale-numbers dup empty? [ - drop - ] [ + scale-numbers [ " " swap 3append - ] if ; + ] unless-empty ; : append-with-conjunction ( str1 str2 -- newstr ) over length zero? [ diff --git a/extra/money/money.factor b/extra/money/money.factor index bf9f4d3a67..fb743e15af 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -22,7 +22,7 @@ ERROR: not-a-decimal x ; : parse-decimal ( str -- ratio ) "." split1 >r dup "-" head? [ drop t "0" ] [ f swap ] if r> - [ dup empty? [ drop "0" ] when ] bi@ + [ [ "0" ] when-empty ] bi@ dup length >r [ dup string>number [ nip ] [ not-a-decimal ] if* ] bi@ r> 10 swap ^ / + swap [ neg ] when ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 8859f07340..a8025828f1 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -112,10 +112,10 @@ SYMBOL: total dup length [ picker 2array ] 2map [ drop object eq? not ] assoc-filter - dup empty? [ drop [ t ] ] [ + [ [ t ] ] [ [ (multi-predicate) ] { } assoc>map unclip [ swap [ f ] \ if 3array append [ ] like ] reduce - ] if ; + ] if-empty ; : argument-count ( methods -- n ) keys 0 [ length max ] reduce ; diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor index b487b385b9..a5d4b36c0b 100755 --- a/extra/pack/pack.factor +++ b/extra/pack/pack.factor @@ -84,7 +84,7 @@ M: string b, ( n string -- ) heap-size b, ; "\0" read-until [ drop f ] unless ; : read-c-string* ( n -- str/f ) - read [ zero? ] trim-right dup empty? [ drop f ] when ; + read [ zero? ] trim-right [ f ] when-empty ; : (read-128-ber) ( n -- n ) read1 diff --git a/extra/porter-stemmer/porter-stemmer.factor b/extra/porter-stemmer/porter-stemmer.factor index 9a2a08bcbe..7ae273f20a 100644 --- a/extra/porter-stemmer/porter-stemmer.factor +++ b/extra/porter-stemmer/porter-stemmer.factor @@ -163,11 +163,11 @@ USING: kernel math parser sequences combinators splitting ; } cond ; : -ion ( str -- newstr ) - dup empty? [ - drop "ion" + [ + "ion" ] [ dup "st" last-is? [ "ion" append ] unless - ] if ; + ] if-empty ; : step4 ( str -- newstr ) dup { diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor index f64c345694..1e6a2fb0b4 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -36,7 +36,7 @@ IN: project-euler.079 : find-source ( seq -- elt ) unzip diff prune - dup empty? [ "Topological sort failed" throw ] [ first ] if ; + [ "Topological sort failed" throw ] [ first ] if-empty ; : remove-source ( seq elt -- seq ) [ swap member? not ] curry filter ; @@ -45,7 +45,7 @@ IN: project-euler.079 dup length 1 > [ dup find-source dup , remove-source (topological-sort) ] [ - dup empty? [ drop ] [ first [ , ] each ] if + [ first [ , ] each ] unless-empty ] if ; PRIVATE> diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 4a36121046..78ede32801 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -155,11 +155,11 @@ M: lambda-word word-noise-factor : vocab-noise-factor ( vocab -- factor ) words flatten-generics [ word-noise-factor dup 20 < [ drop 0 ] when ] map - dup empty? [ drop 0 ] [ + [ 0 ] [ [ [ sum ] [ length 5 max ] bi /i ] [ supremum ] bi + - ] if ; + ] if-empty ; : noisy-vocabs ( -- alist ) vocabs [ dup vocab-noise-factor ] { } map>assoc diff --git a/extra/sequences/lib/lib-docs.factor b/extra/sequences/lib/lib-docs.factor index b2e805304e..9975da00db 100755 --- a/extra/sequences/lib/lib-docs.factor +++ b/extra/sequences/lib/lib-docs.factor @@ -18,23 +18,3 @@ HELP: each-withn "passed to the quotation given to each-withn for each element in the sequence." } { $see-also map-withn } ; - -HELP: if-seq -{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } } -{ $description "Makes an implicit check if the sequence is empty. If the sequence has any elements, " { $snippet "quot1" } " is called on it. Otherwise, the empty sequence is dropped and " { $snippet "quot2" } " is called." } -{ $example - "USING: kernel prettyprint sequences sequences.lib ;" - "{ 1 2 3 } [ sum ] [ \"empty sequence\" throw ] if-seq ." - "6" -} ; - -HELP: if-empty -{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } } -{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." } -{ $example - "USING: kernel prettyprint sequences sequences.lib ;" - "{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ." - "6" -} ; - -{ if-seq if-empty } related-words diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 76f3bb4f5b..12bdd45c46 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -63,6 +63,3 @@ IN: sequences.lib.tests [ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test - -[ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test -[ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 2eb3c44b42..225b3b7d9e 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -189,12 +189,3 @@ PRIVATE> : ?nth* ( n seq -- elt/f ? ) 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable - -: if-seq ( seq quot1 quot2 -- ) [ f like ] 2dip if* ; inline - -: if-empty ( seq quot1 quot2 -- ) swap if-seq ; inline - -: when-empty ( seq quot1 -- ) [ ] if-empty ; inline - -: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline - diff --git a/extra/units/units.factor b/extra/units/units.factor index 7604108b82..02005fcd1f 100755 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -19,8 +19,8 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; [ remove-one ] curry bi@ ; : symbolic-reduce ( seq seq -- seq seq ) - 2dup intersect dup empty? - [ drop ] [ first 2remove-one symbolic-reduce ] if ; + 2dup intersect + [ first 2remove-one symbolic-reduce ] unless-empty ; : ( n top bot -- obj ) symbolic-reduce diff --git a/extra/webapps/wiki/initial-content/Farkup.txt b/extra/webapps/wiki/initial-content/Farkup.txt index 9c1fb5e7db..b8de408588 100644 --- a/extra/webapps/wiki/initial-content/Farkup.txt +++ b/extra/webapps/wiki/initial-content/Farkup.txt @@ -34,7 +34,7 @@ CAN HAS STDIO? VISIBLE "HAI WORLD!" KTHXBYE}] -There is syntax highlighting various languages, too: +There is syntax highlighting for various languages, too: [factor{PEG: parse-request-line ( string -- triple ) #! Triple is { method url version } diff --git a/extra/webapps/wiki/initial-content/Front Page.txt b/extra/webapps/wiki/initial-content/Front Page.txt index 37351eed38..2f390f7349 100644 --- a/extra/webapps/wiki/initial-content/Front Page.txt +++ b/extra/webapps/wiki/initial-content/Front Page.txt @@ -1,5 +1,3 @@ Congratulations, you are now running your very own Wiki. -You can now click *Edit* below and begin editing the content of the [[Front Page]]. This Wiki uses [[Farkup]] to mark up text. - -Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page. +You can now click *Edit* below and begin editing the content of the [[Front Page]]. More information at [[Wiki Help]]. diff --git a/extra/webapps/wiki/initial-content/Wiki Help.txt b/extra/webapps/wiki/initial-content/Wiki Help.txt new file mode 100644 index 0000000000..9c65876377 --- /dev/null +++ b/extra/webapps/wiki/initial-content/Wiki Help.txt @@ -0,0 +1,5 @@ +This Wiki uses [[Farkup]] to mark up text. + +Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page. + +The Wiki supports hierarchical article organization. You can separate components in article names with slashes, and Wiki links only display the last component. An example: [[Factor/Features]]. diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml index 38d9d39d55..5136e4945d 100644 --- a/extra/webapps/wiki/view.xml +++ b/extra/webapps/wiki/view.xml @@ -5,7 +5,7 @@
- +

diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index dea79670a3..89a0f17706 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -41,7 +41,7 @@ - + @@ -52,7 +52,7 @@ - + diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 623c8aabe5..5f679be431 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -3,7 +3,7 @@ USING: accessors kernel hashtables calendar random assocs namespaces splitting sequences sorting math.order present io.files io.encodings.ascii -syndication +syndication farkup html.components html.forms http.server http.server.dispatchers @@ -47,7 +47,7 @@ article "ARTICLES" { :

( title -- article ) article new swap >>title ; -TUPLE: revision id title author date content description ; +TUPLE: revision id title author date content html description ; revision "REVISIONS" { { "id" "ID" INTEGER +db-assigned-id+ } @@ -55,6 +55,7 @@ revision "REVISIONS" { { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid { "date" "DATE" TIMESTAMP +not-null+ } { "content" "CONTENT" TEXT +not-null+ } + { "html" "HTML" TEXT +not-null+ } ! Farkup converted to HTML { "description" "DESCRIPTION" TEXT } } define-persistent @@ -71,6 +72,9 @@ M: revision feed-entry-url id>> revision-url ; : ( id -- revision ) revision new swap >>id ; +: compute-html ( revision -- ) + dup content>> convert-farkup >>html drop ; + : validate-title ( -- ) { { "title" [ v-one-line ] } } validate-params ; @@ -89,6 +93,9 @@ M: revision feed-entry-url id>> revision-url ;
select-tuple dup [ revision>> select-tuple ] when ; +: init-relative-link-prefix ( -- ) + URL" $wiki/view/" adjust-url present relative-link-prefix set ; + : ( -- action ) @@ -96,6 +103,7 @@ M: revision feed-entry-url id>> revision-url ; [ validate-title + init-relative-link-prefix ] >>init [ @@ -118,7 +126,7 @@ M: revision feed-entry-url id>> revision-url ; validate-integer-id "id" value select-tuple from-object - URL" $wiki/view/" adjust-url present relative-link-prefix set + init-relative-link-prefix ] >>init { wiki "view" } >>template @@ -140,11 +148,13 @@ M: revision feed-entry-url id>> revision-url ; [ title>> ] [ id>> ] bi article boa insert-tuple ; : add-revision ( revision -- ) + [ compute-html ] [ insert-tuple ] [ dup title>>
select-tuple [ amend-article ] [ add-article ] if* - ] bi ; + ] + tri ; : ( -- action ) @@ -370,11 +380,13 @@ M: revision feed-entry-url id>> revision-url ; : init-wiki ( -- ) "resource:extra/webapps/wiki/initial-content" directory* keys [ - [ ascii file-contents ] [ file-name "." split1 drop ] bi - f - swap >>title - swap >>content - "slava" >>author - now >>date - add-revision + dup file-name ".txt" ?tail [ + swap ascii file-contents + f + swap >>content + swap >>title + "slava" >>author + now >>date + add-revision + ] [ 2drop ] if ] each ; diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index 11d8fa27c2..5e94e4e88a 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -4,6 +4,7 @@ USING: accessors kernel sequences assocs io.files io.sockets io.sockets.secure io.servers.connection namespaces db db.tuples db.sqlite smtp urls logging.insomniac +html.templates.chloe http.server http.server.dispatchers http.server.redirection @@ -68,6 +69,7 @@ SYMBOL: key-file SYMBOL: dh-file : common-configuration ( -- ) + reset-templates "concatenative.org" 25 smtp-server set-global "noreply@concatenative.org" lost-password-from set-global "website@concatenative.org" insomniac-sender set-global diff --git a/extra/xml/syntax/syntax.factor b/extra/xml/syntax/syntax.factor index 283efa8412..6b765461e5 100644 --- a/extra/xml/syntax/syntax.factor +++ b/extra/xml/syntax/syntax.factor @@ -21,10 +21,10 @@ IN: xml.syntax DEFER: >> : attributes-parsed ( accum quot -- accum ) - dup empty? [ drop f parsed ] [ + [ f parsed ] [ >r \ >r parsed r> parsed [ H{ } make-assoc r> swap ] [ parsed ] each - ] if ; + ] if-empty ; : << parsed-name [