factor: fix up XML syntax. fix some CAPS> words.
parent
e239b7f6f7
commit
b21c5563ef
|
@ -366,17 +366,17 @@ TYPEDEF: ACCEL* LPACCEL ;
|
||||||
TYPEDEF: DWORD COLORREF ;
|
TYPEDEF: DWORD COLORREF ;
|
||||||
TYPEDEF: DWORD* LPCOLORREF ;
|
TYPEDEF: DWORD* LPCOLORREF ;
|
||||||
|
|
||||||
: RGB ( r g b -- COLORREF )
|
: rgb ( r g b -- COLORREF )
|
||||||
{ 16 8 0 } bitfield ; inline
|
{ 16 8 0 } bitfield ; inline
|
||||||
: >RGB< ( COLORREF -- r g b )
|
: >rgb< ( COLORREF -- r g b )
|
||||||
[ 0xff bitand ]
|
[ 0xff bitand ]
|
||||||
[ -8 shift 0xff bitand ]
|
[ -8 shift 0xff bitand ]
|
||||||
[ -16 shift 0xff bitand ] tri ;
|
[ -16 shift 0xff bitand ] tri ;
|
||||||
|
|
||||||
: color>RGB ( color -- COLORREF )
|
: color>rgb ( color -- COLORREF )
|
||||||
>rgba-components drop [ 255 * >integer ] tri@ RGB ;
|
>rgba-components drop [ 255 * >integer ] tri@ rgb ;
|
||||||
: RGB>color ( COLORREF -- color )
|
: rgb>color ( COLORREF -- color )
|
||||||
>RGB< [ 1/255. * >float ] tri@ 1.0 <rgba> ;
|
>rgb< [ 1/255. * >float ] tri@ 1.0 <rgba> ;
|
||||||
|
|
||||||
STRUCT: TEXTMETRICW
|
STRUCT: TEXTMETRICW
|
||||||
{ tmHeight LONG }
|
{ tmHeight LONG }
|
||||||
|
|
|
@ -48,8 +48,8 @@ CONSTANT: ssa-dwFlags flags{ SSA_GLYPHS SSA_FALLBACK SSA_TAB } ;
|
||||||
[ check-ole32-error ] [ |ScriptStringFree void* deref ] bi* ;
|
[ check-ole32-error ] [ |ScriptStringFree void* deref ] bi* ;
|
||||||
|
|
||||||
: set-dc-colors ( dc font -- )
|
: set-dc-colors ( dc font -- )
|
||||||
[ background>> color>RGB SetBkColor drop ]
|
[ background>> color>rgb SetBkColor drop ]
|
||||||
[ foreground>> color>RGB SetTextColor drop ] 2bi ;
|
[ foreground>> color>rgb SetTextColor drop ] 2bi ;
|
||||||
|
|
||||||
: selection-start/end ( script-string -- iMinSel iMaxSel )
|
: selection-start/end ( script-string -- iMinSel iMaxSel )
|
||||||
string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
|
string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
|
||||||
|
|
|
@ -74,12 +74,12 @@ CHLOE: a
|
||||||
[
|
[
|
||||||
[ a-attrs ]
|
[ a-attrs ]
|
||||||
[ compile-children>xml-string ] bi
|
[ compile-children>xml-string ] bi
|
||||||
[ <unescaped> XML[[ <a><-></a> XML]] second swap >>attrs ]
|
[ <unescaped> XML-CHUNK[[ <a><-></a> ]] second swap >>attrs ]
|
||||||
[xml-code]
|
[xml-code]
|
||||||
] compile-with-scope ;
|
] compile-with-scope ;
|
||||||
|
|
||||||
CHLOE: base
|
CHLOE: base
|
||||||
compile-a-url [ XML[[ <base href=<->/> XML]] ] [xml-code] ;
|
compile-a-url [ XML-CHUNK[[ <base href=<->/> ]] ] [xml-code] ;
|
||||||
|
|
||||||
: hidden-nested-fields ( -- xml )
|
: hidden-nested-fields ( -- xml )
|
||||||
nested-forms get " " join f like nested-forms-key
|
nested-forms get " " join f like nested-forms-key
|
||||||
|
@ -93,7 +93,7 @@ CHLOE: base
|
||||||
_ render-hidden
|
_ render-hidden
|
||||||
hidden-nested-fields
|
hidden-nested-fields
|
||||||
form-modifications
|
form-modifications
|
||||||
XML[[ <div style="display: none;"><-><-><-></div> XML]]
|
XML-CHUNK[[ <div style="display: none;"><-><-><-></div> ]]
|
||||||
] [code] ;
|
] [code] ;
|
||||||
|
|
||||||
: (compile-form-attrs) ( method action -- )
|
: (compile-form-attrs) ( method action -- )
|
||||||
|
@ -122,18 +122,18 @@ CHLOE: form
|
||||||
[ hidden-fields ]
|
[ hidden-fields ]
|
||||||
[ compile-children>xml-string ] tri
|
[ compile-children>xml-string ] tri
|
||||||
[
|
[
|
||||||
<unescaped> XML[[ <form><-><-></form> XML]] second
|
<unescaped> XML-CHUNK[[ <form><-><-></form> ]] second
|
||||||
swap >>attrs
|
swap >>attrs
|
||||||
write-xml
|
write-xml
|
||||||
] [code]
|
] [code]
|
||||||
] compile-with-scope ;
|
] compile-with-scope ;
|
||||||
|
|
||||||
: button-tag-markup ( -- xml )
|
: button-tag-markup ( -- xml )
|
||||||
<XML
|
XML-DOC[[
|
||||||
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
|
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
<div style="display: inline;"><button type="submit"></button></div>
|
<div style="display: inline;"><button type="submit"></button></div>
|
||||||
</t:form>
|
</t:form>
|
||||||
XML> body>> clone ;
|
]] body>> clone ;
|
||||||
|
|
||||||
: add-tag-attrs ( attrs tag -- )
|
: add-tag-attrs ( attrs tag -- )
|
||||||
attrs>> swap assoc-union! drop ;
|
attrs>> swap assoc-union! drop ;
|
||||||
|
|
|
@ -23,7 +23,7 @@ PRIVATE<
|
||||||
|
|
||||||
: (render-recaptcha) ( url -- xml )
|
: (render-recaptcha) ( url -- xml )
|
||||||
dup
|
dup
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<script type="text/javascript"
|
<script type="text/javascript"
|
||||||
src=<->>
|
src=<->>
|
||||||
</script>
|
</script>
|
||||||
|
@ -36,7 +36,7 @@ PRIVATE<
|
||||||
<input type="hidden" name="recaptcha_response_field"
|
<input type="hidden" name="recaptcha_response_field"
|
||||||
value="manual_challenge"/>
|
value="manual_challenge"/>
|
||||||
</noscript>
|
</noscript>
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
: recaptcha-url ( secure? -- ? )
|
: recaptcha-url ( secure? -- ? )
|
||||||
"https" "http" ? "://www.google.com/recaptcha/api/challenge" append
|
"https" "http" ? "://www.google.com/recaptcha/api/challenge" append
|
||||||
|
|
|
@ -86,7 +86,7 @@ M: object modify-form drop f ;
|
||||||
|
|
||||||
: hidden-form-field ( value name -- xml )
|
: hidden-form-field ( value name -- xml )
|
||||||
over [
|
over [
|
||||||
XML[[ <input type="hidden" value=<-> name=<->/> XML]]
|
XML-CHUNK[[ <input type="hidden" value=<-> name=<->/> ]]
|
||||||
] [ drop ] if ;
|
] [ drop ] if ;
|
||||||
|
|
||||||
CONSTANT: nested-forms-key "__n" ;
|
CONSTANT: nested-forms-key "__n" ;
|
||||||
|
|
|
@ -78,7 +78,7 @@ in: compiler.tree.dead-code.tests
|
||||||
|
|
||||||
{ [ stream-read1 drop 1 2 ] } [ [ stream-read1 [ 1 2 ] dip drop ] optimize-quot ] unit-test
|
{ [ stream-read1 drop 1 2 ] } [ [ stream-read1 [ 1 2 ] dip drop ] optimize-quot ] unit-test
|
||||||
|
|
||||||
{ [ over >R + R> ] } [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
|
{ [ over >r + r> ] } [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
|
||||||
|
|
||||||
{ [ [ ] [ ] if ] } [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test
|
{ [ [ ] [ ] if ] } [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -1,11 +1,11 @@
|
||||||
USING: compiler.tree help.markup help.syntax kernel ;
|
USING: compiler.tree help.markup help.syntax kernel ;
|
||||||
in: compiler.tree.debugger
|
in: compiler.tree.debugger
|
||||||
|
|
||||||
HELP: >R
|
HELP: >r
|
||||||
{ $description "Symbol in the debugger to show that the top datastack item is moved to the retainstack." } ;
|
{ $description "Symbol in the debugger to show that the top datastack item is moved to the retainstack." } ;
|
||||||
|
|
||||||
HELP: R>
|
HELP: r>
|
||||||
{ $description "Symbol in the debugger to show that the top retainstack item os moved to the datastack." } ;
|
{ $description "Symbol in the debugger to show that the top retainstack item is moved to the datastack." } ;
|
||||||
|
|
||||||
HELP: #>r?
|
HELP: #>r?
|
||||||
{ $values { "#shuffle" #shuffle } { "?" boolean } }
|
{ $values { "#shuffle" #shuffle } { "?" boolean } }
|
||||||
|
|
|
@ -75,12 +75,12 @@ M: shuffle-node pprint* effect>> effect>string text ;
|
||||||
[ out-d>> length 1 = ]
|
[ out-d>> length 1 = ]
|
||||||
} 1&& ;
|
} 1&& ;
|
||||||
|
|
||||||
SYMBOLS: >R R> ;
|
SYMBOLS: >r r> ;
|
||||||
|
|
||||||
M: #shuffle node>quot
|
M: #shuffle node>quot
|
||||||
{
|
{
|
||||||
{ [ dup #>r? ] [ drop \ >R , ] }
|
{ [ dup #>r? ] [ drop \ >r , ] }
|
||||||
{ [ dup #r>? ] [ drop \ R> , ] }
|
{ [ dup #r>? ] [ drop \ r> , ] }
|
||||||
{
|
{
|
||||||
[ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
|
[ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
|
||||||
[
|
[
|
||||||
|
|
|
@ -10,13 +10,13 @@ in: compiler.tree.modular-arithmetic.tests
|
||||||
: test-modular-arithmetic ( quot -- quot' )
|
: test-modular-arithmetic ( quot -- quot' )
|
||||||
cleaned-up-tree nodes>quot ;
|
cleaned-up-tree nodes>quot ;
|
||||||
|
|
||||||
{ [ >R >fixnum R> >fixnum fixnum+fast ] }
|
{ [ >r >fixnum r> >fixnum fixnum+fast ] }
|
||||||
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
|
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
|
||||||
|
|
||||||
{ [ +-integer-integer dup >fixnum ] }
|
{ [ +-integer-integer dup >fixnum ] }
|
||||||
[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test
|
[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test
|
||||||
|
|
||||||
{ [ >R >fixnum R> >fixnum fixnum+fast 4 fixnum*fast ] }
|
{ [ >r >fixnum r> >fixnum fixnum+fast 4 fixnum*fast ] }
|
||||||
[ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test
|
[ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test
|
||||||
|
|
||||||
TUPLE: declared-fixnum { x fixnum } ;
|
TUPLE: declared-fixnum { x fixnum } ;
|
||||||
|
@ -144,7 +144,7 @@ TUPLE: declared-fixnum { x fixnum } ;
|
||||||
{ [ drop 0 ] }
|
{ [ drop 0 ] }
|
||||||
[ [ >integer 1 mod ] test-modular-arithmetic ] unit-test
|
[ [ >integer 1 mod ] test-modular-arithmetic ] unit-test
|
||||||
|
|
||||||
{ [ >fixnum 255 >R R> fixnum-bitand ] }
|
{ [ >fixnum 255 >r r> fixnum-bitand ] }
|
||||||
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
|
|
|
@ -53,33 +53,33 @@ PRIVATE>
|
||||||
! Condition codes
|
! Condition codes
|
||||||
symbol: cond-code
|
symbol: cond-code
|
||||||
|
|
||||||
: >CC ( n -- )
|
: n>CC ( n -- )
|
||||||
cond-code set ;
|
cond-code set ;
|
||||||
|
|
||||||
: CC> ( -- n )
|
: CC>n ( -- n )
|
||||||
! Default value is 0b1110 AL (= always)
|
! Default value is 0b1110 AL (= always)
|
||||||
cond-code [ f ] change 0b1110 or ;
|
cond-code [ f ] change 0b1110 or ;
|
||||||
|
|
||||||
: EQ ( -- ) 0b0000 >CC ;
|
: EQ ( -- ) 0b0000 n>CC ;
|
||||||
: NE ( -- ) 0b0001 >CC ;
|
: NE ( -- ) 0b0001 n>CC ;
|
||||||
: CS ( -- ) 0b0010 >CC ;
|
: CS ( -- ) 0b0010 n>CC ;
|
||||||
: CC ( -- ) 0b0011 >CC ;
|
: CC ( -- ) 0b0011 n>CC ;
|
||||||
: LO ( -- ) 0b0100 >CC ;
|
: LO ( -- ) 0b0100 n>CC ;
|
||||||
: PL ( -- ) 0b0101 >CC ;
|
: PL ( -- ) 0b0101 n>CC ;
|
||||||
: VS ( -- ) 0b0110 >CC ;
|
: VS ( -- ) 0b0110 n>CC ;
|
||||||
: VC ( -- ) 0b0111 >CC ;
|
: VC ( -- ) 0b0111 n>CC ;
|
||||||
: HI ( -- ) 0b1000 >CC ;
|
: HI ( -- ) 0b1000 n>CC ;
|
||||||
: LS ( -- ) 0b1001 >CC ;
|
: LS ( -- ) 0b1001 n>CC ;
|
||||||
: GE ( -- ) 0b1010 >CC ;
|
: GE ( -- ) 0b1010 n>CC ;
|
||||||
: LT ( -- ) 0b1011 >CC ;
|
: LT ( -- ) 0b1011 n>CC ;
|
||||||
: GT ( -- ) 0b1100 >CC ;
|
: GT ( -- ) 0b1100 n>CC ;
|
||||||
: LE ( -- ) 0b1101 >CC ;
|
: LE ( -- ) 0b1101 n>CC ;
|
||||||
: AL ( -- ) 0b1110 >CC ;
|
: AL ( -- ) 0b1110 n>CC ;
|
||||||
: NV ( -- ) 0b1111 >CC ;
|
: NV ( -- ) 0b1111 n>CC ;
|
||||||
|
|
||||||
PRIVATE<
|
PRIVATE<
|
||||||
|
|
||||||
: (insn) ( n -- ) CC> 28 shift bitor , ;
|
: (insn) ( n -- ) CC>n 28 shift bitor , ;
|
||||||
|
|
||||||
: insn ( bitspec -- ) bitfield (insn) ; inline
|
: insn ( bitspec -- ) bitfield (insn) ; inline
|
||||||
|
|
||||||
|
@ -102,12 +102,12 @@ PRIVATE>
|
||||||
|
|
||||||
: S ( -- ) updates-cond-code on ;
|
: S ( -- ) updates-cond-code on ;
|
||||||
|
|
||||||
: S> ( -- ? ) updates-cond-code [ f ] change ;
|
: S>? ( -- ? ) updates-cond-code [ f ] change ;
|
||||||
|
|
||||||
PRIVATE<
|
PRIVATE<
|
||||||
|
|
||||||
: sinsn ( bitspec -- )
|
: sinsn ( bitspec -- )
|
||||||
bitfield S> [ 20 2^ bitor ] when (insn) ; inline
|
bitfield S>? [ 20 2^ bitor ] when (insn) ; inline
|
||||||
|
|
||||||
GENERIC#: shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n ) ;
|
GENERIC#: shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n ) ;
|
||||||
|
|
||||||
|
|
|
@ -218,7 +218,7 @@ CONSTANT: invalid-url "javascript:alert('Invalid URL in farkup');" ;
|
||||||
|
|
||||||
: render-code ( string mode -- xml )
|
: render-code ( string mode -- xml )
|
||||||
[ string-lines ] dip htmlize-lines
|
[ string-lines ] dip htmlize-lines
|
||||||
XML[[ <pre><-></pre> XML]] ;
|
XML-CHUNK[[ <pre><-></pre> ]] ;
|
||||||
|
|
||||||
GENERIC: (write-farkup) ( farkup -- xml ) ;
|
GENERIC: (write-farkup) ( farkup -- xml ) ;
|
||||||
|
|
||||||
|
@ -243,15 +243,15 @@ M: table (write-farkup) "table" farkup-inside ;
|
||||||
|
|
||||||
: write-link ( href text -- xml )
|
: write-link ( href text -- xml )
|
||||||
[ check-url link-no-follow? get "nofollow" and ] dip
|
[ check-url link-no-follow? get "nofollow" and ] dip
|
||||||
XML[[ <a href=<-> rel=<->><-></a> XML]] ;
|
XML-CHUNK[[ <a href=<-> rel=<->><-></a> ]] ;
|
||||||
|
|
||||||
: write-image-link ( href text -- xml )
|
: write-image-link ( href text -- xml )
|
||||||
disable-images? get [
|
disable-images? get [
|
||||||
2drop
|
2drop
|
||||||
XML[[ <strong>Images are not allowed</strong> XML]]
|
XML-CHUNK[[ <strong>Images are not allowed</strong> ]]
|
||||||
] [
|
] [
|
||||||
[ check-url ] [ f like ] bi*
|
[ check-url ] [ f like ] bi*
|
||||||
XML[[ <img src=<-> alt=<->/> XML]]
|
XML-CHUNK[[ <img src=<-> alt=<->/> ]]
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: open-link ( link -- href text )
|
: open-link ( link -- href text )
|
||||||
|
@ -267,15 +267,15 @@ M: code (write-farkup)
|
||||||
[ string>> ] [ mode>> ] bi render-code ;
|
[ string>> ] [ mode>> ] bi render-code ;
|
||||||
|
|
||||||
M: line (write-farkup)
|
M: line (write-farkup)
|
||||||
drop XML[[ <hr/> XML]] ;
|
drop XML-CHUNK[[ <hr/> ]] ;
|
||||||
|
|
||||||
M: line-break (write-farkup)
|
M: line-break (write-farkup)
|
||||||
drop XML[[ <br/> XML]] ;
|
drop XML-CHUNK[[ <br/> ]] ;
|
||||||
|
|
||||||
M: table-row (write-farkup)
|
M: table-row (write-farkup)
|
||||||
child>>
|
child>>
|
||||||
[ (write-farkup) XML[[ <td><-></td> XML]] ] map
|
[ (write-farkup) XML-CHUNK[[ <td><-></td> ]] ] map
|
||||||
XML[[ <tr><-></tr> XML]] ;
|
XML-CHUNK[[ <tr><-></tr> ]] ;
|
||||||
|
|
||||||
M: string (write-farkup) ;
|
M: string (write-farkup) ;
|
||||||
|
|
||||||
|
|
|
@ -199,7 +199,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
|
||||||
|
|
||||||
! Test xml in html components
|
! Test xml in html components
|
||||||
{ } [
|
{ } [
|
||||||
XML[[ <foo/> XML]] "xmltest" set-value
|
XML-CHUNK[[ <foo/> ]] "xmltest" set-value
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{ "<foo/>" } [
|
{ "<foo/>" } [
|
||||||
|
|
|
@ -46,10 +46,10 @@ M: label render*
|
||||||
singleton: hidden
|
singleton: hidden
|
||||||
|
|
||||||
M: hidden render*
|
M: hidden render*
|
||||||
drop XML[[ <input value=<-> name=<-> type="hidden"/> XML]] ;
|
drop XML-CHUNK[[ <input value=<-> name=<-> type="hidden"/> ]] ;
|
||||||
|
|
||||||
: render-field ( value name size type -- xml )
|
: render-field ( value name size type -- xml )
|
||||||
XML[[ <input value=<-> name=<-> size=<-> type=<->/> XML]] ;
|
XML-CHUNK[[ <input value=<-> name=<-> size=<-> type=<->/> ]] ;
|
||||||
|
|
||||||
TUPLE: field size ;
|
TUPLE: field size ;
|
||||||
|
|
||||||
|
@ -77,12 +77,12 @@ TUPLE: textarea rows cols ;
|
||||||
M:: textarea render* ( value name area -- xml )
|
M:: textarea render* ( value name area -- xml )
|
||||||
area rows>> :> rows
|
area rows>> :> rows
|
||||||
area cols>> :> cols
|
area cols>> :> cols
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<textarea
|
<textarea
|
||||||
name=<-name->
|
name=<-name->
|
||||||
rows=<-rows->
|
rows=<-rows->
|
||||||
cols=<-cols->><-value-></textarea>
|
cols=<-cols->><-value-></textarea>
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
! Choice
|
! Choice
|
||||||
TUPLE: choice size multiple choices ;
|
TUPLE: choice size multiple choices ;
|
||||||
|
@ -92,7 +92,7 @@ TUPLE: choice size multiple choices ;
|
||||||
|
|
||||||
: render-option ( text selected? -- xml )
|
: render-option ( text selected? -- xml )
|
||||||
"selected" and swap
|
"selected" and swap
|
||||||
XML[[ <option selected=<->><-></option> XML]] ;
|
XML-CHUNK[[ <option selected=<->><-></option> ]] ;
|
||||||
|
|
||||||
: render-options ( value choice -- xml )
|
: render-options ( value choice -- xml )
|
||||||
[ choices>> value ] [ multiple>> ] bi
|
[ choices>> value ] [ multiple>> ] bi
|
||||||
|
@ -103,10 +103,10 @@ M:: choice render* ( value name choice -- xml )
|
||||||
choice size>> :> size
|
choice size>> :> size
|
||||||
choice multiple>> "true" and :> multiple
|
choice multiple>> "true" and :> multiple
|
||||||
value choice render-options :> contents
|
value choice render-options :> contents
|
||||||
XML[[ <select
|
XML-CHUNK[[ <select
|
||||||
name=<-name->
|
name=<-name->
|
||||||
size=<-size->
|
size=<-size->
|
||||||
multiple=<-multiple->><-contents-></select> XML]] ;
|
multiple=<-multiple->><-contents-></select> ]] ;
|
||||||
|
|
||||||
! Checkboxes
|
! Checkboxes
|
||||||
TUPLE: checkbox label ;
|
TUPLE: checkbox label ;
|
||||||
|
@ -116,9 +116,9 @@ TUPLE: checkbox label ;
|
||||||
|
|
||||||
M: checkbox render*
|
M: checkbox render*
|
||||||
[ "true" and ] [ ] [ label>> ] tri*
|
[ "true" and ] [ ] [ label>> ] tri*
|
||||||
XML[[ <input
|
XML-CHUNK[[ <input
|
||||||
type="checkbox"
|
type="checkbox"
|
||||||
checked=<-> name=<->><-></input> XML]] ;
|
checked=<-> name=<->><-></input> ]] ;
|
||||||
|
|
||||||
! Link components
|
! Link components
|
||||||
GENERIC: link-title ( obj -- string ) ;
|
GENERIC: link-title ( obj -- string ) ;
|
||||||
|
@ -142,7 +142,7 @@ TUPLE: link target ;
|
||||||
M: link render*
|
M: link render*
|
||||||
nip swap
|
nip swap
|
||||||
[ target>> ] [ [ link-href ] [ link-title ] bi ] bi*
|
[ target>> ] [ [ link-href ] [ link-title ] bi ] bi*
|
||||||
XML[[ <a target=<-> href=<->><-></a> XML]] ;
|
XML-CHUNK[[ <a target=<-> href=<->><-></a> ]] ;
|
||||||
|
|
||||||
! XMode code component
|
! XMode code component
|
||||||
TUPLE: code mode ;
|
TUPLE: code mode ;
|
||||||
|
|
|
@ -109,6 +109,6 @@ C: <validation-error-state> validation-error-state ;
|
||||||
: render-validation-errors ( -- )
|
: render-validation-errors ( -- )
|
||||||
form get errors>>
|
form get errors>>
|
||||||
[
|
[
|
||||||
[ XML[[ <li><-></li> XML]] ] map
|
[ XML-CHUNK[[ <li><-></li> ]] ] map
|
||||||
XML[[ <ul class="errors"><-></ul> XML]] write-xml
|
XML-CHUNK[[ <ul class="errors"><-></ul> ]] write-xml
|
||||||
] unless-empty ;
|
] unless-empty ;
|
||||||
|
|
|
@ -10,7 +10,7 @@ M: empty-prolog write-xml drop ;
|
||||||
: <empty-prolog> ( -- prolog ) \ empty-prolog new ;
|
: <empty-prolog> ( -- prolog ) \ empty-prolog new ;
|
||||||
|
|
||||||
: simple-page ( title head body -- xml )
|
: simple-page ( title head body -- xml )
|
||||||
<XML
|
XML-DOC[[
|
||||||
<!DOCTYPE html>
|
<!DOCTYPE html>
|
||||||
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
|
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
|
||||||
<head>
|
<head>
|
||||||
|
@ -19,13 +19,13 @@ M: empty-prolog write-xml drop ;
|
||||||
</head>
|
</head>
|
||||||
<body><-></body>
|
<body><-></body>
|
||||||
</html>
|
</html>
|
||||||
XML> <empty-prolog> >>prolog ;
|
]] <empty-prolog> >>prolog ;
|
||||||
|
|
||||||
: render-error ( message -- xml )
|
: render-error ( message -- xml )
|
||||||
XML[[ <span class="error"><-></span> XML]] ;
|
XML-CHUNK[[ <span class="error"><-></span> ]] ;
|
||||||
|
|
||||||
: simple-link ( xml url -- xml' )
|
: simple-link ( xml url -- xml' )
|
||||||
url-encode swap XML[[ <a href=<->><-></a> XML]] ;
|
url-encode swap XML-CHUNK[[ <a href=<->><-></a> ]] ;
|
||||||
|
|
||||||
: simple-image ( url -- xml )
|
: simple-image ( url -- xml )
|
||||||
url-encode XML[[ <img src=<-> /> XML]] ;
|
url-encode XML-CHUNK[[ <img src=<-> /> ]] ;
|
||||||
|
|
|
@ -72,7 +72,7 @@ MACRO: make-css ( pairs -- str )
|
||||||
|
|
||||||
: span-tag ( xml style -- xml )
|
: span-tag ( xml style -- xml )
|
||||||
span-css-style
|
span-css-style
|
||||||
[ swap XML[[ <span style=<->><-></span> XML]] ] unless-empty ; inline
|
[ swap XML-CHUNK[[ <span style=<->><-></span> ]] ] unless-empty ; inline
|
||||||
|
|
||||||
: emit-html ( stream quot -- )
|
: emit-html ( stream quot -- )
|
||||||
dip data>> push ; inline
|
dip data>> push ; inline
|
||||||
|
@ -125,7 +125,7 @@ CONSTANT: pre-css "white-space: pre; font-family: monospace; " ;
|
||||||
|
|
||||||
: div-tag ( xml style -- xml' )
|
: div-tag ( xml style -- xml' )
|
||||||
div-css-style
|
div-css-style
|
||||||
[ swap XML[[ <div style=<->><-></div> XML]] ] unless-empty ;
|
[ swap XML-CHUNK[[ <div style=<->><-></div> ]] ] unless-empty ;
|
||||||
|
|
||||||
: format-html-div ( string style stream -- )
|
: format-html-div ( string style stream -- )
|
||||||
[ [ div-tag ] [ object-link-tag ] bi ] emit-html ;
|
[ [ div-tag ] [ object-link-tag ] bi ] emit-html ;
|
||||||
|
@ -159,7 +159,7 @@ M: html-writer stream-format
|
||||||
format-html-span ;
|
format-html-span ;
|
||||||
|
|
||||||
M: html-writer stream-nl
|
M: html-writer stream-nl
|
||||||
[ XML[[ <br/> XML]] ] emit-html ;
|
[ XML-CHUNK[[ <br/> ]] ] emit-html ;
|
||||||
|
|
||||||
M: html-writer make-span-stream
|
M: html-writer make-span-stream
|
||||||
html-span-stream new-html-sub-stream ;
|
html-span-stream new-html-sub-stream ;
|
||||||
|
@ -173,10 +173,10 @@ M: html-writer make-cell-stream
|
||||||
M: html-writer stream-write-table
|
M: html-writer stream-write-table
|
||||||
[
|
[
|
||||||
table-style swap [
|
table-style swap [
|
||||||
[ data>> XML[[ <td valign="top" style=<->><-></td> XML]] ] with map
|
[ data>> XML-CHUNK[[ <td valign="top" style=<->><-></td> ]] ] with map
|
||||||
XML[[ <tr><-></tr> XML]]
|
XML-CHUNK[[ <tr><-></tr> ]]
|
||||||
] with map
|
] with map
|
||||||
XML[[ <table style="display: inline-table; border-collapse: collapse;"><-></table> XML]]
|
XML-CHUNK[[ <table style="display: inline-table; border-collapse: collapse;"><-></table> ]]
|
||||||
] emit-html ;
|
] emit-html ;
|
||||||
|
|
||||||
M: html-writer dispose drop ;
|
M: html-writer dispose drop ;
|
||||||
|
|
|
@ -274,7 +274,7 @@ ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custo
|
||||||
"As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:"
|
"As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:"
|
||||||
{ $code "singleton: image" }
|
{ $code "singleton: image" }
|
||||||
"Now we define a method on the " { $link render* } " generic word which renders the image using " { $link { "xml.syntax" "literals" } } ":"
|
"Now we define a method on the " { $link render* } " generic word which renders the image using " { $link { "xml.syntax" "literals" } } ":"
|
||||||
{ $code "M: image render* 2drop XML[[ <img src=<-> /> XML]] ;" }
|
{ $code "M: image render* 2drop XML-CHUNK[[ <img src=<-> /> ]] ;" }
|
||||||
"Finally, we can define a Chloe component:"
|
"Finally, we can define a Chloe component:"
|
||||||
{ $code "component: image" }
|
{ $code "component: image" }
|
||||||
"We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":"
|
"We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":"
|
||||||
|
|
|
@ -19,7 +19,7 @@ CHLOE: write-title
|
||||||
drop
|
drop
|
||||||
"head" tag-stack get member?
|
"head" tag-stack get member?
|
||||||
"title" tag-stack get member? not and
|
"title" tag-stack get member? not and
|
||||||
[ get-title XML[[ <title><-></title> XML]] ]
|
[ get-title XML-CHUNK[[ <title><-></title> ]] ]
|
||||||
[ get-title ] ?
|
[ get-title ] ?
|
||||||
[xml-code] ;
|
[xml-code] ;
|
||||||
|
|
||||||
|
@ -33,7 +33,7 @@ CHLOE: style
|
||||||
CHLOE: write-style
|
CHLOE: write-style
|
||||||
drop [
|
drop [
|
||||||
get-style
|
get-style
|
||||||
XML[[ <style type="text/css"> <-> </style> XML]]
|
XML-CHUNK[[ <style type="text/css"> <-> </style> ]]
|
||||||
] [xml-code] ;
|
] [xml-code] ;
|
||||||
|
|
||||||
CHLOE: even
|
CHLOE: even
|
||||||
|
|
|
@ -66,13 +66,13 @@ symbol: atom-feeds
|
||||||
|
|
||||||
: get-atom-feeds ( -- xml )
|
: get-atom-feeds ( -- xml )
|
||||||
atom-feeds get [
|
atom-feeds get [
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<link
|
<link
|
||||||
rel="alternate"
|
rel="alternate"
|
||||||
type="application/atom+xml"
|
type="application/atom+xml"
|
||||||
title=<->
|
title=<->
|
||||||
href=<->/>
|
href=<->/>
|
||||||
XML]]
|
]]
|
||||||
] { } assoc>map ;
|
] { } assoc>map ;
|
||||||
|
|
||||||
: write-atom-feeds ( -- )
|
: write-atom-feeds ( -- )
|
||||||
|
|
|
@ -19,13 +19,13 @@ IN: http.server.responses
|
||||||
"text/html" <content> ;
|
"text/html" <content> ;
|
||||||
|
|
||||||
: trivial-response-body ( code message -- )
|
: trivial-response-body ( code message -- )
|
||||||
<XML
|
XML-DOC[[
|
||||||
<html>
|
<html>
|
||||||
<body>
|
<body>
|
||||||
<h1><-> <-></h1>
|
<h1><-> <-></h1>
|
||||||
</body>
|
</body>
|
||||||
</html>
|
</html>
|
||||||
XML> write-xml ;
|
]] write-xml ;
|
||||||
|
|
||||||
: <trivial-response> ( code message -- response )
|
: <trivial-response> ( code message -- response )
|
||||||
2dup [ trivial-response-body ] with-string-writer
|
2dup [ trivial-response-body ] with-string-writer
|
||||||
|
|
|
@ -60,14 +60,14 @@ TUPLE: file-responder root hook special index-names allow-listings ;
|
||||||
|
|
||||||
: file>html ( name -- xml )
|
: file>html ( name -- xml )
|
||||||
dup link-info directory? [ "/" append ] when
|
dup link-info directory? [ "/" append ] when
|
||||||
dup XML[[ <li><a href=<->><-></a></li> XML]] ;
|
dup XML-CHUNK[[ <li><a href=<->><-></a></li> ]] ;
|
||||||
|
|
||||||
: directory>html ( path -- xml )
|
: directory>html ( path -- xml )
|
||||||
[ file-name ]
|
[ file-name ]
|
||||||
[ drop f ]
|
[ drop f ]
|
||||||
[
|
[
|
||||||
[ file-name ] [ [ natural-sort [ file>html ] map ] with-directory-files ] bi
|
[ file-name ] [ [ natural-sort [ file>html ] map ] with-directory-files ] bi
|
||||||
XML[[ <h1><-></h1> <ul><-></ul> XML]]
|
XML-CHUNK[[ <h1><-></h1> <ul><-></ul> ]]
|
||||||
] tri
|
] tri
|
||||||
simple-page ;
|
simple-page ;
|
||||||
|
|
||||||
|
|
|
@ -11,30 +11,30 @@ GENERIC: diff-line ( obj -- xml ) ;
|
||||||
|
|
||||||
M: retain diff-line
|
M: retain diff-line
|
||||||
item-string
|
item-string
|
||||||
XML[[ <td class="retain"><-></td> XML]]
|
XML-CHUNK[[ <td class="retain"><-></td> ]]
|
||||||
dup XML[[ <tr><-><-></tr> XML]] ;
|
dup XML-CHUNK[[ <tr><-><-></tr> ]] ;
|
||||||
|
|
||||||
M: insert diff-line
|
M: insert diff-line
|
||||||
item-string XML[[
|
item-string XML-CHUNK[[
|
||||||
<tr>
|
<tr>
|
||||||
<td> </td>
|
<td> </td>
|
||||||
<td class="insert"><-></td>
|
<td class="insert"><-></td>
|
||||||
</tr>
|
</tr>
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
M: delete diff-line
|
M: delete diff-line
|
||||||
item-string XML[[
|
item-string XML-CHUNK[[
|
||||||
<tr>
|
<tr>
|
||||||
<td class="delete"><-></td>
|
<td class="delete"><-></td>
|
||||||
<td> </td>
|
<td> </td>
|
||||||
</tr>
|
</tr>
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
: htmlize-diff ( diff -- xml )
|
: htmlize-diff ( diff -- xml )
|
||||||
[ diff-line ] map
|
[ diff-line ] map
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<table width="100%" class="comparison">
|
<table width="100%" class="comparison">
|
||||||
<tr><th>Old</th><th>New</th></tr>
|
<tr><th>Old</th><th>New</th></tr>
|
||||||
<->
|
<->
|
||||||
</table>
|
</table>
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
|
@ -119,23 +119,23 @@ M: byte-array parse-feed [ bytes>xml xml>feed ] with-html-entities ;
|
||||||
[ date>> timestamp>rfc3339 ]
|
[ date>> timestamp>rfc3339 ]
|
||||||
[ description>> ]
|
[ description>> ]
|
||||||
} cleave
|
} cleave
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<entry>
|
<entry>
|
||||||
<title type="html"><-></title>
|
<title type="html"><-></title>
|
||||||
<link rel="alternate" href=<-> />
|
<link rel="alternate" href=<-> />
|
||||||
<published><-></published>
|
<published><-></published>
|
||||||
<content type="html"><-></content>
|
<content type="html"><-></content>
|
||||||
</entry>
|
</entry>
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
: feed>xml ( feed -- xml )
|
: feed>xml ( feed -- xml )
|
||||||
[ title>> ]
|
[ title>> ]
|
||||||
[ url>> present ]
|
[ url>> present ]
|
||||||
[ entries>> [ entry>xml ] map ] tri
|
[ entries>> [ entry>xml ] map ] tri
|
||||||
<XML
|
XML-DOC[[
|
||||||
<feed xmlns="http://www.w3.org/2005/Atom">
|
<feed xmlns="http://www.w3.org/2005/Atom">
|
||||||
<title><-></title>
|
<title><-></title>
|
||||||
<link rel="alternate" href=<-> />
|
<link rel="alternate" href=<-> />
|
||||||
<->
|
<->
|
||||||
</feed>
|
</feed>
|
||||||
XML> ;
|
]] ;
|
||||||
|
|
|
@ -16,34 +16,34 @@ GENERIC: item>xml ( object -- xml ) ;
|
||||||
M: integer item>xml
|
M: integer item>xml
|
||||||
dup 31 2^ neg 31 2^ 1 - between?
|
dup 31 2^ neg 31 2^ 1 - between?
|
||||||
[ "Integers must fit in 32 bits" throw ] unless
|
[ "Integers must fit in 32 bits" throw ] unless
|
||||||
XML[[ <i4><-></i4> XML]] ;
|
XML-CHUNK[[ <i4><-></i4> ]] ;
|
||||||
|
|
||||||
M: boolean item>xml
|
M: boolean item>xml
|
||||||
"1" "0" ? XML[[ <boolean><-></boolean> XML]] ;
|
"1" "0" ? XML-CHUNK[[ <boolean><-></boolean> ]] ;
|
||||||
|
|
||||||
M: float item>xml
|
M: float item>xml
|
||||||
number>string XML[[ <double><-></double> XML]] ;
|
number>string XML-CHUNK[[ <double><-></double> ]] ;
|
||||||
|
|
||||||
M: string item>xml
|
M: string item>xml
|
||||||
XML[[ <string><-></string> XML]] ;
|
XML-CHUNK[[ <string><-></string> ]] ;
|
||||||
|
|
||||||
: struct-member ( name value -- tag )
|
: struct-member ( name value -- tag )
|
||||||
over string? [ "Struct member name must be string" throw ] unless
|
over string? [ "Struct member name must be string" throw ] unless
|
||||||
item>xml
|
item>xml
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<member>
|
<member>
|
||||||
<name><-></name>
|
<name><-></name>
|
||||||
<value><-></value>
|
<value><-></value>
|
||||||
</member>
|
</member>
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
M: hashtable item>xml
|
M: hashtable item>xml
|
||||||
[ struct-member ] { } assoc>map
|
[ struct-member ] { } assoc>map
|
||||||
XML[[ <struct><-></struct> XML]] ;
|
XML-CHUNK[[ <struct><-></struct> ]] ;
|
||||||
|
|
||||||
M: array item>xml
|
M: array item>xml
|
||||||
[ item>xml XML[[ <value><-></value> XML]] ] map
|
[ item>xml XML-CHUNK[[ <value><-></value> ]] ] map
|
||||||
XML[[ <array><data><-></data></array> XML]] ;
|
XML-CHUNK[[ <array><data><-></data></array> ]] ;
|
||||||
|
|
||||||
TUPLE: base64 string ;
|
TUPLE: base64 string ;
|
||||||
|
|
||||||
|
@ -51,33 +51,33 @@ C: <base64> base64 ;
|
||||||
|
|
||||||
M: base64 item>xml
|
M: base64 item>xml
|
||||||
string>> >base64
|
string>> >base64
|
||||||
XML[[ <base64><-></base64> XML]] ;
|
XML-CHUNK[[ <base64><-></base64> ]] ;
|
||||||
|
|
||||||
: params ( seq -- xml )
|
: params ( seq -- xml )
|
||||||
[ item>xml XML[[ <param><value><-></value></param> XML]] ] map
|
[ item>xml XML-CHUNK[[ <param><value><-></value></param> ]] ] map
|
||||||
XML[[ <params><-></params> XML]] ;
|
XML-CHUNK[[ <params><-></params> ]] ;
|
||||||
|
|
||||||
: method-call ( name seq -- xml )
|
: method-call ( name seq -- xml )
|
||||||
params
|
params
|
||||||
<XML
|
XML-DOC[[
|
||||||
<methodCall>
|
<methodCall>
|
||||||
<methodName><-></methodName>
|
<methodName><-></methodName>
|
||||||
<->
|
<->
|
||||||
</methodCall>
|
</methodCall>
|
||||||
XML> ;
|
]] ;
|
||||||
|
|
||||||
: return-params ( seq -- xml )
|
: return-params ( seq -- xml )
|
||||||
params <XML <methodResponse><-></methodResponse> XML> ;
|
params XML-DOC[[ <methodResponse><-></methodResponse> ]] ;
|
||||||
|
|
||||||
: return-fault ( fault-code fault-string -- xml )
|
: return-fault ( fault-code fault-string -- xml )
|
||||||
[ "faultString" ,, "faultCode" ,, ] H{ } make item>xml
|
[ "faultString" ,, "faultCode" ,, ] H{ } make item>xml
|
||||||
<XML
|
XML-DOC[[
|
||||||
<methodResponse>
|
<methodResponse>
|
||||||
<fault>
|
<fault>
|
||||||
<value><-></value>
|
<value><-></value>
|
||||||
</fault>
|
</fault>
|
||||||
</methodResponse>
|
</methodResponse>
|
||||||
XML> ;
|
]] ;
|
||||||
|
|
||||||
TUPLE: rpc-method name params ;
|
TUPLE: rpc-method name params ;
|
||||||
|
|
||||||
|
|
|
@ -75,11 +75,11 @@ HELP: bad-cdata
|
||||||
{ $class-description "Describes the error where CDATA is used outside of the main tag of an XML document." }
|
{ $class-description "Describes the error where CDATA is used outside of the main tag of an XML document." }
|
||||||
{ $xml-error "<x>y</x>\n<![CDATA[]]>" } ;
|
{ $xml-error "<x>y</x>\n<![CDATA[]]>" } ;
|
||||||
|
|
||||||
HELP: text-w/]]>
|
HELP: text-w/terminator
|
||||||
{ $class-description "Describes the error where a text node contains the literal string " { $snippet "]]>" } " which is disallowed." }
|
{ $class-description "Describes the error where a text node contains the literal string " { $snippet "]]>" } " which is disallowed." }
|
||||||
{ $xml-error "<x>Here's some text: ]]> there it was</x>" } ;
|
{ $xml-error "<x>Here's some text: ]]> there it was</x>" } ;
|
||||||
|
|
||||||
HELP: attr-w/<
|
HELP: attr-w/lt
|
||||||
{ $class-description "Describes the error where an attribute value contains the literal character " { $snippet "<" } " which is disallowed." }
|
{ $class-description "Describes the error where an attribute value contains the literal character " { $snippet "<" } " which is disallowed." }
|
||||||
{ $xml-error "<x value='bar<baz'/>" } ;
|
{ $xml-error "<x value='bar<baz'/>" } ;
|
||||||
|
|
||||||
|
@ -111,8 +111,8 @@ ARTICLE: "xml.errors" "XML parsing errors"
|
||||||
unexpected-end
|
unexpected-end
|
||||||
duplicate-attr
|
duplicate-attr
|
||||||
bad-cdata
|
bad-cdata
|
||||||
text-w/]]>
|
text-w/terminator
|
||||||
attr-w/<
|
attr-w/lt
|
||||||
misplaced-directive
|
misplaced-directive
|
||||||
}
|
}
|
||||||
"Additionally, most of these errors are a kind of " { $link xml-error } " which provides more information about where the error occurred."
|
"Additionally, most of these errors are a kind of " { $link xml-error } " which provides more information about where the error occurred."
|
||||||
|
|
|
@ -29,8 +29,8 @@ T{ unclosed-quote f 1 12 } "<x value='/>" xml-error-test
|
||||||
T{ bad-name f 1 3 "-" } "<-/>" xml-error-test
|
T{ bad-name f 1 3 "-" } "<-/>" xml-error-test
|
||||||
T{ quoteless-attr f 1 12 } "<x value=<->/>" xml-error-test
|
T{ quoteless-attr f 1 12 } "<x value=<->/>" xml-error-test
|
||||||
T{ quoteless-attr f 1 10 } "<x value=3/>" xml-error-test
|
T{ quoteless-attr f 1 10 } "<x value=3/>" xml-error-test
|
||||||
T{ attr-w/< f 1 11 } "<x value='<'/>" xml-error-test
|
T{ attr-w/lt f 1 11 } "<x value='<'/>" xml-error-test
|
||||||
T{ text-w/]]> f 1 6 } "<x>]]></x>" xml-error-test
|
T{ text-w/terminator f 1 6 } "<x>]]></x>" xml-error-test
|
||||||
T{ duplicate-attr f 1 21 T{ name { space "" } { main "this" } } V{ "a" "b" } } "<x this='a' this='b'/>" xml-error-test
|
T{ duplicate-attr f 1 21 T{ name { space "" } { main "this" } } V{ "a" "b" } } "<x this='a' this='b'/>" xml-error-test
|
||||||
T{ bad-cdata f 1 3 } "<![CDATA[]]><x/>" xml-error-test
|
T{ bad-cdata f 1 3 } "<![CDATA[]]><x/>" xml-error-test
|
||||||
T{ bad-cdata f 1 7 } "<x/><![CDATA[]]>" xml-error-test
|
T{ bad-cdata f 1 7 } "<x/><![CDATA[]]>" xml-error-test
|
||||||
|
|
|
@ -15,49 +15,49 @@ ARTICLE: "xml.syntax" "Syntax extensions for XML"
|
||||||
|
|
||||||
ARTICLE: { "xml.syntax" "tags" } "Dispatch on XML tag names"
|
ARTICLE: { "xml.syntax" "tags" } "Dispatch on XML tag names"
|
||||||
"There is a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
|
"There is a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
|
||||||
{ $subsections postpone\ TAGS: }
|
{ $subsections \ TAGS: }
|
||||||
"and to define a new 'method' for this word, use"
|
"and to define a new 'method' for this word, use"
|
||||||
{ $subsections postpone\ TAG: } ;
|
{ $subsections \ TAG: } ;
|
||||||
|
|
||||||
HELP: \ TAGS:
|
HELP: \ TAGS:
|
||||||
{ $syntax "TAGS: word effect ;" }
|
{ $syntax "TAGS: word effect ;" }
|
||||||
{ $values { "word" "a new word to define" } }
|
{ $values { "word" "a new word to define" } }
|
||||||
{ $description "Creates a new word to which dispatches on XML tag names." }
|
{ $description "Creates a new word to which dispatches on XML tag names." }
|
||||||
{ $see-also postpone\ TAG: } ;
|
{ $see-also \ TAG: } ;
|
||||||
|
|
||||||
HELP: \ TAG:
|
HELP: \ TAG:
|
||||||
{ $syntax "TAG: tag word definition... ;" }
|
{ $syntax "TAG: tag word definition... ;" }
|
||||||
{ $values { "tag" "an XML tag name" } { "word" "an XML process" } }
|
{ $values { "tag" "an XML tag name" } { "word" "an XML process" } }
|
||||||
{ $description "Defines a 'method' on a word created with " { $link postpone\ TAGS: } ". It determines what such a word should do for an argument that is has the given name." }
|
{ $description "Defines a 'method' on a word created with " { $link \ TAGS: } ". It determines what such a word should do for an argument that is has the given name." }
|
||||||
{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
|
{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
|
||||||
{ $see-also postpone\ TAGS: } ;
|
{ $see-also \ TAGS: } ;
|
||||||
|
|
||||||
ARTICLE: { "xml.syntax" "literals" } "XML literals"
|
ARTICLE: { "xml.syntax" "literals" } "XML literals"
|
||||||
"The following words provide syntax for XML literals:"
|
"The following words provide syntax for XML literals:"
|
||||||
{ $subsections
|
{ $subsections
|
||||||
postpone\ <XML
|
\ XML-DOC[[
|
||||||
postpone\ XML[[
|
\ XML-CHUNK[[
|
||||||
}
|
}
|
||||||
"These can be used for creating an XML literal, which can be used with variables or a fry-like syntax to interpolate data into XML."
|
"These can be used for creating an XML literal, which can be used with variables or a fry-like syntax to interpolate data into XML."
|
||||||
{ $subsections { "xml.syntax" "interpolation" } } ;
|
{ $subsections { "xml.syntax" "interpolation" } } ;
|
||||||
|
|
||||||
HELP: \ <XML
|
HELP: \ XML-DOC[[
|
||||||
{ $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" }
|
{ $syntax "XML-DOC[[ <?xml version=\"1.0\"?><document>...</document> ]]" }
|
||||||
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ;
|
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ;
|
||||||
|
|
||||||
HELP: \ XML[[
|
HELP: \ XML-CHUNK[[
|
||||||
{ $syntax "XML[[ foo <x>...</x> bar <y>...</y> baz XML]]" }
|
{ $syntax "XML-CHUNK[[ foo <x>...</x> bar <y>...</y> baz ]]" }
|
||||||
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ;
|
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ;
|
||||||
|
|
||||||
ARTICLE: { "xml.syntax" "interpolation" } "XML interpolation syntax"
|
ARTICLE: { "xml.syntax" "interpolation" } "XML interpolation syntax"
|
||||||
"XML interpolation has two forms for each of the words " { $link postpone\ <XML } " and " { $link postpone\ XML[[ } ": a fry-like form and a locals form. To splice locals in, use the syntax " { $snippet "<-variable->" } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles."
|
"XML interpolation has two forms for each of the words " { $link \ XML-DOC[[ } " and " { $link \ XML-CHUNK[[ } ": a fry-like form and a locals form. To splice locals in, use the syntax " { $snippet "<-variable->" } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles."
|
||||||
$nl
|
$nl
|
||||||
"These forms can be used where a tag might go, as in " { $snippet "XML[[ <foo><-></foo> XML]]" } " or where an attribute might go, as in " { $snippet "XML[[ <foo bar=<->/> XML]]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
|
"These forms can be used where a tag might go, as in " { $snippet "XML-CHUNK[[ <foo><-></foo> ]]" } " or where an attribute might go, as in " { $snippet "XML-CHUNK[[ <foo bar=<->/> ]]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
|
||||||
{ $example
|
{ $example
|
||||||
"USING: splitting xml.writer xml.syntax ;
|
"USING: splitting xml.writer xml.syntax ;
|
||||||
\"one two three\" \" \" split
|
\"one two three\" \" \" split
|
||||||
[ XML[[ <item><-></item> XML]] ] map
|
[ XML-CHUNK[[ <item><-></item> ]] ] map
|
||||||
<XML <doc><-></doc> XML> pprint-xml"
|
XML-DOC[[ <doc><-></doc> ]] pprint-xml"
|
||||||
|
|
||||||
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>
|
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>
|
||||||
<doc>
|
<doc>
|
||||||
|
@ -80,14 +80,14 @@ let[
|
||||||
URL\" http://factorcode.org/\" :> url
|
URL\" http://factorcode.org/\" :> url
|
||||||
\"hello\" :> string
|
\"hello\" :> string
|
||||||
\\ drop :> word
|
\\ drop :> word
|
||||||
<XML
|
XML-DOC[[
|
||||||
<x
|
<x
|
||||||
number=<-number->
|
number=<-number->
|
||||||
false=<-false->
|
false=<-false->
|
||||||
url=<-url->
|
url=<-url->
|
||||||
string=<-string->
|
string=<-string->
|
||||||
word=<-word-> />
|
word=<-word-> />
|
||||||
XML> pprint-xml
|
]] pprint-xml
|
||||||
]"
|
]"
|
||||||
|
|
||||||
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>
|
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>
|
||||||
|
@ -96,12 +96,12 @@ let[
|
||||||
{ $example "USING: xml.syntax inverse ;
|
{ $example "USING: xml.syntax inverse ;
|
||||||
: dispatch ( xml -- string )
|
: dispatch ( xml -- string )
|
||||||
{
|
{
|
||||||
{ [ XML[[ <a><-></a> XML]] ] [ \"a\" prepend ] }
|
{ [ XML-CHUNK[[ <a><-></a> ]] ] [ \"a\" prepend ] }
|
||||||
{ [ XML[[ <b><-></b> XML]] ] [ \"b\" prepend ] }
|
{ [ XML-CHUNK[[ <b><-></b> ]] ] [ \"b\" prepend ] }
|
||||||
{ [ XML[[ <b val='yes'/> XML]] ] [ \"yes\" ] }
|
{ [ XML-CHUNK[[ <b val='yes'/> ]] ] [ \"yes\" ] }
|
||||||
{ [ XML[[ <b val=<->/> XML]] ] [ \"no\" prepend ] }
|
{ [ XML-CHUNK[[ <b val=<->/> ]] ] [ \"no\" prepend ] }
|
||||||
} switch ;
|
} switch ;
|
||||||
XML[[ <a>pple</a> XML]] dispatch write"
|
XML-CHUNK[[ <a>pple</a> ]] dispatch write"
|
||||||
"apple" } ;
|
"apple" } ;
|
||||||
|
|
||||||
HELP: \ XML-NS:
|
HELP: \ XML-NS:
|
||||||
|
|
|
@ -55,10 +55,10 @@ XML-NS: foo http://blah.com ;
|
||||||
y
|
y
|
||||||
<foo/>
|
<foo/>
|
||||||
</x>" } [
|
</x>" } [
|
||||||
let[ "one" :> a "two" :> c "y" :> x XML[[ <-x-> <foo/> XML]] :> d
|
let[ "one" :> a "two" :> c "y" :> x XML-CHUNK[[ <-x-> <foo/> ]] :> d
|
||||||
<XML
|
XML-DOC[[
|
||||||
<x> <-a-> <b val=<-c->/> <-d-> </x>
|
<x> <-a-> <b val=<-c->/> <-d-> </x>
|
||||||
XML> pprint-xml>string
|
]] pprint-xml>string
|
||||||
]
|
]
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -75,69 +75,69 @@ XML-NS: foo http://blah.com ;
|
||||||
</item>
|
</item>
|
||||||
</doc>" } [
|
</doc>" } [
|
||||||
"one two three" " " split
|
"one two three" " " split
|
||||||
[ XML[[ <item><-></item> XML]] ] map
|
[ XML-CHUNK[[ <item><-></item> ]] ] map
|
||||||
<XML <doc><-></doc> XML> pprint-xml>string
|
XML-DOC[[ <doc><-></doc> ]] pprint-xml>string
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
|
{ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
|
||||||
<x number=\"3\" url=\"http://factorcode.org/\" string=\"hello\" word=\"drop\"/>" }
|
<x number=\"3\" url=\"http://factorcode.org/\" string=\"hello\" word=\"drop\"/>" }
|
||||||
[ 3 f "http://factorcode.org/" "hello" \ drop
|
[ 3 f "http://factorcode.org/" "hello" \ drop
|
||||||
<XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
|
XML-DOC[[ <x number=<-> false=<-> url=<-> string=<-> word=<->/> ]]
|
||||||
pprint-xml>string ] unit-test
|
pprint-xml>string ] unit-test
|
||||||
|
|
||||||
{ "<x>3</x>" } [ 3 XML[[ <x><-></x> XML]] xml>string ] unit-test
|
{ "<x>3</x>" } [ 3 XML-CHUNK[[ <x><-></x> ]] xml>string ] unit-test
|
||||||
{ "<x></x>" } [ f XML[[ <x><-></x> XML]] xml>string ] unit-test
|
{ "<x></x>" } [ f XML-CHUNK[[ <x><-></x> ]] xml>string ] unit-test
|
||||||
|
|
||||||
[ XML[[ <-> XML]] ] must-infer
|
[ XML-CHUNK[[ <-> ]] ] must-infer
|
||||||
[ XML[[ <foo><-></foo> <bar val=<->/> XML]] ] must-infer
|
[ XML-CHUNK[[ <foo><-></foo> <bar val=<->/> ]] ] must-infer
|
||||||
|
|
||||||
{ xml-chunk } [ [ XML[[ <foo/> XML]] ] first class-of ] unit-test
|
{ xml-chunk } [ [ XML-CHUNK[[ <foo/> ]] ] first class-of ] unit-test
|
||||||
{ xml } [ [ <XML <foo/> XML> ] first class-of ] unit-test
|
{ xml } [ [ XML-DOC[[ <foo/> ]] ] first class-of ] unit-test
|
||||||
{ xml-chunk } [ [ XML[[ <foo val=<->/> XML]] ] third class-of ] unit-test
|
{ xml-chunk } [ [ XML-CHUNK[[ <foo val=<->/> ]] ] third class-of ] unit-test
|
||||||
{ xml } [ [ <XML <foo val=<->/> XML> ] third class-of ] unit-test
|
{ xml } [ [ XML-DOC[[ <foo val=<->/> ]] ] third class-of ] unit-test
|
||||||
{ 1 } [ [ XML[[ <foo/> XML]] ] length ] unit-test
|
{ 1 } [ [ XML-CHUNK[[ <foo/> ]] ] length ] unit-test
|
||||||
{ 1 } [ [ <XML <foo/> XML> ] length ] unit-test
|
{ 1 } [ [ XML-DOC[[ <foo/> ]] ] length ] unit-test
|
||||||
|
|
||||||
{ "" } [ XML[[ XML]] concat ] unit-test
|
{ "" } [ XML-CHUNK[[ ]] concat ] unit-test
|
||||||
|
|
||||||
{ "foo" } [ XML[[ <a>foo</a> XML]] [ XML[[ <a><-></a> XML]] ] undo ] unit-test
|
{ "foo" } [ XML-CHUNK[[ <a>foo</a> ]] [ XML-CHUNK[[ <a><-></a> ]] ] undo ] unit-test
|
||||||
{ "foo" } [ XML[[ <a bar='foo'/> XML]] [ XML[[ <a bar=<-> /> XML]] ] undo ] unit-test
|
{ "foo" } [ XML-CHUNK[[ <a bar='foo'/> ]] [ XML-CHUNK[[ <a bar=<-> /> ]] ] undo ] unit-test
|
||||||
{ "foo" "baz" } [ XML[[ <a bar='foo'>baz</a> XML]] [ XML[[ <a bar=<->><-></a> XML]] ] undo ] unit-test
|
{ "foo" "baz" } [ XML-CHUNK[[ <a bar='foo'>baz</a> ]] [ XML-CHUNK[[ <a bar=<->><-></a> ]] ] undo ] unit-test
|
||||||
|
|
||||||
: dispatch ( xml -- string )
|
: dispatch ( xml -- string )
|
||||||
{
|
{
|
||||||
{ [ XML[[ <a><-></a> XML]] ] [ "a" prepend ] }
|
{ [ XML-CHUNK[[ <a><-></a> ]] ] [ "a" prepend ] }
|
||||||
{ [ XML[[ <b><-></b> XML]] ] [ "b" prepend ] }
|
{ [ XML-CHUNK[[ <b><-></b> ]] ] [ "b" prepend ] }
|
||||||
{ [ XML[[ <b val='yes'/> XML]] ] [ "byes" ] }
|
{ [ XML-CHUNK[[ <b val='yes'/> ]] ] [ "byes" ] }
|
||||||
{ [ XML[[ <b val=<->/> XML]] ] [ "bno" prepend ] }
|
{ [ XML-CHUNK[[ <b val=<->/> ]] ] [ "bno" prepend ] }
|
||||||
} switch ;
|
} switch ;
|
||||||
|
|
||||||
{ "apple" } [ XML[[ <a>pple</a> XML]] dispatch ] unit-test
|
{ "apple" } [ XML-CHUNK[[ <a>pple</a> ]] dispatch ] unit-test
|
||||||
{ "banana" } [ XML[[ <b>anana</b> XML]] dispatch ] unit-test
|
{ "banana" } [ XML-CHUNK[[ <b>anana</b> ]] dispatch ] unit-test
|
||||||
{ "byes" } [ XML[[ <b val="yes"/> XML]] dispatch ] unit-test
|
{ "byes" } [ XML-CHUNK[[ <b val="yes"/> ]] dispatch ] unit-test
|
||||||
{ "bnowhere" } [ XML[[ <b val="where"/> XML]] dispatch ] unit-test
|
{ "bnowhere" } [ XML-CHUNK[[ <b val="where"/> ]] dispatch ] unit-test
|
||||||
{ "baboon" } [ XML[[ <b val="something">aboon</b> XML]] dispatch ] unit-test
|
{ "baboon" } [ XML-CHUNK[[ <b val="something">aboon</b> ]] dispatch ] unit-test
|
||||||
{ "apple" } [ <XML <a>pple</a> XML> dispatch ] unit-test
|
{ "apple" } [ XML-DOC[[ <a>pple</a> ]] dispatch ] unit-test
|
||||||
{ "apple" } [ <XML <a>pple</a> XML> body>> dispatch ] unit-test
|
{ "apple" } [ XML-DOC[[ <a>pple</a> ]] body>> dispatch ] unit-test
|
||||||
|
|
||||||
: dispatch-doc ( xml -- string )
|
: dispatch-doc ( xml -- string )
|
||||||
{
|
{
|
||||||
{ [ <XML <a><-></a> XML> ] [ "a" prepend ] }
|
{ [ XML-DOC[[ <a><-></a> ]] ] [ "a" prepend ] }
|
||||||
{ [ <XML <b><-></b> XML> ] [ "b" prepend ] }
|
{ [ XML-DOC[[ <b><-></b> ]] ] [ "b" prepend ] }
|
||||||
{ [ <XML <b val='yes'/> XML> ] [ "byes" ] }
|
{ [ XML-DOC[[ <b val='yes'/> ]] ] [ "byes" ] }
|
||||||
{ [ <XML <b val=<->/> XML> ] [ "bno" prepend ] }
|
{ [ XML-DOC[[ <b val=<->/> ]] ] [ "bno" prepend ] }
|
||||||
} switch ;
|
} switch ;
|
||||||
|
|
||||||
{ "apple" } [ <XML <a>pple</a> XML> dispatch-doc ] unit-test
|
{ "apple" } [ XML-DOC[[ <a>pple</a> ]] dispatch-doc ] unit-test
|
||||||
{ "apple" } [ XML[[ <a>pple</a> XML]] dispatch-doc ] unit-test
|
{ "apple" } [ XML-CHUNK[[ <a>pple</a> ]] dispatch-doc ] unit-test
|
||||||
{ "apple" } [ <XML <a>pple</a> XML> body>> dispatch-doc ] unit-test
|
{ "apple" } [ XML-DOC[[ <a>pple</a> ]] body>> dispatch-doc ] unit-test
|
||||||
|
|
||||||
! Make sure nested XML documents interpolate correctly
|
! Make sure nested XML documents interpolate correctly
|
||||||
{
|
{
|
||||||
"<?xml version=\"1.0\" encoding=\"UTF-8\"?><color><blue>it's blue!</blue></color>"
|
"<?xml version=\"1.0\" encoding=\"UTF-8\"?><color><blue>it's blue!</blue></color>"
|
||||||
} [
|
} [
|
||||||
"it's blue!" <XML <blue><-></blue> XML>
|
"it's blue!" XML-DOC[[ <blue><-></blue> ]]
|
||||||
<XML <color><-></color> XML> xml>string
|
XML-DOC[[ <color><-></color> ]] xml>string
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{
|
{
|
||||||
|
@ -147,5 +147,5 @@ XML-NS: foo http://blah.com ;
|
||||||
"asdf"
|
"asdf"
|
||||||
"asdf" f f <tag>
|
"asdf" f f <tag>
|
||||||
"asdf2" <xml>
|
"asdf2" <xml>
|
||||||
<XML <a><-></a> XML> xml>string
|
XML-DOC[[ <a><-></a> ]] xml>string
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -170,11 +170,11 @@ MACRO: interpolate-xml ( xml -- quot )
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
SYNTAX: \ <XML
|
SYNTAX: \ XML-DOC[[
|
||||||
"XML>" [ string>doc ] parse-def ;
|
"]]" [ string>doc ] parse-def ;
|
||||||
|
|
||||||
SYNTAX: \ XML[[
|
SYNTAX: \ XML-CHUNK[[
|
||||||
"XML]]" [ string>chunk ] parse-def ;
|
"]]" [ string>chunk ] parse-def ;
|
||||||
|
|
||||||
use: vocabs.loader
|
use: vocabs.loader
|
||||||
|
|
||||||
|
|
|
@ -153,7 +153,7 @@ HINTS: next* { spot } ;
|
||||||
512 <sbuf> [ spot get (parse-char) ] keep "" like ; inline
|
512 <sbuf> [ spot get (parse-char) ] keep "" like ; inline
|
||||||
|
|
||||||
: assure-no-terminator ( pos char -- pos' )
|
: assure-no-terminator ( pos char -- pos' )
|
||||||
"]]>" next-matching dup 2 > [ text-w/terminatorl ] when ; inline
|
"]]>" next-matching dup 2 > [ text-w/terminator ] when ; inline
|
||||||
|
|
||||||
:: parse-text ( -- string )
|
:: parse-text ( -- string )
|
||||||
depth get zero? :> no-text
|
depth get zero? :> no-text
|
||||||
|
|
|
@ -48,7 +48,7 @@ HELP: pprint-xml
|
||||||
HELP: indenter
|
HELP: indenter
|
||||||
{ $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" }
|
{ $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" }
|
||||||
{ $example "USING: xml.syntax xml.writer namespaces ;
|
{ $example "USING: xml.syntax xml.writer namespaces ;
|
||||||
XML[[ <foo>bar</foo> XML]] \"%%%%\" indenter [ pprint-xml ] with-variable " "
|
XML-CHUNK[[ <foo>bar</foo> ]] \"%%%%\" indenter [ pprint-xml ] with-variable " "
|
||||||
<foo>
|
<foo>
|
||||||
%%%%bar
|
%%%%bar
|
||||||
</foo>" } ;
|
</foo>" } ;
|
||||||
|
@ -56,9 +56,9 @@ XML[[ <foo>bar</foo> XML]] \"%%%%\" indenter [ pprint-xml ] with-variable " "
|
||||||
HELP: sensitive-tags
|
HELP: sensitive-tags
|
||||||
{ $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" }
|
{ $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" }
|
||||||
{ $example "USING: xml.syntax xml.writer namespaces ;
|
{ $example "USING: xml.syntax xml.writer namespaces ;
|
||||||
XML[[ <html> <head> <title> something</title></head><body><pre>bing
|
XML-CHUNK[[ <html> <head> <title> something</title></head><body><pre>bing
|
||||||
bang
|
bang
|
||||||
bong</pre></body></html> XML]] { \"pre\" } sensitive-tags [ pprint-xml ] with-variable"
|
bong</pre></body></html> ]] { \"pre\" } sensitive-tags [ pprint-xml ] with-variable"
|
||||||
"
|
"
|
||||||
<html>
|
<html>
|
||||||
<head>
|
<head>
|
||||||
|
|
|
@ -71,8 +71,8 @@ in: xml.writer.tests
|
||||||
{ } [
|
{ } [
|
||||||
{ 1 2 3 4 } [
|
{ 1 2 3 4 } [
|
||||||
[ number>string ] [ sq number>string ] bi
|
[ number>string ] [ sq number>string ] bi
|
||||||
XML[[ <tr><td><-></td><td><-></td></tr> XML]]
|
XML-CHUNK[[ <tr><td><-></td><td><-></td></tr> ]]
|
||||||
] map XML[[ <h2>Timings</h2> <table><-></table> XML]]
|
] map XML-CHUNK[[ <h2>Timings</h2> <table><-></table> ]]
|
||||||
pprint-xml
|
pprint-xml
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -7,7 +7,7 @@ IN: xmode.code2html
|
||||||
[
|
[
|
||||||
[ str>> ] [ id>> ] bi [
|
[ str>> ] [ id>> ] bi [
|
||||||
name>> swap
|
name>> swap
|
||||||
XML[[ <span class=<->><-></span> XML]]
|
XML-CHUNK[[ <span class=<->><-></span> ]]
|
||||||
] when*
|
] when*
|
||||||
] map ;
|
] map ;
|
||||||
|
|
||||||
|
@ -21,14 +21,14 @@ IN: xmode.code2html
|
||||||
: default-stylesheet ( -- xml )
|
: default-stylesheet ( -- xml )
|
||||||
"resource:basis/xmode/code2html/stylesheet.css"
|
"resource:basis/xmode/code2html/stylesheet.css"
|
||||||
utf8 file-contents
|
utf8 file-contents
|
||||||
XML[[ <style><-></style> XML]] ;
|
XML-CHUNK[[ <style><-></style> ]] ;
|
||||||
|
|
||||||
:: htmlize-stream ( path stream -- xml )
|
:: htmlize-stream ( path stream -- xml )
|
||||||
stream stream-lines
|
stream stream-lines
|
||||||
[ "" ] [ path over first find-mode htmlize-lines ]
|
[ "" ] [ path over first find-mode htmlize-lines ]
|
||||||
if-empty :> input
|
if-empty :> input
|
||||||
default-stylesheet :> stylesheet
|
default-stylesheet :> stylesheet
|
||||||
<XML <html>
|
XML-DOC[[ <html>
|
||||||
<head>
|
<head>
|
||||||
<-stylesheet->
|
<-stylesheet->
|
||||||
<title><-path-></title>
|
<title><-path-></title>
|
||||||
|
@ -36,7 +36,7 @@ IN: xmode.code2html
|
||||||
<body>
|
<body>
|
||||||
<pre><-input-></pre>
|
<pre><-input-></pre>
|
||||||
</body>
|
</body>
|
||||||
</html> XML> ;
|
</html> ]] ;
|
||||||
|
|
||||||
: htmlize-file ( path -- )
|
: htmlize-file ( path -- )
|
||||||
dup utf8 [
|
dup utf8 [
|
||||||
|
|
|
@ -16,23 +16,23 @@ IN: codebook
|
||||||
|
|
||||||
CONSTANT: codebook-style
|
CONSTANT: codebook-style
|
||||||
{
|
{
|
||||||
{ COMMENT1 [ XML[[ <i><font color="#555555"><-></font></i> XML]] ] }
|
{ COMMENT1 [ XML-CHUNK[[ <i><font color="#555555"><-></font></i> ]] ] }
|
||||||
{ COMMENT2 [ XML[[ <i><font color="#555555"><-></font></i> XML]] ] }
|
{ COMMENT2 [ XML-CHUNK[[ <i><font color="#555555"><-></font></i> ]] ] }
|
||||||
{ COMMENT3 [ XML[[ <i><font color="#555555"><-></font></i> XML]] ] }
|
{ COMMENT3 [ XML-CHUNK[[ <i><font color="#555555"><-></font></i> ]] ] }
|
||||||
{ COMMENT4 [ XML[[ <i><font color="#555555"><-></font></i> XML]] ] }
|
{ COMMENT4 [ XML-CHUNK[[ <i><font color="#555555"><-></font></i> ]] ] }
|
||||||
{ DIGIT [ XML[[ <font color="#333333"><-></font> XML]] ] }
|
{ DIGIT [ XML-CHUNK[[ <font color="#333333"><-></font> ]] ] }
|
||||||
{ FUNCTION [ XML[[ <b><font color="#111111"><-></font></b> XML]] ] }
|
{ FUNCTION [ XML-CHUNK[[ <b><font color="#111111"><-></font></b> ]] ] }
|
||||||
{ KEYWORD1 [ XML[[ <b><font color="#111111"><-></font></b> XML]] ] }
|
{ KEYWORD1 [ XML-CHUNK[[ <b><font color="#111111"><-></font></b> ]] ] }
|
||||||
{ KEYWORD2 [ XML[[ <b><font color="#111111"><-></font></b> XML]] ] }
|
{ KEYWORD2 [ XML-CHUNK[[ <b><font color="#111111"><-></font></b> ]] ] }
|
||||||
{ KEYWORD3 [ XML[[ <b><font color="#111111"><-></font></b> XML]] ] }
|
{ KEYWORD3 [ XML-CHUNK[[ <b><font color="#111111"><-></font></b> ]] ] }
|
||||||
{ KEYWORD4 [ XML[[ <b><font color="#111111"><-></font></b> XML]] ] }
|
{ KEYWORD4 [ XML-CHUNK[[ <b><font color="#111111"><-></font></b> ]] ] }
|
||||||
{ LABEL [ XML[[ <b><font color="#333333"><-></font></b> XML]] ] }
|
{ LABEL [ XML-CHUNK[[ <b><font color="#333333"><-></font></b> ]] ] }
|
||||||
{ LITERAL1 [ XML[[ <font color="#333333"><-></font> XML]] ] }
|
{ LITERAL1 [ XML-CHUNK[[ <font color="#333333"><-></font> ]] ] }
|
||||||
{ LITERAL2 [ XML[[ <font color="#333333"><-></font> XML]] ] }
|
{ LITERAL2 [ XML-CHUNK[[ <font color="#333333"><-></font> ]] ] }
|
||||||
{ LITERAL3 [ XML[[ <font color="#333333"><-></font> XML]] ] }
|
{ LITERAL3 [ XML-CHUNK[[ <font color="#333333"><-></font> ]] ] }
|
||||||
{ LITERAL4 [ XML[[ <font color="#333333"><-></font> XML]] ] }
|
{ LITERAL4 [ XML-CHUNK[[ <font color="#333333"><-></font> ]] ] }
|
||||||
{ MARKUP [ XML[[ <b><font color="#333333"><-></font></b> XML]] ] }
|
{ MARKUP [ XML-CHUNK[[ <b><font color="#333333"><-></font></b> ]] ] }
|
||||||
{ OPERATOR [ XML[[ <b><font color="#111111"><-></font></b> XML]] ] }
|
{ OPERATOR [ XML-CHUNK[[ <b><font color="#111111"><-></font></b> ]] ] }
|
||||||
[ drop ]
|
[ drop ]
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -70,7 +70,7 @@ TUPLE: code-file
|
||||||
: toc-list ( files -- list )
|
: toc-list ( files -- list )
|
||||||
[ name>> ] map natural-sort [
|
[ name>> ] map natural-sort [
|
||||||
[ file-html-name ] keep
|
[ file-html-name ] keep
|
||||||
XML[[ <li><a href=<->><-></a></li> XML]]
|
XML-CHUNK[[ <li><a href=<->><-></a></li> ]]
|
||||||
] map ;
|
] map ;
|
||||||
|
|
||||||
! insert zero-width non-joiner between all characters so words can wrap anywhere
|
! insert zero-width non-joiner between all characters so words can wrap anywhere
|
||||||
|
@ -82,7 +82,7 @@ TUPLE: code-file
|
||||||
: htmlize-tokens ( tokens line# -- html-tokens )
|
: htmlize-tokens ( tokens line# -- html-tokens )
|
||||||
swap [
|
swap [
|
||||||
[ str>> zwnj ] [ id>> ] bi codebook-style case
|
[ str>> zwnj ] [ id>> ] bi codebook-style case
|
||||||
] map XML[[ <tt><font size="-2" color="#666666"><-></font> <-></tt> XML]]
|
] map XML-CHUNK[[ <tt><font size="-2" color="#666666"><-></font> <-></tt> ]]
|
||||||
"\n" 2array ;
|
"\n" 2array ;
|
||||||
|
|
||||||
: line#>string ( i line#len -- i-string )
|
: line#>string ( i line#len -- i-string )
|
||||||
|
@ -96,7 +96,7 @@ TUPLE: code-file
|
||||||
file mode>> load-mode :> rules
|
file mode>> load-mode :> rules
|
||||||
f lines |[ l i | l rules tokenize-line i 1 + line#len line#>string htmlize-tokens ]
|
f lines |[ l i | l rules tokenize-line i 1 + line#len line#>string htmlize-tokens ]
|
||||||
map-index concat nip :> html-lines
|
map-index concat nip :> html-lines
|
||||||
<XML <html>
|
XML-DOC[[ <html>
|
||||||
<head>
|
<head>
|
||||||
<title><-name-></title>
|
<title><-name-></title>
|
||||||
<meta http-equiv="Content-type" content="text/html; charset=utf-8" />
|
<meta http-equiv="Content-type" content="text/html; charset=utf-8" />
|
||||||
|
@ -106,7 +106,7 @@ TUPLE: code-file
|
||||||
<pre><-html-lines-></pre>
|
<pre><-html-lines-></pre>
|
||||||
<mbp:pagebreak xmlns:mbp="http://www.mobipocket.com/mbp" />
|
<mbp:pagebreak xmlns:mbp="http://www.mobipocket.com/mbp" />
|
||||||
</body>
|
</body>
|
||||||
</html> XML> ;
|
</html> ]] ;
|
||||||
|
|
||||||
:: code>toc-html ( dir name files -- html )
|
:: code>toc-html ( dir name files -- html )
|
||||||
"Generating HTML table of contents" print flush
|
"Generating HTML table of contents" print flush
|
||||||
|
@ -116,7 +116,7 @@ TUPLE: code-file
|
||||||
dir [
|
dir [
|
||||||
files toc-list :> toc
|
files toc-list :> toc
|
||||||
|
|
||||||
<XML <html>
|
XML-DOC[[ <html>
|
||||||
<head>
|
<head>
|
||||||
<title><-name-></title>
|
<title><-name-></title>
|
||||||
<meta http-equiv="Content-type" content="text/html; charset=utf-8" />
|
<meta http-equiv="Content-type" content="text/html; charset=utf-8" />
|
||||||
|
@ -130,7 +130,7 @@ TUPLE: code-file
|
||||||
<ul><-toc-></ul>
|
<ul><-toc-></ul>
|
||||||
<mbp:pagebreak xmlns:mbp="http://www.mobipocket.com/mbp" />
|
<mbp:pagebreak xmlns:mbp="http://www.mobipocket.com/mbp" />
|
||||||
</body>
|
</body>
|
||||||
</html> XML>
|
</html> ]]
|
||||||
] with-directory ;
|
] with-directory ;
|
||||||
|
|
||||||
:: code>ncx ( dir name files -- xml )
|
:: code>ncx ( dir name files -- xml )
|
||||||
|
@ -141,13 +141,13 @@ TUPLE: code-file
|
||||||
name file-html-name :> filename
|
name file-html-name :> filename
|
||||||
i 2 + number>string :> istr
|
i 2 + number>string :> istr
|
||||||
|
|
||||||
XML[[ <navPoint class="book" id=<-filename-> playOrder=<-istr->>
|
XML-CHUNK[[ <navPoint class="book" id=<-filename-> playOrder=<-istr->>
|
||||||
<navLabel><text><-name-></text></navLabel>
|
<navLabel><text><-name-></text></navLabel>
|
||||||
<content src=<-filename-> />
|
<content src=<-filename-> />
|
||||||
</navPoint> XML]]
|
</navPoint> ]]
|
||||||
] map-index :> file-nav-points
|
] map-index :> file-nav-points
|
||||||
|
|
||||||
<XML <?xml version="1.0" encoding="UTF-8" ?>
|
XML-DOC[[ <?xml version="1.0" encoding="UTF-8" ?>
|
||||||
<ncx version="2005-1" xmlns="http://www.daisy.org/z3986/2005/ncx/">
|
<ncx version="2005-1" xmlns="http://www.daisy.org/z3986/2005/ncx/">
|
||||||
<navMap>
|
<navMap>
|
||||||
<navPoint class="book" id="toc" playOrder="1">
|
<navPoint class="book" id="toc" playOrder="1">
|
||||||
|
@ -156,7 +156,7 @@ TUPLE: code-file
|
||||||
</navPoint>
|
</navPoint>
|
||||||
<-file-nav-points->
|
<-file-nav-points->
|
||||||
</navMap>
|
</navMap>
|
||||||
</ncx> XML> ;
|
</ncx> ]] ;
|
||||||
|
|
||||||
:: code>opf ( dir name files -- xml )
|
:: code>opf ( dir name files -- xml )
|
||||||
"Generating OPF manifest" print flush
|
"Generating OPF manifest" print flush
|
||||||
|
@ -164,12 +164,12 @@ TUPLE: code-file
|
||||||
|
|
||||||
files [
|
files [
|
||||||
name>> file-html-name dup
|
name>> file-html-name dup
|
||||||
XML[[ <item id=<-> href=<-> media-type="text/html" /> XML]]
|
XML-CHUNK[[ <item id=<-> href=<-> media-type="text/html" /> ]]
|
||||||
] map :> html-manifest
|
] map :> html-manifest
|
||||||
|
|
||||||
files [ name>> file-html-name XML[[ <itemref idref=<-> /> XML]] ] map :> html-spine
|
files [ name>> file-html-name XML-CHUNK[[ <itemref idref=<-> /> ]] ] map :> html-spine
|
||||||
|
|
||||||
<XML <?xml version="1.0" encoding="UTF-8" ?>
|
XML-DOC[[ <?xml version="1.0" encoding="UTF-8" ?>
|
||||||
<package
|
<package
|
||||||
version="2.0"
|
version="2.0"
|
||||||
xmlns="http://www.idpf.org/2007/opf"
|
xmlns="http://www.idpf.org/2007/opf"
|
||||||
|
@ -192,7 +192,7 @@ TUPLE: code-file
|
||||||
<guide>
|
<guide>
|
||||||
<reference type="toc" title="Table of Contents" href="_toc.html" />
|
<reference type="toc" title="Table of Contents" href="_toc.html" />
|
||||||
</guide>
|
</guide>
|
||||||
</package> XML> ;
|
</package> ]] ;
|
||||||
|
|
||||||
: write-dest-file ( xml name ext -- )
|
: write-dest-file ( xml name ext -- )
|
||||||
append utf8 [ write-xml ] with-file-writer ;
|
append utf8 [ write-xml ] with-file-writer ;
|
||||||
|
|
|
@ -69,11 +69,11 @@ M: pathname url-of
|
||||||
|
|
||||||
: help-stylesheet ( stylesheet -- xml )
|
: help-stylesheet ( stylesheet -- xml )
|
||||||
"vocab:help/html/stylesheet.css" ascii file-contents
|
"vocab:help/html/stylesheet.css" ascii file-contents
|
||||||
swap "\n" glue XML[[ <style><-></style> XML]] ;
|
swap "\n" glue XML-CHUNK[[ <style><-></style> ]] ;
|
||||||
|
|
||||||
: help-navbar ( -- xml )
|
: help-navbar ( -- xml )
|
||||||
"conventions" >link topic>filename
|
"conventions" >link topic>filename
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<div class="navbar">
|
<div class="navbar">
|
||||||
<b> Factor Documentation </b> |
|
<b> Factor Documentation </b> |
|
||||||
<a href="/">Home</a> |
|
<a href="/">Home</a> |
|
||||||
|
@ -84,7 +84,7 @@ M: pathname url-of
|
||||||
</form>
|
</form>
|
||||||
<a href="http://factorcode.org" style="float:right; padding: 4px;">factorcode.org</a>
|
<a href="http://factorcode.org" style="float:right; padding: 4px;">factorcode.org</a>
|
||||||
</div>
|
</div>
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
: bijective-base26 ( n -- name )
|
: bijective-base26 ( n -- name )
|
||||||
[ dup 0 > ] [ 1 - 26 /mod char: a + ] "" produce-as nip reverse! ;
|
[ dup 0 > ] [ 1 - 26 /mod char: a + ] "" produce-as nip reverse! ;
|
||||||
|
|
|
@ -8,7 +8,7 @@ IN: mason.report
|
||||||
|
|
||||||
: git-link ( id -- link )
|
: git-link ( id -- link )
|
||||||
[ "http://github.com/factor/factor/commit/" "" prepend-as ] keep
|
[ "http://github.com/factor/factor/commit/" "" prepend-as ] keep
|
||||||
XML[[ <a href=<->><-></a> XML]] ;
|
XML-CHUNK[[ <a href=<->><-></a> ]] ;
|
||||||
|
|
||||||
: common-report ( -- xml )
|
: common-report ( -- xml )
|
||||||
target-os get
|
target-os get
|
||||||
|
@ -17,7 +17,7 @@ IN: mason.report
|
||||||
disk-usage
|
disk-usage
|
||||||
build-dir
|
build-dir
|
||||||
current-git-id get git-link
|
current-git-id get git-link
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<h1>Build report for <->/<-></h1>
|
<h1>Build report for <->/<-></h1>
|
||||||
<table>
|
<table>
|
||||||
<tr><td>Build machine:</td><td><-></td></tr>
|
<tr><td>Build machine:</td><td><-></td></tr>
|
||||||
|
@ -25,14 +25,14 @@ IN: mason.report
|
||||||
<tr><td>Build directory:</td><td><-></td></tr>
|
<tr><td>Build directory:</td><td><-></td></tr>
|
||||||
<tr><td>GIT ID:</td><td><-></td></tr>
|
<tr><td>GIT ID:</td><td><-></td></tr>
|
||||||
</table>
|
</table>
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
: with-report ( quot -- )
|
: with-report ( quot -- )
|
||||||
[ "report" utf8 ] dip
|
[ "report" utf8 ] dip
|
||||||
'[
|
'[
|
||||||
common-report
|
common-report
|
||||||
_ call( -- xml )
|
_ call( -- xml )
|
||||||
XML[[ <html><body><-><-></body></html> XML]]
|
XML-CHUNK[[ <html><body><-><-></body></html> ]]
|
||||||
write-xml
|
write-xml
|
||||||
] with-file-writer ; inline
|
] with-file-writer ; inline
|
||||||
|
|
||||||
|
@ -44,13 +44,13 @@ IN: mason.report
|
||||||
error [ error. ] with-string-writer :> error
|
error [ error. ] with-string-writer :> error
|
||||||
file utf8 400 file-tail :> output
|
file utf8 400 file-tail :> output
|
||||||
|
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<h2><-what-></h2>
|
<h2><-what-></h2>
|
||||||
Build output:
|
Build output:
|
||||||
<pre><-output-></pre>
|
<pre><-output-></pre>
|
||||||
Launcher error:
|
Launcher error:
|
||||||
<pre><-error-></pre>
|
<pre><-error-></pre>
|
||||||
XML]]
|
]]
|
||||||
] with-report
|
] with-report
|
||||||
status-error ;
|
status-error ;
|
||||||
|
|
||||||
|
@ -73,30 +73,30 @@ IN: mason.report
|
||||||
html-help-time-file
|
html-help-time-file
|
||||||
} [
|
} [
|
||||||
dup eval-file nanos>time
|
dup eval-file nanos>time
|
||||||
XML[[ <tr><td><-></td><td><-></td></tr> XML]]
|
XML-CHUNK[[ <tr><td><-></td><td><-></td></tr> ]]
|
||||||
] map XML[[ <h2>Timings</h2> <table><-></table> XML]] ;
|
] map XML-CHUNK[[ <h2>Timings</h2> <table><-></table> ]] ;
|
||||||
|
|
||||||
: error-dump ( heading vocabs-file messages-file -- xml )
|
: error-dump ( heading vocabs-file messages-file -- xml )
|
||||||
[ eval-file ] dip over empty? [ 3drop f ] [
|
[ eval-file ] dip over empty? [ 3drop f ] [
|
||||||
[ ]
|
[ ]
|
||||||
[ [ XML[[ <li><-></li> XML]] ] map XML[[ <ul><-></ul> XML]] ]
|
[ [ XML-CHUNK[[ <li><-></li> ]] ] map XML-CHUNK[[ <ul><-></ul> ]] ]
|
||||||
[ utf8 file-contents ]
|
[ utf8 file-contents ]
|
||||||
tri*
|
tri*
|
||||||
XML[[ <h1><-></h1> <-> Details: <pre><-></pre> XML]]
|
XML-CHUNK[[ <h1><-></h1> <-> Details: <pre><-></pre> ]]
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: benchmarks-table ( assoc -- xml )
|
: benchmarks-table ( assoc -- xml )
|
||||||
[
|
[
|
||||||
1,000,000,000 /f
|
1,000,000,000 /f
|
||||||
XML[[ <tr><td><-></td><td><-></td></tr> XML]]
|
XML-CHUNK[[ <tr><td><-></td><td><-></td></tr> ]]
|
||||||
] { } assoc>map
|
] { } assoc>map
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<h2>Benchmarks</h2>
|
<h2>Benchmarks</h2>
|
||||||
<table>
|
<table>
|
||||||
<tr><th>Benchmark</th><th>Time (seconds)</th></tr>
|
<tr><th>Benchmark</th><th>Time (seconds)</th></tr>
|
||||||
<->
|
<->
|
||||||
</table>
|
</table>
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
: successful-report ( -- )
|
: successful-report ( -- )
|
||||||
[
|
[
|
||||||
|
|
|
@ -56,18 +56,18 @@ symbol: time-std
|
||||||
: info-table ( alist -- html )
|
: info-table ( alist -- html )
|
||||||
[
|
[
|
||||||
first2 dupd 1000000 /f
|
first2 dupd 1000000 /f
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<tr><td><a href=<->><-></a></td><td><-> seconds</td></tr>
|
<tr><td><a href=<->><-></a></td><td><-> seconds</td></tr>
|
||||||
XML]]
|
]]
|
||||||
] map XML[[ <table border="1"><-></table> XML]] ;
|
] map XML-CHUNK[[ <table border="1"><-></table> ]] ;
|
||||||
|
|
||||||
: report-broken-pages ( -- html )
|
: report-broken-pages ( -- html )
|
||||||
broken-pages get info-table ;
|
broken-pages get info-table ;
|
||||||
|
|
||||||
: report-network-failures ( -- html )
|
: report-network-failures ( -- html )
|
||||||
network-failures get [
|
network-failures get [
|
||||||
dup XML[[ <li><a href=<->><-></a></li> XML]]
|
dup XML-CHUNK[[ <li><a href=<->><-></a></li> ]]
|
||||||
] map XML[[ <ul><-></ul> XML]] ;
|
] map XML-CHUNK[[ <ul><-></ul> ]] ;
|
||||||
|
|
||||||
: slowest-pages-table ( -- html )
|
: slowest-pages-table ( -- html )
|
||||||
slowest-pages get info-table ;
|
slowest-pages get info-table ;
|
||||||
|
@ -76,31 +76,31 @@ symbol: time-std
|
||||||
mean-time get
|
mean-time get
|
||||||
median-time get
|
median-time get
|
||||||
time-std get
|
time-std get
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<table border="1">
|
<table border="1">
|
||||||
<tr><th>Mean</th><td><-> seconds</td></tr>
|
<tr><th>Mean</th><td><-> seconds</td></tr>
|
||||||
<tr><th>Median</th><td><-> seconds</td></tr>
|
<tr><th>Median</th><td><-> seconds</td></tr>
|
||||||
<tr><th>Standard deviation</th><td><-> seconds</td></tr>
|
<tr><th>Standard deviation</th><td><-> seconds</td></tr>
|
||||||
</table>
|
</table>
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
: report-timings ( -- html )
|
: report-timings ( -- html )
|
||||||
slowest-pages-table
|
slowest-pages-table
|
||||||
timing-summary-table
|
timing-summary-table
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<h3>Slowest pages</h3>
|
<h3>Slowest pages</h3>
|
||||||
<->
|
<->
|
||||||
|
|
||||||
<h3>Summary</h3>
|
<h3>Summary</h3>
|
||||||
<->
|
<->
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
: generate-report ( -- html )
|
: generate-report ( -- html )
|
||||||
url get dup
|
url get dup
|
||||||
report-broken-pages
|
report-broken-pages
|
||||||
report-network-failures
|
report-network-failures
|
||||||
report-timings
|
report-timings
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<h1>Spider report</h1>
|
<h1>Spider report</h1>
|
||||||
URL: <a href=<->><-></a>
|
URL: <a href=<->><-></a>
|
||||||
|
|
||||||
|
@ -112,7 +112,7 @@ symbol: time-std
|
||||||
|
|
||||||
<h2>Load times</h2>
|
<h2>Load times</h2>
|
||||||
<->
|
<->
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
: spider-report ( spider -- html )
|
: spider-report ( spider -- html )
|
||||||
[ "Spider report" f ] dip
|
[ "Spider report" f ] dip
|
||||||
|
|
|
@ -2,7 +2,7 @@ USING: io xml.syntax xml.writer ;
|
||||||
IN: tools.deploy.test.20
|
IN: tools.deploy.test.20
|
||||||
|
|
||||||
: test-xml ( str -- str' )
|
: test-xml ( str -- str' )
|
||||||
<XML <foo><-></foo> XML> xml>string ;
|
XML-DOC[[ <foo><-></foo> ]] xml>string ;
|
||||||
|
|
||||||
: main ( -- )
|
: main ( -- )
|
||||||
"Factor" test-xml print ;
|
"Factor" test-xml print ;
|
||||||
|
|
|
@ -27,8 +27,8 @@ CONSTANT: tc-lisp-slides
|
||||||
{ $code
|
{ $code
|
||||||
"USING: splitting xml.writer xml.syntax ;
|
"USING: splitting xml.writer xml.syntax ;
|
||||||
{ \"one\" \"two\" \"three\" }
|
{ \"one\" \"two\" \"three\" }
|
||||||
[ XML[[ <item><-></item> XML]] ] map
|
[ XML-CHUNK[[ <item><-></item> ]] ] map
|
||||||
<XML <doc><-></doc> XML> pprint-xml"
|
XML-DOC[[ <doc><-></doc> ]] pprint-xml"
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
{ $slide "Differences between Factor and Lisp"
|
{ $slide "Differences between Factor and Lisp"
|
||||||
|
|
|
@ -5,8 +5,8 @@ mason.email webapps.mason.backend ;
|
||||||
IN: webapps.mason.backend.watchdog
|
IN: webapps.mason.backend.watchdog
|
||||||
|
|
||||||
: crashed-builder-body ( crashed-builders -- string content-type )
|
: crashed-builder-body ( crashed-builders -- string content-type )
|
||||||
[ os/cpu XML[[ <li><-></li> XML]] ] map
|
[ os/cpu XML-CHUNK[[ <li><-></li> ]] ] map
|
||||||
<XML
|
XML-DOC[[
|
||||||
<html>
|
<html>
|
||||||
<body>
|
<body>
|
||||||
<p>Machines which are not sending heartbeats:</p>
|
<p>Machines which are not sending heartbeats:</p>
|
||||||
|
@ -14,7 +14,7 @@ IN: webapps.mason.backend.watchdog
|
||||||
<a href="http://builds.factorcode.org/dashboard">Dashboard</a>
|
<a href="http://builds.factorcode.org/dashboard">Dashboard</a>
|
||||||
</body>
|
</body>
|
||||||
</html>
|
</html>
|
||||||
XML> xml>string
|
]] xml>string
|
||||||
"text/html" ;
|
"text/html" ;
|
||||||
|
|
||||||
: s ( n before after -- string )
|
: s ( n before after -- string )
|
||||||
|
|
|
@ -6,10 +6,10 @@ webapps.mason.utils ;
|
||||||
IN: webapps.mason.downloads
|
IN: webapps.mason.downloads
|
||||||
|
|
||||||
CONSTANT: CRASHED
|
CONSTANT: CRASHED
|
||||||
XML[[ <span style="background-color: yellow;">CRASHED</span> XML]]
|
XML-CHUNK[[ <span style="background-color: yellow;">CRASHED</span> ]]
|
||||||
|
|
||||||
CONSTANT: BROKEN
|
CONSTANT: BROKEN
|
||||||
XML[[ <span style="background-color: red; color: white;">BROKEN</span> XML]]
|
XML-CHUNK[[ <span style="background-color: red; color: white;">BROKEN</span> ]]
|
||||||
|
|
||||||
: builder-status ( builder -- status/f )
|
: builder-status ( builder -- status/f )
|
||||||
{
|
{
|
||||||
|
@ -22,10 +22,10 @@ XML[[ <span style="background-color: red; color: white;">BROKEN</span> XML]]
|
||||||
[ os/cpu ] sort-with
|
[ os/cpu ] sort-with
|
||||||
[
|
[
|
||||||
[ report-url ] [ os/cpu ] [ builder-status ] tri
|
[ report-url ] [ os/cpu ] [ builder-status ] tri
|
||||||
XML[[ <li><a href=<->><-></a> <-></li> XML]]
|
XML-CHUNK[[ <li><a href=<->><-></a> <-></li> ]]
|
||||||
] map
|
] map
|
||||||
[ XML[[ <p>No machines.</p> XML]] ]
|
[ XML-CHUNK[[ <p>No machines.</p> ]] ]
|
||||||
[ XML[[ <ul><-></ul> XML]] ]
|
[ XML-CHUNK[[ <ul><-></ul> ]] ]
|
||||||
if-empty ;
|
if-empty ;
|
||||||
|
|
||||||
: <dashboard-action> ( -- action )
|
: <dashboard-action> ( -- action )
|
||||||
|
|
|
@ -9,8 +9,8 @@ IN: webapps.mason.grids
|
||||||
: render-grid-cell ( cpu os quot -- xml )
|
: render-grid-cell ( cpu os quot -- xml )
|
||||||
call( cpu os -- url label )
|
call( cpu os -- url label )
|
||||||
2dup and
|
2dup and
|
||||||
[ link XML[[ <td class="supported"><div class="bigdiv"><-></div></td> XML]] ]
|
[ link XML-CHUNK[[ <td class="supported"><div class="bigdiv"><-></div></td> ]] ]
|
||||||
[ 2drop XML[[ <td class="doesnotexist" /> XML]] ]
|
[ 2drop XML-CHUNK[[ <td class="doesnotexist" /> ]] ]
|
||||||
if ;
|
if ;
|
||||||
|
|
||||||
CONSTANT: oses
|
CONSTANT: oses
|
||||||
|
@ -27,21 +27,21 @@ CONSTANT: cpus
|
||||||
}
|
}
|
||||||
|
|
||||||
: render-grid-header ( -- xml )
|
: render-grid-header ( -- xml )
|
||||||
oses values [ XML[[ <th align='center' scope='col'><-></th> XML]] ] map ;
|
oses values [ XML-CHUNK[[ <th align='center' scope='col'><-></th> ]] ] map ;
|
||||||
|
|
||||||
:: render-grid-row ( cpu quot -- xml )
|
:: render-grid-row ( cpu quot -- xml )
|
||||||
cpu second oses keys |[ os | cpu os quot render-grid-cell ] map
|
cpu second oses keys |[ os | cpu os quot render-grid-cell ] map
|
||||||
XML[[ <tr><th align='center' scope='row'><-></th><-></tr> XML]] ;
|
XML-CHUNK[[ <tr><th align='center' scope='row'><-></th><-></tr> ]] ;
|
||||||
|
|
||||||
:: render-grid ( quot -- xml )
|
:: render-grid ( quot -- xml )
|
||||||
render-grid-header
|
render-grid-header
|
||||||
cpus [ quot render-grid-row ] map
|
cpus [ quot render-grid-row ] map
|
||||||
XML[[
|
XML-CHUNK[[
|
||||||
<table id="downloads" cellspacing="0">
|
<table id="downloads" cellspacing="0">
|
||||||
<tr><th class="nobg">OS/CPU</th><-></tr>
|
<tr><th class="nobg">OS/CPU</th><-></tr>
|
||||||
<->
|
<->
|
||||||
</table>
|
</table>
|
||||||
XML]] ;
|
]] ;
|
||||||
|
|
||||||
: package-date ( filename -- date )
|
: package-date ( filename -- date )
|
||||||
"." split1 drop 16 tail* 6 head* ;
|
"." split1 drop 16 tail* 6 head* ;
|
||||||
|
|
|
@ -9,7 +9,7 @@ IN: webapps.mason.package
|
||||||
|
|
||||||
: building ( builder string -- xml )
|
: building ( builder string -- xml )
|
||||||
swap current-git-id>> git-link
|
swap current-git-id>> git-link
|
||||||
XML[[ <-> for <-> XML]] ;
|
XML-CHUNK[[ <-> for <-> ]] ;
|
||||||
|
|
||||||
: status-string ( builder -- string )
|
: status-string ( builder -- string )
|
||||||
dup status>> {
|
dup status>> {
|
||||||
|
|
|
@ -20,4 +20,4 @@ IN: webapps.mason.report
|
||||||
[ URL" report" ] dip
|
[ URL" report" ] dip
|
||||||
[ os>> "os" set-query-param ]
|
[ os>> "os" set-query-param ]
|
||||||
[ cpu>> "cpu" set-query-param ] bi
|
[ cpu>> "cpu" set-query-param ] bi
|
||||||
XML[[ <a href=<->>Latest build report</a> XML]] ;
|
XML-CHUNK[[ <a href=<->>Latest build report</a> ]] ;
|
||||||
|
|
|
@ -7,7 +7,7 @@ webapps.mason.version.data xml.syntax ;
|
||||||
IN: webapps.mason.utils
|
IN: webapps.mason.utils
|
||||||
|
|
||||||
: link ( url label -- xml )
|
: link ( url label -- xml )
|
||||||
XML[[ <a href=<->><-></a> XML]] ;
|
XML-CHUNK[[ <a href=<->><-></a> ]] ;
|
||||||
|
|
||||||
: validate-os/cpu ( -- )
|
: validate-os/cpu ( -- )
|
||||||
{
|
{
|
||||||
|
@ -35,7 +35,7 @@ IN: webapps.mason.utils
|
||||||
?
|
?
|
||||||
] [ drop f ] if
|
] [ drop f ] if
|
||||||
] bi
|
] bi
|
||||||
2array sift [ XML[[ <li><-></li> XML]] ] map XML[[ <ul><-></ul> XML]] ;
|
2array sift [ XML-CHUNK[[ <li><-></li> ]] ] map XML-CHUNK[[ <ul><-></ul> ]] ;
|
||||||
|
|
||||||
: download-url ( string -- string' )
|
: download-url ( string -- string' )
|
||||||
"http://downloads.factorcode.org/" prepend ;
|
"http://downloads.factorcode.org/" prepend ;
|
||||||
|
|
Loading…
Reference in New Issue