html stream generates css

TODO.FACTOR.txt

@@ -1,15 +1,11 @@
-- fedit broken with listener
-- maple-like: press enter at old commands to evaluate there
-- add a socket timeout
-- balance needs USE:
-- html: order of attrs should not matter
-
 + docs:
 
 - unparse examples
 - review doc formatting with latex2html
 - recursion -vs- iteration in vectors chapter
-
+- objects chapter covering namespaces, hashtables, equality and
+  object identity.
+ =
 + tests:
 
 - java factor: equal numbers have non-equal hashcodes!
@@ -19,6 +15,9 @@
 
 + listener/plugin:
 
+- balance needs USE:
+- fedit broken with listener
+- maple-like: press enter at old commands to evaluate there
 - make inferior.factor nicer to use
 - input style after clicking link
 - plugin should not exit jEdit on fatal errors
@@ -31,6 +30,7 @@
 
 + native:
 
+- add a socket timeout
 - read1
 - telnetd and httpd should use multitasking
 - read# and eof
@@ -61,6 +61,7 @@
 
 + misc:
 
+- ifte* and keep combinators
 - 'cascading' styles
 - jedit ==> jedit-word, jedit takes a file name
 - some way to run httpd from command line
@@ -79,6 +80,9 @@
 - file responder:
   - port to native
   - if a directory is requested and URL does not end with /, redirect
+- wiki responder:
+  - port to native
+  - text styles
 - if user clicks stop in browser, doesn't stop sending?
 - log with date
 - return more header fields, like Content-Length, Last-Modified, and so on

library/combinators.factor

@@ -61,6 +61,11 @@ USE: stack
     #! This combinator will not compile.
     dup dip forever ; interpret-only
 
+: keep ( a quot -- a )
+    #! Execute the quotation with a on the stack, and restore a
+    #! after the quotation returns.
+    over >r call r> ;
+
 : cond ( x list -- )
     #! The list is of this form:
     #!

library/httpd/html.factor

@@ -71,33 +71,42 @@ USE: url-encoding
 : link-tag ( string link -- string )
     url-encode "a" swap link-attrs html-tag ;
 
-: bold-tag ( string -- string )
-    "b" f html-tag ;
-
-: italics-tag ( string -- string )
-    "i" f html-tag ;
-
-: underline-tag ( string -- string )
-    "u" f html-tag ;
-
 : >hex-color ( triplet -- hex )
     [ >hex 2 digits ] inject "#" swons cat ;
 
-: fg-tag ( string color -- string )
+: fg-css% ( color -- )
-    "font" swap "color=\"" swap >hex-color "\"" cat3 html-tag ;
+    "color: " % >hex-color % "; " % ;
 
-: size-tag ( string size -- string )
+: bold-css% ( flag -- )
-    "font" swap "size=\"" swap "\"" cat3 html-tag ;
+    [ "font-weight: bold; " % ] when ;
+
+: italics-css% ( flag -- )
+    [ "font-style: italic; " % ] when ;
+
+: underline-css% ( flag -- )
+    [ "text-decoration: underline; " % ] when ;
+
+: size-css% ( size -- )
+    "font-size: " % unparse % "; " % ;
+
+: font-css% ( font -- )
+    "font-family: " % % "; " % ;
+
+: css-style% ( style -- )
+    [
+        [ "fg"        fg-css% ]
+        [ "bold"      bold-css% ]
+        [ "italics"   italics-css% ]
+        [ "underline" underline-css% ]
+        [ "size"      size-css% ]
+        [ "font"      font-css% ]
+    ] assoc-apply ;
+
+: span-tag ( string style -- string )
+    "span" swap <% "style=\"" % css-style% "\"" % %> html-tag ;
 
 : html-attr-string ( string style -- string )
-    [
+    [ span-tag ] keep "link" swap assoc [ link-tag ] when* ;
-        [ "fg"        fg-tag ]
-        [ "bold"      drop bold-tag ]
-        [ "italics"   drop italics-tag ]
-        [ "underline" drop underline-tag ]
-        [ "size"      size-tag ]
-        [ "link"      link-tag ]
-    ] assoc-apply ;
 
 : html-write-attr ( string style -- )
     swap chars>entities swap html-attr-string write ;
@@ -112,8 +121,10 @@ USE: url-encoding
     #! fg - an rgb triplet in a list
     #! bg - an rgb triplet in a list
     #! bold
-    #! italic
+    #! italics
     #! underline
+    #! size
+    #! link - an object path
     <extend-stream> [
         [ chars>entities write ] "fwrite" set
         [ chars>entities print ] "fprint" set

library/test/httpd/html.factor

@@ -15,23 +15,9 @@ USE: test
     "Hello world" f html-attr-string
 ] unit-test
 
-[ "<b>Hello world</b>" ]
+[ "<span style=\"color: #ff00ff; font-family: Monospaced; \">car</span>" ]
 [
-    "Hello world"
+    "car"
-    [ [ "bold" | t ] ]
+    [ [ "fg" 255 0 255 ] [ "font" | "Monospaced" ] ]
-    html-attr-string
+    span-tag
-] unit-test
-
-[ "<i>Hello world</i>" ]
-[
-    "Hello world"
-    [ [ "italics" | t ] ]
-    html-attr-string
-] unit-test
-
-[ "<font color=\"#ff00ff\">Hello world</font>" ]
-[
-    "Hello world"
-    [ [ "fg" 255 0 255 ] ]
-    html-attr-string
 ] unit-test

library/test/test.factor

@@ -94,6 +94,14 @@ USE: unparser
         test
     ] each
     
+    native? [
+        [
+            "threads"
+        ] [
+            test
+        ] each
+    ] when
+
     java? [
         [
             "lists/java"

library/vocabularies.factor

@@ -80,6 +80,7 @@ USE: strings
         "errors"
         "debugger"
         "hashtables"
+        "inferior"
         "inspector"
         "interpreter"
         "jedit"