Converting Farkup, html.components and lcs.diff2html to xml.interpolate

basis/farkup/farkup.factor

@@ -232,8 +232,11 @@ M: vector (write-farkup) [ (write-farkup) ] map ;
 
 M: f (write-farkup) ;
 
+: farkup>xml ( string -- xml )
+    parse-farkup (write-farkup) ;
+
 : write-farkup ( string -- )
-    parse-farkup (write-farkup) write-xml-chunk ;
+    farkup>xml write-xml-chunk ;
 
 : convert-farkup ( string -- string' )
     [ write-farkup ] with-string-writer ;

basis/html/components/components-tests.factor

@@ -31,7 +31,7 @@ TUPLE: color red green blue ;
     ] with-string-writer
 ] unit-test
 
-[ "<input type='hidden' name='red' value='<jimmy>'/>" ] [
+[ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
     [
         "red" hidden render
     ] with-string-writer
@@ -39,13 +39,13 @@ TUPLE: color red green blue ;
 
 [ ] [ "'jimmy'" "red" set-value ] unit-test
 
-[ "<input type='text' size='5' name='red' value='&apos;jimmy&apos;'/>" ] [
+[ "<input value=\"&apos;jimmy&apos;\" name=\"red\" size=\"5\" type=\"text\"/>" ] [
     [
         "red" <field> 5 >>size render
     ] with-string-writer
 ] unit-test
 
-[ "<input type='password' size='5' name='red' value=''/>" ] [
+[ "<input value=\"\" name=\"red\" size=\"5\" type=\"password\"/>" ] [
     [
         "red" <password> 5 >>size render
     ] with-string-writer
@@ -105,7 +105,7 @@ TUPLE: color red green blue ;
 
 [ ] [ t "delivery" set-value ] unit-test
 
-[ "<input type='checkbox' name='delivery' checked='true'>Delivery</input>" ] [
+[ "<input type=\"checkbox\" checked=\"true\" name=\"delivery\">Delivery</input>" ] [
     [
         "delivery"
         <checkbox>
@@ -116,7 +116,7 @@ TUPLE: color red green blue ;
 
 [ ] [ f "delivery" set-value ] unit-test
 
-[ "<input type='checkbox' name='delivery'>Delivery</input>" ] [
+[ "<input type=\"checkbox\" name=\"delivery\">Delivery</input>" ] [
     [
         "delivery"
         <checkbox>
@@ -133,7 +133,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
 
 [ ] [ link-test "link" set-value ] unit-test
 
-[ "<a href='http://www.apple.com/foo&amp;bar'>&lt;Link Title&gt;</a>" ] [
+[ "<a href=\"http://www.apple.com/foo&amp;bar\">&lt;Link Title&gt;</a>" ] [
     [ "link" link new render ] with-string-writer
 ] unit-test
 
@@ -149,7 +149,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
 
 [ ] [ "java" "mode" set-value ] unit-test
 
-[ "<span class='KEYWORD3'>int</span> x <span class='OPERATOR'>=</span> <span class='DIGIT'>4</span>;\n" ] [
+[ "<span class=\"KEYWORD3\">int</span> x <span class=\"OPERATOR\">=</span> <span class=\"DIGIT\">4</span>;" ] [
     [ "code" <code> "mode" >>mode render ] with-string-writer
 ] unit-test
 
@@ -163,6 +163,8 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
 
 [ t ] [
     [ "object" inspector render ] with-string-writer
+    USING: splitting sequences ;
+    "\"" split "'" join ! replace " with ' for now
     [ "object" value [ describe ] with-html-writer ] with-string-writer
     =
 ] unit-test

basis/html/components/components.factor

@@ -4,12 +4,12 @@ USING: accessors kernel namespaces io math.parser assocs classes
 classes.tuple words arrays sequences splitting mirrors
 hashtables combinators continuations math strings inspector
 fry locals calendar calendar.format xml.entities
-validators urls present
+validators urls present xml.writer xml.interpolate xml
-xmode.code2html lcs.diff2html farkup
+xmode.code2html lcs.diff2html farkup io.streams.string
 html.elements html.streams html.forms ;
 IN: html.components
 
-GENERIC: render* ( value name renderer -- )
+GENERIC: render* ( value name renderer -- xml )
 
 : render ( name renderer -- )
     prepare-value
@@ -19,38 +19,36 @@ GENERIC: render* ( value name renderer -- )
         [ f swap ]
         if
     ] 2dip
-    render*
+    render* write-xml-chunk
     [ render-error ] when* ;
 
 <PRIVATE
 
-: render-input ( value name type -- )
+: render-input ( value name type -- xml )
-    <input =type =name present =value input/> ;
+    [XML <input value=<-> name=<-> type=<->/> XML] ;
 
 PRIVATE>
 
 SINGLETON: label
 
-M: label render* 2drop present escape-string write ;
+M: label render*
+    2drop present ;
 
 SINGLETON: hidden
 
-M: hidden render* drop "hidden" render-input ;
+M: hidden render*
+    drop "hidden" render-input ;
 
-: render-field ( value name size type -- )
+: render-field ( value name size type -- xml )
-    <input
+    [XML <input value=<-> name=<-> size=<-> type=<->/> XML] ;
-        =type
-        [ present =size ] when*
-        =name
-        present =value
-    input/> ;
 
 TUPLE: field size ;
 
 : <field> ( -- field )
     field new ;
 
-M: field render* size>> "text" render-field ;
+M: field render*
+    size>> "text" render-field ;
 
 TUPLE: password size ;
 
@@ -67,14 +65,12 @@ TUPLE: textarea rows cols ;
 : <textarea> ( -- renderer )
     textarea new ;
 
-M: textarea render*
+M: textarea render* ( value name area -- xml )
-    <textarea
+    rot [ [ rows>> ] [ cols>> ] bi ] dip
-        [ rows>> [ present =rows ] when* ]
+    [XML <textarea
-        [ cols>> [ present =cols ] when* ] bi
+            name=<->
-        =name
+            rows=<->
-    textarea>
+            cols=<->><-></textarea> XML] ;
-        present escape-string write
-    </textarea> ;
 
 ! Choice
 TUPLE: choice size multiple choices ;
@@ -82,24 +78,23 @@ TUPLE: choice size multiple choices ;
 : <choice> ( -- choice )
     choice new ;
 
-: render-option ( text selected? -- )
+: render-option ( text selected? -- xml )
-    <option [ "selected" =selected ] when option>
+    "selected" and swap
-        present escape-string write
+    [XML <option selected=<->><-></option> XML] ;
-    </option> ;
 
-: render-options ( options selected -- )
+: render-options ( value choice -- xml )
-    '[ dup _ member? render-option ] each ;
-
-M: choice render*
-    <select
-        swap =name
-        dup size>> [ present =size ] when*
-        dup multiple>> [ "true" =multiple ] when
-    select>
     [ choices>> value ] [ multiple>> ] bi
     [ swap ] [ swap 1array ] if
-        render-options
+    '[ dup _ member? render-option ] map ;
-    </select> ;
+
+M:: choice render* ( value name choice -- xml )
+    choice size>> :> size
+    choice multiple>> "true" and :> multiple
+    value choice render-options :> contents
+    [XML <select
+        name=<-name->
+        size=<-size->
+        multiple=<-multiple->><-contents-></select> XML] ;
 
 ! Checkboxes
 TUPLE: checkbox label ;
@@ -108,13 +103,10 @@ TUPLE: checkbox label ;
     checkbox new ;
 
 M: checkbox render*
-    <input
+    [ "true" and ] [ ] [ label>> ] tri*
-        "checkbox" =type
+    [XML <input
-        swap =name
+        type="checkbox"
-        swap [ "true" =checked ] when
+        checked=<-> name=<->><-></input> XML] ;
-    input>
-        label>> escape-string write
-    </input> ;
 
 ! Link components
 GENERIC: link-title ( obj -- string )
@@ -129,10 +121,9 @@ M: url link-href ;
 TUPLE: link target ;
 
 M: link render*
-    nip
+    nip swap
-    <a target>> [ =target ] when* dup link-href =href a>
+    [ target>> ] [ [ link-href ] [ link-title ] bi ] bi*
-        link-title present escape-string write
+    [XML <a target=<-> href=<->><-></a> XML] ;
-    </a> ;
 
 ! XMode code component
 TUPLE: code mode ;
@@ -161,7 +152,7 @@ M: farkup render*
         nip
         [ no-follow>> [ string>boolean link-no-follow? set ] when* ]
         [ disable-images>> [ string>boolean disable-images? set ] when* ]
-        [ parsed>> string>boolean [ (write-farkup) ] [ write-farkup ] if ]
+        [ parsed>> string>boolean [ (write-farkup) ] [ farkup>xml ] if ]
         tri
     ] with-scope ;
 
@@ -169,7 +160,8 @@ M: farkup render*
 SINGLETON: inspector
 
 M: inspector render*
-    2drop [ describe ] with-html-writer ;
+    2drop [ [ describe ] with-html-writer ] with-string-writer
+    string>xml-chunk ;
 
 ! Diff component
 SINGLETON: comparison
@@ -180,4 +172,4 @@ M: comparison render*
 ! HTML component
 SINGLETON: html
 
-M: html render* 2drop write ;
+M: html render* 2drop string>xml-chunk ;

basis/lcs/diff2html/diff2html.factor

@@ -1,44 +1,42 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: lcs html.elements kernel ;
+USING: lcs xml.interpolate xml.writer kernel strings ;
 FROM: accessors => item>> ;
 FROM: io => write ;
-FROM: sequences => each if-empty ;
+FROM: sequences => each if-empty when-empty map ;
-FROM: xml.entities => escape-string ;
 IN: lcs.diff2html
 
-GENERIC: diff-line ( obj -- )
+GENERIC: diff-line ( obj -- xml )
 
-: write-item ( item -- )
+: item-string ( item -- string )
-    item>> [ " " ] [ escape-string ] if-empty write ;
+    item>> [ CHAR: no-break-space 1string ] when-empty ;
 
 M: retain diff-line
-    <tr>
+    item-string
-        dup [
+    [XML <td class="retain"><-></td> XML]
-            <td "retain" =class td>
+    dup [XML <tr><-><-></tr> XML] ;
-                write-item
-            </td>
-        ] bi@
-    </tr> ;
 
 M: insert diff-line
+    [XML
         <tr>
             <td> </td>
-        <td "insert" =class td>
+            <td class="insert"><-></td>
-            write-item
+        </tr>
-        </td>
+    XML] ;
-    </tr> ;
 
 M: delete diff-line
+    [XML
         <tr>
-        <td "delete" =class td>
+            <td class="delete"><-></td>
-            write-item
-        </td>
             <td> </td>
-    </tr> ;
+        </tr>
+    XML] ;
 
-: htmlize-diff ( diff -- )
+: htmlize-diff ( diff -- xml )
-    <table "100%" =width "comparison" =class table>
+    [ diff-line ] map
-        <tr> <th> "Old" write </th> <th> "New" write </th> </tr>
+    [XML
-        [ diff-line ] each
+        <table width="100%" class="comparison">
-    </table> ;
+            <tr><th>Old</th><th>New</th></tr>
+            <->
+        </table>
+    XML] ;

basis/xml/data/data.factor

@@ -216,3 +216,6 @@ M: xml like
 
 PREDICATE: contained-tag < tag children>> not ;
 PREDICATE: open-tag < tag children>> ;
+
+UNION: xml-data
+    tag comment string directive instruction ;

basis/xml/interpolate/interpolate.factor

@@ -30,7 +30,8 @@ DEFER: interpolate-sequence
 
 GENERIC: push-item ( item -- )
 M: string push-item , ;
-M: object push-item , ;
+M: xml-data push-item , ;
+M: object push-item present , ;
 M: sequence push-item
     [ dup array? [ % ] [ , ] if ] each ;