Convert HTML streams to use inheritance and new accessors, fix a bug

extra/html/streams/streams-tests.factor

@@ -1,6 +1,6 @@
 USING: html.streams html.streams.private
 io io.streams.string io.styles kernel
-namespaces tools.test xml.writer sbufs sequences ;
+namespaces tools.test xml.writer sbufs sequences inspector ;
 IN: html.streams.tests
 
 : make-html-string
@@ -70,3 +70,5 @@ M: funky browser-link-href
 ] [
     [ H{ } [ ] with-nesting nl ] make-html-string
 ] unit-test
+
+[ ] [ [ { 1 2 3 } describe ] with-html-stream ] unit-test

extra/html/streams/streams.factor

@@ -1,50 +1,44 @@
-! Copyright (C) 2004, 2006 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: generic assocs help http io io.styles io.files continuations
 io.streams.string kernel math math.order math.parser namespaces
 quotations assocs sequences strings words html.elements
-xml.entities sbufs continuations destructors ;
+xml.entities sbufs continuations destructors accessors ;
 IN: html.streams
 
 GENERIC: browser-link-href ( presented -- href )
 
 M: object browser-link-href drop f ;
 
-TUPLE: html-stream last-div? ;
+TUPLE: html-stream stream last-div ;
 
-! A hack: stream-nl after with-nesting or tabular-output is
+! stream-nl after with-nesting or tabular-output is
-! ignored, so that HTML stream output looks like UI pane output
+! ignored, so that HTML stream output looks like
-: test-last-div? ( stream -- ? )
+! UI pane output
-    dup html-stream-last-div?
+: last-div? ( stream -- ? )
-    f rot set-html-stream-last-div? ;
+    [ f ] change-last-div drop ;
 
 : not-a-div ( stream -- stream )
-    dup test-last-div? drop ; inline
+    f >>last-div ; inline
 
 : a-div ( stream -- straem )
-    t over set-html-stream-last-div? ; inline
+    t >>last-div ; inline
 
 : <html-stream> ( stream -- stream )
-    html-stream construct-delegate ;
+    f html-stream boa ;
 
 <PRIVATE
 
-TUPLE: html-sub-stream style stream ;
+TUPLE: html-sub-stream < html-stream style parent ;
 
-: (html-sub-stream) ( style stream -- stream )
+: new-html-sub-stream ( style stream class -- stream )
-    html-sub-stream boa
+    new
-    512 <sbuf> <html-stream> over set-delegate ;
+        512 <sbuf> >>stream
-
+        swap >>parent
-: <html-sub-stream> ( style stream class -- stream )
+        swap >>style ; inline
-    >r (html-sub-stream) r> construct-delegate ; inline
 
 : end-sub-stream ( substream -- string style stream )
-    dup delegate >string
+    [ stream>> >string ] [ style>> ] [ parent>> ] tri ;
-    over html-sub-stream-style
-    rot html-sub-stream-stream ;
-
-: delegate-write ( string -- )
-    output-stream get delegate stream-write ;
 
 : object-link-tag ( style quot -- )
     presented pick at [
@@ -99,11 +93,11 @@ TUPLE: html-sub-stream style stream ;
     ] if ; inline
 
 : format-html-span ( string style stream -- )
-    [
+    stream>> [
-        [ [ drop delegate-write ] span-tag ] object-link-tag
+        [ [ drop write ] span-tag ] object-link-tag
     ] with-output-stream* ;
 
-TUPLE: html-span-stream ;
+TUPLE: html-span-stream < html-sub-stream ;
 
 M: html-span-stream dispose
     end-sub-stream not-a-div format-html-span ;
@@ -132,11 +126,11 @@ M: html-span-stream dispose
     ] if ; inline
 
 : format-html-div ( string style stream -- )
-    [
+    stream>> [
-        [ [ delegate-write ] div-tag ] object-link-tag
+        [ [ write ] div-tag ] object-link-tag
     ] with-output-stream* ;
 
-TUPLE: html-block-stream ;
+TUPLE: html-block-stream < html-sub-stream ;
 
 M: html-block-stream dispose ( quot style stream -- )
     end-sub-stream a-div format-html-div ;
@@ -159,38 +153,43 @@ M: html-block-stream dispose ( quot style stream -- )
 PRIVATE>
 
 ! Stream protocol
-M: html-stream stream-write1 ( char stream -- )
+M: html-stream stream-flush
+    stream>> stream-flush ;
+
+M: html-stream stream-write1
     >r 1string r> stream-write ;
 
-M: html-stream stream-write ( str stream -- )
+M: html-stream stream-write
-    not-a-div >r escape-string r> delegate stream-write ;
+    not-a-div >r escape-string r> stream>> stream-write ;
 
-M: html-stream make-span-stream ( style stream -- stream' )
+M: html-stream stream-format
-    html-span-stream <html-sub-stream> ;
-
-M: html-stream stream-format ( str style stream -- )
     >r html over at [ >r escape-string r> ] unless r>
     format-html-span ;
 
-M: html-stream make-block-stream ( style stream -- stream' )
+M: html-stream stream-nl
-    html-block-stream <html-sub-stream> ;
+    dup last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
 
-M: html-stream stream-write-table ( grid style stream -- )
+M: html-stream make-span-stream
-    a-div [
+    html-span-stream new-html-sub-stream ;
+
+M: html-stream make-block-stream
+    html-block-stream new-html-sub-stream ;
+
+M: html-stream make-cell-stream
+    html-sub-stream new-html-sub-stream ;
+
+M: html-stream stream-write-table
+    a-div stream>> [
         <table dup table-attrs table> swap [
             <tr> [
                 <td "top" =valign swap table-style =style td>
-                    >string write-html
+                    stream>> >string write
                 </td>
             ] with each </tr>
         ] with each </table>
     ] with-output-stream* ;
 
-M: html-stream make-cell-stream ( style stream -- stream' )
+M: html-stream dispose stream>> dispose ;
-    (html-sub-stream) ;
-
-M: html-stream stream-nl ( stream -- )
-    dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
 
 : with-html-stream ( quot -- )
     output-stream get <html-stream> swap with-output-stream* ; inline