Markup fixes for better HTML generation

contrib/httpd/browser-responder.factor

@@ -54,14 +54,13 @@ prettyprint sequences words xml ;
         </tr>
     </table> ;
 
-: browser-title ( -- )
+: browser-title ( -- str )
     current-word
     [ synopsis ] [ "IN: " current-vocab append ] if* ;
 
 : browser-responder ( -- )
     #! Display a Smalltalk like browser for exploring words.
-    serving-html browser-title dup [
+    serving-html browser-title [
-        <h1> write </h1>
         <form "main" =name "" =action "get" =method form>
             browser-body
         </form>

contrib/httpd/html.factor

@@ -18,9 +18,9 @@ IN: html
 : style-css, ( flag -- )
     dup
     { italic bold-italic } member?
-    [ "font-style: italic; " % ] when
+    "font-style: " % "italic" "normal" ? % ";" %
     { bold bold-italic } member?
-    [ "font-weight: bold; " % ] when ;
+    "font-weight: " % "bold" "normal" ? % ";" % ;
 
 : size-css, ( size -- )
     "font-size: " % # "pt; " % ;
@@ -133,21 +133,22 @@ M: html-stream stream-write1 ( char stream -- )
 M: html-stream stream-write ( str stream -- )
     >r chars>entities r> delegate-write ;
 
+: with-html-style ( quot style stream -- )
+    [ [ swap span-tag ] object-link-tag ] with-stream* ; inline
+
+M: html-stream with-stream-style ( quot style stream -- )
+    [ drop call ] -rot with-html-style ;
+
 M: html-stream stream-format ( str style stream -- )
-    [
+    [ do-escaping stdio get delegate-write ] -rot
-        [
+    with-html-style ;
-            [
-                do-escaping stdio get delegate-write
-            ] span-tag
-        ] object-link-tag
-    ] with-stream* ;
 
 : with-html-stream ( quot -- )
     stdio get <html-stream> swap with-stream* ;
 
 : make-outliner-quot
     [
-        <div "padding-left:10px;" =style div>
+        <div "padding-left:20px;" =style div>
             with-html-stream
         </div>
     ] curry ;
@@ -175,7 +176,7 @@ M: html-stream with-stream-table ( grid quot style stream -- )
     [
         <table> rot [
             <tr> [
-                <td>
+                <td "top" =valign td>
                 pick pick stdio get with-nested-stream </td>
             ] each </tr>
         ] each 2drop </table>
@@ -188,7 +189,7 @@ M: html-stream stream-terpri [ <br/> ] with-stream* ;
     "A:link { text-decoration: none; color: black; }" print
     "A:visited { text-decoration: none; color: black; }" print
     "A:active { text-decoration: none; color: black; }" print
-    "A:hover, A:hover { text-decoration: none; color: black; }" print
+    "A:hover, A:hover { text-decoration: underline; color: black; }" print
   </style> ;
 
 : xhtml-preamble

library/collections/growable.facts

@@ -4,7 +4,7 @@ USING: help kernel sequences ;
 HELP: set-fill "( n seq -- )"
 { $values { "n" "a new fill pointer" } { "seq" "a growable sequence" } }
 { $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a growable sequence." }
-{ $side-effects "Modifies " { $snippet "seq" } "." }
+{ $side-effects "seq" }
 { $warning "This word is in the " { $snippet "sequences-internals" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ;
 
 HELP: underlying "( seq -- underlying )"

library/help/crossref.factor

@@ -61,9 +61,11 @@ DEFER: $subsection
     where dup empty? [
         drop
     ] [
+        [
             where-style [
-            [ "Parent topics: " write $links ] ($block)
+                "Parent topics: " write $links
             ] with-style
+        ] ($block)
     ] if ;
 
 : xref-article ( article -- )

library/help/help.factor

@@ -18,24 +18,19 @@ M: word article-content
         ] ?if
     ] { } make ;
 
-: with-default-style ( quot -- )
+: $title ( article -- )
-    default-style [
+    title-style [
-        H{ } [ last-block on call ] with-nesting
+        title-style [
-    ] with-style ; inline
+            dup [ article-title write ] ($block) $where
+        ] with-nesting
+    ] with-style terpri ;
 
-: print-title ( article -- )
+: (help) ( topic -- ) article-content print-content ;
-    [ dup article-title $title $where ] with-default-style
-    terpri ;
 
-: print-content ( element -- )
+: help ( topic -- ) dup $title (help) terpri ;
-    [ print-element ] with-default-style ;
-
-: (help) ( topic -- ) article-content print-content terpri ;
-
-: help ( topic -- ) dup print-title (help) ;
 
 : see-help ( word -- )
-    dup help [ $definition terpri ] with-default-style ;
+    dup help [ terpri $definition terpri ] with-default-style ;
 
 : handbook ( -- ) "handbook" help ;
 

library/help/markup.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: help
 USING: arrays generic hashtables inspector io kernel namespaces
 parser prettyprint sequences strings styles vectors words ;
+IN: help
 
 ! Simple markup language.
 
@@ -12,45 +12,69 @@ parser prettyprint sequences strings styles vectors words ;
 
 ! Element types are words whose name begins with $.
 
+SYMBOL: last-element
+SYMBOL: span
+SYMBOL: block
+SYMBOL: table
+
+: last-span? last-element get span eq? ;
+: last-block? last-element get block eq? ;
+
+: ($span) ( quot -- )
+    last-block? [ terpri ] when
+    span last-element set
+    call ; inline
+
 PREDICATE: array simple-element
     dup empty? [ drop t ] [ first word? not ] if ;
 
 M: simple-element print-element [ print-element ] each ;
-M: string print-element last-block off write ;
+M: string print-element [ write ] ($span) ;
 M: array print-element unclip execute ;
 M: word print-element { } swap execute ;
 
-: ($span) ( content style -- )
+: print-element* ( element style -- )
-    last-block off [ print-element ] with-style ;
+    [ print-element ] with-style ;
 
-: ?terpri ( -- )
+: with-default-style ( quot -- )
-    last-block [ [ terpri ] unless t ] change ;
+    default-style [
+        last-element off
+        H{ } swap with-nesting
+    ] with-style ; inline
+
+: print-content ( element -- )
+    last-element off
+    [ print-element ] with-default-style ;
 
 : ($block) ( quot -- )
-    ?terpri
+    last-element get { f table } member? [ terpri ] unless
+    span last-element set
     call
-    terpri
+    block last-element set ; inline
-    last-block on ; inline
 
 ! Some spans
 
-: $snippet snippet-style ($span) ;
+: $snippet [ snippet-style print-element* ] ($span) ;
 
-: $emphasis emphasis-style ($span) ;
+: $emphasis [ emphasis-style print-element* ] ($span) ;
 
-: $url url-style ($span) ;
+: $url [ url-style print-element* ] ($span) ;
 
-: $terpri last-block off terpri terpri drop ;
+: $terpri terpri terpri drop ;
 
 ! Some blocks
-: $title [ title-style ($span) ] ($block) ;
+: ($heading)
+    last-element get [ terpri ] when ($block) ; inline
 
-: $heading [ heading-style ($span) ] ($block) ;
+: $heading
+    [ heading-style print-element* ] ($heading) ;
 
 : ($code) ( presentation quot -- )
     [
         code-style [
-            >r presented associate r> with-nesting
+            last-element off
+            >r presented associate code-style hash-union r>
+            with-nesting
         ] with-style
     ] ($block) ; inline
 
@@ -82,9 +106,10 @@ M: word print-element { } swap execute ;
 : $warning ( content -- )
     [
         warning-style [
+            last-element off
             "Warning" $heading print-element
         ] with-nesting
-    ] ($block) ;
+    ] ($heading) ;
 
 ! Some links
 TUPLE: link name ;
@@ -102,23 +127,26 @@ M: link summary "Link: " swap link-name append ;
     ] with-style ;
 
 : $link ( article -- )
-    last-block off first link-style
+    first link-style [
-    [ dup article-title swap >link write-object ] with-style ;
+        dup article-title swap >link write-object
+    ] with-style ;
 
 : textual-list ( seq quot -- )
     [ ", " print-element ] interleave ; inline
 
 : $links ( content -- )
-    [ 1array $link ] textual-list ;
+    [ [ 1array $link ] textual-list ] ($span) ;
 
 : $see-also ( content -- )
     "See also" $heading $links ;
 
 : $table ( content -- )
-    ?terpri table-style [
+    [
-        H{ { table-padding 5 } { table-gap { 5 5 0 } } }
+        table-style [
+            H{ { table-gap { 5 5 0 } } }
             [ print-element ] tabular-output
-    ] with-style ;
+        ] with-style
+    ] ($block) table last-element set ;
 
 : $values ( content -- )
     "Arguments and values" $heading
@@ -144,11 +172,13 @@ M: link summary "Link: " swap link-name append ;
 : $notes ( content -- )
     "Notes" $heading print-element ;
 
-: $see ( content -- )
+: ($see) ( word -- )
-    code-style [ H{ } [ first see ] with-nesting ] with-style ;
+    code-style [ code-style [ see ] with-nesting ] with-style ;
+
+: $see ( content -- ) first ($see) ;
 
 : $definition ( content -- )
-    "Definition" $heading $see ;
+    "Definition" $heading ($see) ;
 
 : $curious ( content -- )
     "For the curious..." $heading print-element ;

library/help/stylesheet.factor

@@ -5,7 +5,7 @@ USING: styles ;
 
 : default-style
     H{
-        { font "serif" }
+        { font "sans-serif" }
         { font-size 12 }
         { wrap-margin 500 }
     } ;
@@ -18,20 +18,19 @@ USING: styles ;
 
 : title-style
     H{
-        { font "serif" }
+        { font "sans-serif" }
         { font-size 16 }
         { font-style bold }
+        { wrap-margin 500 }
+        { page-color { 0.8 0.8 1 1 } }
+        { border-width 5 }
     } ;
 
 : where-style
-    H{
+    H{ { font-size 10 } } ;
-        { font "serif" }
-        { font-size 10 }
-    } ;
 
 : heading-style
     H{
-        { font "serif" }
         { font-size 14 }
         { font-style bold }
         { foreground { 0.2 0.2 0.4 1 } }
@@ -39,7 +38,6 @@ USING: styles ;
 
 : subsection-style
     H{
-        { font "serif" }
         { font-size 14 }
         { font-style bold }
     } ;
@@ -56,7 +54,7 @@ USING: styles ;
 : code-style
     H{
         { font "monospace" }
-        { page-color { 0.9 0.9 1 0.5 } }
+        { page-color { 0.8 0.8 0.8 0.5 } }
         { border-width 5 }
         { wrap-margin f }
     } ;

library/help/topics.factor

@@ -25,5 +25,3 @@ M: string article-content article article-content ;
 ! Special case: f help
 M: f article-title drop \ f article-title ;
 M: f article-content drop \ f article-content ;
-
-SYMBOL: last-block

library/io/duplex-stream.factor

@@ -46,6 +46,9 @@ M: duplex-stream stream-terpri
 M: duplex-stream stream-format
     duplex-stream-out+ stream-format ;
 
+M: duplex-stream with-stream-style
+    duplex-stream-out+ with-stream-style ;
+
 M: duplex-stream with-nested-stream
     duplex-stream-out+ with-nested-stream ;
 

library/io/nested-style.factor

@@ -5,18 +5,14 @@ USING: arrays generic hashtables kernel namespaces strings ;
 
 TUPLE: nested-style-stream style ;
 
-: with-style ( style quot -- )
+: (with-stream-style) ( quot style stream -- )
-    >r stdio get <nested-style-stream> r> with-stream* ; inline
+    <nested-style-stream> swap with-stream* ; inline
 
 : do-nested-style ( style stream -- style delegate )
     [ nested-style-stream-style swap hash-union ] keep
     delegate ;
 
-: collapse-nested-style ( style delegate -- style delegate )
-    dup nested-style-stream? [ do-nested-style ] when ;
-
 C: nested-style-stream ( style delegate -- stream )
-    >r collapse-nested-style r>
     [ set-delegate ] keep
     [ set-nested-style-stream-style ] keep ;
 
@@ -35,6 +31,9 @@ M: nested-style-stream stream-write1
     3array >quotation
     r> r> do-nested-style ;
 
+M: nested-style-stream with-stream-style ( quot style stream -- )
+    do-nested-style with-stream-style ;
+
 M: nested-style-stream with-nested-stream
     do-nested-quot with-nested-stream ;
 

library/io/plain-stream.factor

@@ -16,3 +16,6 @@ M: plain-writer stream-format ( string style stream -- )
 
 M: plain-writer with-nested-stream ( quot style stream -- )
     nip swap with-stream* ;
+
+M: plain-writer with-stream-style ( quot style stream -- )
+    (with-stream-style) ;

library/io/stdio.factor

@@ -26,6 +26,9 @@ SYMBOL: stdio
 : tabular-output ( grid style quot -- )
     swap stdio get with-stream-table ;
 
+: with-style ( style quot -- )
+    swap stdio get with-stream-style ;
+
 : print ( string -- ) stdio get stream-print ;
 
 : with-stream* ( stream quot -- )

library/io/stream.factor

@@ -16,6 +16,7 @@ GENERIC: stream-terpri ( stream -- )
 GENERIC: stream-format ( string style stream -- )
 GENERIC: with-nested-stream ( quot style stream -- )
 GENERIC: with-stream-table ( grid quot style stream -- )
+GENERIC: with-stream-style ( quot style stream -- )
 
 : stream-print ( string stream -- )
     [ stream-write ] keep stream-terpri ;

library/io/styles.factor

@@ -27,7 +27,6 @@ SYMBOL: outline
 
 ! Table styles
 SYMBOL: table-gap
-SYMBOL: table-padding
 
 ! Input history
 TUPLE: input string ;

library/ui/gadgets/panes.factor

@@ -130,6 +130,9 @@ M: pane stream-format ( string style pane -- )
 
 M: pane stream-close ( pane -- ) drop ;
 
+M: pane with-stream-style ( quot style pane -- )
+    (with-stream-style) ;
+
 : ?terpri
     dup pane-current gadget-children empty?
     [ dup stream-terpri ] unless drop ;

library/ui/gadgets/presentations.factor

@@ -91,8 +91,7 @@ M: object-button gadget-help ( button -- string )
 
 : styled-grid ( style grid -- )
     <grid>
-    table-gap pick hash [ { 0 0 0 } ] unless* over set-grid-gap
+    table-gap rot hash [ { 0 0 0 } ] unless* over set-grid-gap ;
-    table-padding rot hash [ 0 ] unless* <border> ;
 
 : <pane-grid> ( quot style grid -- gadget )
     [