Merge branch 'master' of git://factorcode.org/git/factor
commit
d6daf688ad
|
@ -36,7 +36,7 @@ PRIVATE>
|
|||
#! pad string with = when not enough bits
|
||||
dup length dup 3 mod - cut
|
||||
[ 3 <groups> [ encode3 ] map concat ]
|
||||
[ dup empty? [ drop "" ] [ >base64-rem ] if ]
|
||||
[ [ "" ] [ >base64-rem ] if-empty ]
|
||||
bi* append ;
|
||||
|
||||
: base64> ( base64 -- str )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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? ;
|
||||
|
|
|
@ -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> ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 -- ? )
|
||||
{
|
||||
|
|
|
@ -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, ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
|||
[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
|
||||
[ "[c{int main()}]" convert-farkup ] unit-test
|
||||
|
||||
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
|
||||
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
|
||||
[ "<p><a href=\"lol.com\">lol.com</a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
|
||||
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
|
||||
[ "<p><img src='lol.jpg'/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
|
||||
[ "<p><img src='lol.jpg' alt='teh lol'/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
|
||||
[ "<p><a href='http://lol.com'>http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
|
||||
[ "<p><a href='http://lol.com'>haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
|
||||
[ "<p><a href='Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
|
||||
|
||||
"/wiki/view/" relative-link-prefix [
|
||||
[ "<p><a href='/wiki/view/Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
|
||||
] with-variable
|
||||
|
||||
[ ] [ "[{}]" convert-farkup drop ] unit-test
|
||||
|
||||
|
|
|
@ -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
|
||||
"<a" write
|
||||
" href=\"" write write "\"" write
|
||||
link-no-follow? get [ " nofollow=\"true\"" write ] when
|
||||
">" write write "</a>" write ;
|
||||
[ <a =href link-no-follow? get [ "true" =nofollow ] when a> ]
|
||||
[ write </a> ]
|
||||
bi* ;
|
||||
|
||||
: write-image-link ( href text -- )
|
||||
disable-images? get [
|
||||
2drop "<strong>Images are not allowed</strong>" write
|
||||
2drop
|
||||
<strong> "Images are not allowed" write </strong>
|
||||
] [
|
||||
escape-link
|
||||
>r "<img src=\"" write write "\"" write r>
|
||||
dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
|
||||
"/>" write
|
||||
[ <img =src ] [ [ =alt ] unless-empty img/> ] bi*
|
||||
] if ;
|
||||
|
||||
: render-code ( string mode -- string' )
|
||||
|
@ -149,32 +155,35 @@ stand-alone = (code | heading | list | table | paragraph | nl)*
|
|||
</pre>
|
||||
] with-string-writer write ;
|
||||
|
||||
GENERIC: write-farkup ( obj -- )
|
||||
GENERIC: (write-farkup) ( farkup -- )
|
||||
: <foo.> ( string -- ) <foo> write ;
|
||||
: </foo.> ( string -- ) </foo> write ;
|
||||
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; 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 ;
|
||||
|
|
|
@ -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) ;
|
||||
|
||||
|
|
|
@ -23,11 +23,11 @@ SYMBOL: rest
|
|||
|
||||
: render-validation-messages ( -- )
|
||||
form get errors>>
|
||||
dup empty? [ drop ] [
|
||||
[
|
||||
<ul "errors" =class ul>
|
||||
[ <li> escape-string write </li> ] each
|
||||
</ul>
|
||||
] 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 [
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
: <auth-boilerplate> ( responder -- responder' )
|
||||
<boilerplate> { realm "boilerplate" } >>template ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -36,7 +36,8 @@ IN: furnace.auth.features.registration
|
|||
|
||||
URL" $realm" <redirect>
|
||||
] >>submit
|
||||
<auth-boilerplate> ;
|
||||
<auth-boilerplate>
|
||||
<secure-realm-only> ;
|
||||
|
||||
: allow-registration ( login -- login )
|
||||
<register-action> "register" add-responder ;
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
<url>
|
||||
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
|
||||
[ <a =href a> ] [code] ;
|
||||
|
||||
: a-end-tag ( tag -- )
|
||||
drop [ </a> ] [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 -- )
|
||||
[ <form ] [code]
|
||||
[ compile-attr [ =method ] [code] ]
|
||||
[ compile-attr [ resolve-base-path =action ] [code] ]
|
||||
[ compile-attrs ]
|
||||
tri*
|
||||
[ form> ] [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 [ </form> ] [code] ;
|
||||
|
||||
CHLOE: form
|
||||
[
|
||||
{
|
||||
[ compile-link-attrs ]
|
||||
[ form-start-tag ]
|
||||
[ compile-children ]
|
||||
[ form-end-tag ]
|
||||
} cleave
|
||||
] compile-with-scope ;
|
||||
|
||||
STRING: button-tag-markup
|
||||
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
<button type="submit"></button>
|
||||
</t:form>
|
||||
;
|
||||
|
||||
: 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 ;
|
|
@ -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
|
||||
|
|
|
@ -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 [
|
||||
<input
|
||||
"hidden" =type
|
||||
=name
|
||||
present =value
|
||||
input/>
|
||||
] [ 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 ] [
|
||||
<url>
|
||||
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 -- )
|
||||
[ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
|
||||
|
||||
CHLOE: a
|
||||
[ a-start-tag ]
|
||||
[ process-tag-children ]
|
||||
[ drop </a> ]
|
||||
tri ;
|
||||
|
||||
: hidden-form-field ( value name -- )
|
||||
over [
|
||||
<input
|
||||
"hidden" =type
|
||||
=name
|
||||
present =value
|
||||
input/>
|
||||
] [ 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 -- )
|
||||
[
|
||||
[
|
||||
<form
|
||||
{
|
||||
[ link-attrs ]
|
||||
[ "method" optional-attr "post" or =method ]
|
||||
[ "action" required-attr resolve-base-path =action ]
|
||||
[ attrs>> non-chloe-attrs-only print-attrs ]
|
||||
} cleave
|
||||
form>
|
||||
]
|
||||
[ form-magic ] bi
|
||||
] with-scope ;
|
||||
|
||||
CHLOE: form
|
||||
[ form-start-tag ]
|
||||
[ process-tag-children ]
|
||||
[ drop </form> ]
|
||||
tri ;
|
||||
|
||||
STRING: button-tag-markup
|
||||
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
<button type="submit"></button>
|
||||
</t:form>
|
||||
;
|
||||
|
||||
: 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
|
||||
|
|
|
@ -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
|
||||
|
||||
: <redirect> ( url -- response )
|
||||
|
@ -32,10 +32,14 @@ TUPLE: secure-only < filter-responder ;
|
|||
|
||||
C: <secure-only> secure-only
|
||||
|
||||
: if-secure ( quot -- )
|
||||
>r url get protocol>> "http" =
|
||||
[ url get <secure-redirect> ]
|
||||
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 <secure-redirect> ]
|
||||
} cond ; inline
|
||||
|
||||
M: secure-only call-responder*
|
||||
'[ , , call-next-method ] if-secure ;
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -5,10 +5,13 @@ USING: kernel sequences sequences.private namespaces math
|
|||
math.ranges combinators macros quotations fry arrays ;
|
||||
IN: generalizations
|
||||
|
||||
MACRO: narray ( n -- quot )
|
||||
[ <reversed> ] [ '[ , f <array> ] ] bi
|
||||
MACRO: nsequence ( n seq -- quot )
|
||||
[ drop <reversed> ] [ '[ , , new-sequence ] ] 2bi
|
||||
[ '[ @ [ , swap set-nth-unsafe ] keep ] ] reduce ;
|
||||
|
||||
MACRO: narray ( n -- quot )
|
||||
'[ , { } nsequence ] ;
|
||||
|
||||
MACRO: firstn ( n -- )
|
||||
dup zero? [ drop [ drop ] ] [
|
||||
[ [ '[ , _ nth-unsafe ] ] map ]
|
||||
|
|
|
@ -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* ;
|
||||
|
|
|
@ -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. ;
|
||||
|
||||
|
|
|
@ -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 -- )
|
||||
[
|
||||
|
|
|
@ -13,10 +13,10 @@ IN: hints
|
|||
dup length <reversed>
|
||||
[ (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 [
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
>>
|
||||
|
|
|
@ -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
|
||||
] [
|
||||
<span =style span> call </span>
|
||||
] 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
|
||||
] [
|
||||
<div =style div> call </div>
|
||||
] if ; inline
|
||||
] if-empty ; inline
|
||||
|
||||
: format-html-div ( string style stream -- )
|
||||
stream>> [
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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> 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
|
||||
[ <title> write-title </title> ] [ write-title ] if ;
|
||||
[ <title> write-title </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 <style> write-style </style> ;
|
||||
drop [ <style> write-style </style> ] [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 <file-reader> 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 <file-reader> read-xml process-chloe ;
|
||||
nested-template? get
|
||||
[ nested-template-quot ] [ template-quot ] if
|
||||
assert-depth ;
|
||||
|
||||
INSTANCE: chloe template
|
||||
|
|
|
@ -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 -- )
|
||||
"</" [write]
|
||||
name>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 ;
|
|
@ -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
|
|
@ -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>> ] [ <mirror> ] 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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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* ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -95,11 +95,11 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ;
|
|||
<PRIVATE
|
||||
|
||||
: parse-inet6 ( string -- seq )
|
||||
dup empty? [ drop f ] [
|
||||
[ f ] [
|
||||
":" split [
|
||||
hex> [ "Component not a number" throw ] unless*
|
||||
] B{ } map-as
|
||||
] if ;
|
||||
] if-empty ;
|
||||
|
||||
: pad-inet6 ( string1 string2 -- seq )
|
||||
2dup [ length ] bi@ + 8 swap -
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
<tr>
|
||||
|
|
|
@ -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
|
|
@ -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> quote
|
|||
UNION: special local quote local-word local-reader local-writer ;
|
||||
|
||||
: load-locals-quot ( args -- quot )
|
||||
dup empty? [
|
||||
drop [ ]
|
||||
[
|
||||
[ ]
|
||||
] [
|
||||
dup [ local-reader? ] contains? [
|
||||
<reversed> [
|
||||
|
@ -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 [
|
||||
<local-reader>
|
||||
|
|
|
@ -18,14 +18,14 @@ SYMBOL: insomniac-recipients
|
|||
] "" make ;
|
||||
|
||||
: (email-log-report) ( service word-names -- )
|
||||
dupd ?analyze-log dup empty? [ 2drop ] [
|
||||
dupd ?analyze-log [ drop ] [
|
||||
<email>
|
||||
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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 } <branch> ;
|
||||
|
||||
METHOD: sift-down { singleton-heap empty-heap }
|
||||
: singleton-sift-down ( value prio singleton empty -- heap )
|
||||
3dup drop prio>> <= [ <branch> ] [
|
||||
drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip
|
||||
<singleton-heap> <persistent-heap> <branch>
|
||||
] if ;
|
||||
|
||||
M: empty-heap sift-down
|
||||
over singleton-heap? [ singleton-sift-down ] [ <branch> ] 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
|
||||
<branch> ;
|
||||
|
||||
METHOD: sift-down { branch branch }
|
||||
M: branch sift-down ! both arguments are branches
|
||||
3dup [ prio>> <= ] both-with? [ <branch> ] [
|
||||
2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if
|
||||
] if ;
|
||||
|
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -11,9 +11,9 @@ IN: stack-checker.backend
|
|||
: push-d ( obj -- ) meta-d get push ;
|
||||
|
||||
: pop-d ( -- obj )
|
||||
meta-d get dup empty? [
|
||||
drop <value> dup 1array #introduce, d-in inc
|
||||
] [ pop ] if ;
|
||||
meta-d get [
|
||||
<value> 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 )
|
||||
[
|
||||
|
|
|
@ -31,10 +31,10 @@ SYMBOL: +bottom+
|
|||
|
||||
: unify-values ( values -- phi-out )
|
||||
remove-bottom
|
||||
dup empty? [ drop <value> ] [
|
||||
[ <value> ] [
|
||||
[ known ] map dup all-eq?
|
||||
[ first make-known ] [ drop <value> ] 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 ;
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
@ -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 }
|
||||
}
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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. ;
|
||||
|
|
|
@ -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> 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-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
|
||||
|
|
|
@ -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) [
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -108,7 +108,7 @@ SYMBOL: double-click-timeout
|
|||
|
||||
: drag-gesture ( -- )
|
||||
hand-buttons get-global
|
||||
dup empty? [ drop ] [ first <drag> button-gesture ] if ;
|
||||
[ first <drag> 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 <column> prune dup empty? [ drop f ] [ >array ] if ;
|
||||
0 <column> prune [ f ] [ >array ] if-empty ;
|
||||
|
||||
: drag-loc ( -- loc )
|
||||
hand-loc get-global hand-click-loc get-global v- ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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\"/></body></html>" ]
|
||||
[ "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
|
||||
|
|
|
@ -164,7 +164,7 @@ SYMBOL: ns-stack
|
|||
T{ name f "" "encoding" f }
|
||||
T{ name f "" "standalone" f }
|
||||
} diff
|
||||
dup empty? [ drop ] [ <extra-attrs> throw ] if ;
|
||||
[ <extra-attrs> throw ] unless-empty ;
|
||||
|
||||
: good-version ( version -- version )
|
||||
dup { "1.0" "1.1" } member? [ <bad-version> throw ] unless ;
|
||||
|
|
|
@ -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
|
|
@ -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 -- )
|
||||
[
|
||||
|
|
|
@ -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 -- )
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -18,7 +18,7 @@ M: growable stream-flush drop ;
|
|||
<string-writer> 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 ;
|
||||
|
|
|
@ -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 <array> 1quotation call drop ;
|
||||
|
||||
|
|
|
@ -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 + <vector> ] keep swap
|
||||
[ [ push-if ] 2curry each-object ] keep >array ; inline
|
||||
|
||||
: save ( -- ) image save-image ;
|
||||
|
|
|
@ -182,6 +182,7 @@ SYMBOL: interactive-vocabs
|
|||
"sequences"
|
||||
"slicing"
|
||||
"sorting"
|
||||
"stack-checker"
|
||||
"strings"
|
||||
"syntax"
|
||||
"tools.annotations"
|
||||
|
|
|
@ -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." }
|
||||
|
|
|
@ -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 * + ;
|
||||
|
|
|
@ -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 - ] [ <enum> [ 1quotation ] assoc-map ] bi
|
||||
|
|
|
@ -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 <inet4> ;
|
||||
|
||||
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
: <cord> ( seqs -- cord )
|
||||
dup length 2 = [
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue