HTTPD cleanups, working on help responder

TODO.FACTOR.txt

@@ -1,4 +1,3 @@
-- FUNCTION: not updating crossref correctly
 - need line and paragraph spacing
 - update HTML stream
 - help cross-referencing
@@ -10,12 +9,8 @@
   - alien calls
   - port ffi to win64
 - intrinsic char-slot set-char-slot for x86
-- closing ui does not stop timers
-- adding/removing timers automatically for animated gadgets
-- saving image with UI open
 - fix up the min thumb size hack
 - the invalid recursion form case needs to be fixed, for inlines too
-- what about tasks and timers between image restarts
 - code walker & exceptions
 - signal handler should not lose stack pointers
 - FIELD: char key_vector[32];

contrib/cont-responder/todo-example.factor

@@ -27,6 +27,7 @@
 ! list of things to do. All data is stored in a directory in the 
 ! filesystem with the users name.
 IN: todo-example
+USING: xml ;
 USE: cont-responder
 USE: html
 USE: io

contrib/httpd/browser-responder.factor

@@ -25,8 +25,8 @@
 ! cont-responder facilities.
 !
 IN: browser-responder
-USING: html cont-responder hashtables kernel io namespaces words lists prettyprint 
+USING: cont-responder hashtables help html io kernel lists
-       memory sequences ;
+memory namespaces prettyprint sequences words xml ;
 
 : option ( current text -- )
   #! Output the HTML option tag for the given text. If
@@ -56,13 +56,7 @@ USING: html cont-responder hashtables kernel io namespaces words lists prettypri
 
 : word-source ( vocab word -- )
   #! Write the source for the given word from the vocab as HTML.
-  swap lookup [
+  swap lookup [ [ help ] with-html-stream ] when* ;
-    [ see ] with-simple-html-output
-  ] when* ;
-
-: vm-statistics ( -- )
-  #! Display statistics about the vm.
-  <pre> room. </pre> ;
 
 : browser-body ( vocab word -- )
   #! Write out the HTML for the body of the main browser page.
@@ -70,15 +64,14 @@ USING: html cont-responder hashtables kernel io namespaces words lists prettypri
     <tr>  
       <td> <b> "Vocabularies" write </b> </td>
       <td> <b> "Words" write </b> </td>
-      <td> <b> "Source" write </b> </td>
+      <td> <b> "Documentation" write </b> </td>
     </tr>
     <tr>  
       <td "top" =valign "width: 200" =style td> over vocab-list </td> 
       <td "top" =valign "width: 200" =style td> 2dup word-list </td> 
       <td "top" =valign td> word-source </td> 
     </tr>
-  </table>
+  </table> ;
-  vm-statistics ;
 
 : browser-title ( vocab word -- )
   #! Output the HTML title for the browser.

contrib/httpd/default-responders.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: httpd
-USING: browser-responder cont-responder file-responder kernel
+USING: browser-responder cont-responder file-responder
-namespaces prettyprint ;
+help-responder kernel namespaces prettyprint ;
 
 #! Remove all existing responders, and create a blank
 #! responder table.
@@ -14,6 +14,12 @@ global [
         "404" "responder" set
         [ drop no-such-responder ] "get" set
     ] make-responder
+
+    ! Online help browsing
+    [
+        "help" "responder" set
+        [ help-responder ] "get" set
+    ] make-responder
     
     ! Servers Factor word definitions from the image.
     "browser" [ browser-responder ] install-cont-responder

contrib/httpd/help-responder.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: help-responder
+USING: help html kernel sequences ;
+
+: help-responder ( filename -- )
+    dup empty? [ drop "handbook" ] when
+    dup article-title
+    [ [ (help) ] with-html-stream ] html-document ;

contrib/httpd/html.factor

@@ -1,38 +1,25 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: html
-USING: generic hashtables http io kernel lists math namespaces
+USING: generic hashtables help http io kernel lists math
-sequences strings styles words ;
+namespaces sequences strings styles words xml ;
-
-: html-entities ( -- alist )
-    H{
-        { CHAR: < "&lt;"   }
-        { CHAR: > "&gt;"   }
-        { CHAR: & "&amp;"  }
-        { CHAR: ' "&apos;" }
-        { CHAR: " "&quot;" }
-    } ;
-
-: chars>entities ( str -- str )
-    #! Convert <, >, &, ' and " to HTML entities.
-    [
-        [ dup html-entities hash [ % ] [ , ] ?if ] each
-    ] "" make ;
 
 : hex-color, ( triplet -- )
     3 swap head [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
 
-: fg-css, ( color -- )
+: fg-css, ( color -- ) "color: #" % hex-color, "; " % ;
-    "color: #" % hex-color, "; " % ;
+
+: bg-css, ( color -- ) "background-color: #" % hex-color, "; " % ;
 
 : style-css, ( flag -- )
-    dup [ italic bold-italic ] member?
+    dup
+    { italic bold-italic } member?
     [ "font-style: italic; " % ] when
-    [ bold bold-italic ] member?
+    { bold bold-italic } member?
     [ "font-weight: bold; " % ] when ;
 
 : size-css, ( size -- )
-    "font-size: " % # "; " % ;
+    "font-size: " % # "pt; " % ;
 
 : font-css, ( font -- )
     "font-family: " % % "; " % ;
@@ -47,10 +34,11 @@ sequences strings styles words ;
         swap rot hash dup [ call ] [ 2drop ] if
     ] hash-each-with ;
 
-: css-style ( style -- )
+: span-css-style ( style -- str )
     [
         H{
             { foreground  [ fg-css,        ] }
+            { background  [ bg-css,        ] }
             { font        [ font-css,      ] }
             { font-style  [ style-css,     ] }
             { font-size   [ size-css,      ] }
@@ -58,12 +46,30 @@ sequences strings styles words ;
     ] "" make ;
 
 : span-tag ( style quot -- )
-    over css-style dup "" = [
+    over span-css-style dup empty? [
         drop call
     ] [
         <span =style span> call </span>
     ] if ;
 
+: div-css-style ( style -- str )
+    drop "" ;
+    ! [
+    !     H{
+    !         { foreground  [ fg-css,        ] }
+    !         { font        [ font-css,      ] }
+    !         { font-style  [ style-css,     ] }
+    !         { font-size   [ size-css,      ] }
+    !     } hash-apply
+    ! ] "" make ;
+
+: div-tag ( style quot -- )
+    over div-css-style dup empty? [
+        drop call
+    ] [
+        <div =style div> call </div>
+    ] if ;
+
 : resolve-file-link ( path -- link )
     #! The file responder needs relative links not absolute
     #! links.
@@ -81,22 +87,30 @@ sequences strings styles words ;
         call
     ] if* ;
 
-: browser-link-href ( word -- href )
+GENERIC: browser-link-href ( presented -- href )
-    dup word-name swap word-vocabulary
+
-    [
+M: word browser-link-href
+    dup word-name swap word-vocabulary [
         "/responder/browser/?vocab=" %
         url-encode %
         "&word=" %
         url-encode %
     ] "" make ;
 
-: browser-link-tag ( style quot -- style )
+M: link browser-link-href
-    over presented swap hash dup word? [
+    link-name [ \ f ] unless* dup word? [
-        <a browser-link-href =href a> call </a>
+        browser-link-href
     ] [
-        drop call
+        [ "/responder/help/" % url-encode % ] "" make
     ] if ;
 
+M: object browser-link-href
+    drop f ;
+
+: browser-link-tag ( style quot -- style )
+    presented pick hash browser-link-href
+    [ <a =href a> call </a> ] [ call ] if* ;
+
 TUPLE: wrapper-stream scope ;
 
 C: wrapper-stream ( stream -- stream )
@@ -107,12 +121,19 @@ C: wrapper-stream ( stream -- stream )
 : with-wrapper ( stream quot -- )
     >r wrapper-stream-scope r> bind ; inline
 
+TUPLE: nested-stream ;
+
+C: nested-stream [ set-delegate ] keep ;
+
+M: nested-stream stream-close drop ;
+
 TUPLE: html-stream ;
 
 M: html-stream stream-write1 ( char stream -- )
-    [
+    >r ch>string r> stream-write ;
-        dup html-entities hash [ write ] [ write1 ] ?if
+
-    ] with-wrapper ;
+M: html-stream stream-write ( char stream -- )
+    [ chars>entities write ] with-wrapper ;
 
 M: html-stream stream-format ( str style stream -- )
     [
@@ -123,6 +144,23 @@ M: html-stream stream-format ( str style stream -- )
         ] browser-link-tag
     ] with-wrapper ;
 
+: pre-tag ( stream style quot -- )
+    wrap-margin rot hash [
+        call
+    ] [
+        over [ [ <pre> ] with-wrapper call ] keep
+        [ </pre> ] with-wrapper
+    ] if ;
+
+M: html-stream with-nested-stream ( quot style stream -- )
+    swap [
+        [ <nested-stream> swap with-stream ] pre-tag
+    ] div-tag ;
+
+M: html-stream stream-terpri [ <br/> ] with-wrapper ;
+
+M: html-stream stream-terpri* [ <br/> ] with-wrapper ;
+
 C: html-stream ( stream -- stream )
     #! Wraps the given stream in an HTML stream. An HTML stream
     #! converts special characters to entities when being

contrib/httpd/load.factor

@@ -2,6 +2,7 @@ IN: scratchpad
 USING: words kernel parser sequences io compiler ;
 
 { 
+    "xml"
     "http-common"
     "mime"
     "html-tags"
@@ -9,6 +10,7 @@ USING: words kernel parser sequences io compiler ;
     "responder"
     "httpd"
     "file-responder"
+    "help-responder"
     "cont-responder"
     "browser-responder"
     "default-responders"

contrib/httpd/test/html.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: html io kernel namespaces styles test ;
+USING: html io kernel namespaces styles test xml ;
 
 [
     "<html>&'sgml'"
@@ -32,7 +32,7 @@ USING: html io kernel namespaces styles test ;
 [
     [
         "car"
-        H{ { font "Monospaced" } }
+        H{ { font "monospace" } }
         html-format
     ] string-out
 ] unit-test

contrib/httpd/xml.factor

@@ -1,5 +1,6 @@
-USING: kernel math infix parser namespaces sequences strings prettyprint
+USING: kernel math parser namespaces sequences strings
-    errors lists hashtables vectors html io generic words ;
+prettyprint errors lists hashtables vectors io generic
+words ;
 IN: xml
 
 ! * Simple SAX-ish parser
@@ -124,12 +125,18 @@ M: xml-string-error error.
     ] if ;
 
 : entities
+    #! We have both directions here as a shortcut.
     H{
-        [[ "lt" CHAR: < ]]
+        { "lt" CHAR: < }
-        [[ "gt" CHAR: > ]]
+        { "gt" CHAR: > }
-        [[ "amp" CHAR: & ]]
+        { "amp" CHAR: & }
-        [[ "apos" CHAR: ' ]]
+        { "apos" CHAR: ' }
-        [[ "quot" CHAR: " ]]
+        { "quot" CHAR: " }
+        { CHAR: < "&lt;"   }
+        { CHAR: > "&gt;"   }
+        { CHAR: & "&amp;"  }
+        { CHAR: ' "&apos;" }
+        { CHAR: " "&quot;" }
     } ;
 
 : parse-entity ( -- ch )
@@ -334,21 +341,13 @@ M: closer process
 
 GENERIC: (xml>string) ( object -- )
 
-: reverse-entities ! not as many as entities needed for printing
+: chars>entities ( str -- str )
-    H{
+    #! Convert <, >, &, ' and " to HTML entities.
-        { CHAR: & "amp" }
-        { CHAR: < "lt" }
-        { CHAR: " "quot" }
-    } ;
-
-M: string (xml>string)
     [
-        dup reverse-entities hash [
+        [ dup entities hash [ % ] [ , ] ?if ] each
-            CHAR: & , % CHAR: ; ,
+    ] "" make ;
-        ] [
+
-            ,
+M: string (xml>string) chars>entities % ;
-        ] ?if
-    ] each ;
 
 : print-open/close ( tag -- )
     CHAR: > ,

library/bootstrap/boot-stage1.factor

@@ -171,6 +171,7 @@ vectors words ;
         "/library/freetype/freetype.factor"
         "/library/freetype/freetype-gl.factor"
 
+        "/library/ui/timers.factor"
         "/library/ui/gadgets.factor"
         "/library/ui/layouts.factor"
         "/library/ui/hierarchy.factor"
@@ -332,9 +333,6 @@ vocabularies get [
 
 "!syntax" vocabularies get remove-hash
 
-H{ } clone crossref set
-recrossref
-
 "Building generic words..." print flush
 
 all-words [ generic? ] subset [ make-generic ] each

library/bootstrap/boot-stage2.factor

@@ -43,6 +43,10 @@ sequences sequences-internals words ;
     0 exit
 ] set-boot
 
+"Building cross-referencing database..." print
+H{ } clone crossref set
+recrossref
+
 [ compiled? ] word-subset length
 number>string write " compiled words" print
 

library/freetype/freetype-gl.factor

@@ -54,18 +54,18 @@ M: font = eq? ;
 
 : ttf-name ( font style -- name )
     cons H{
-        { [[ "Monospaced" plain       ]] "VeraMono" }
+        { [[ "monospace" plain        ]] "VeraMono" }
-        { [[ "Monospaced" bold        ]] "VeraMoBd" }
+        { [[ "monospace" bold         ]] "VeraMoBd" }
-        { [[ "Monospaced" bold-italic ]] "VeraMoBI" }
+        { [[ "monospace" bold-italic  ]] "VeraMoBI" }
-        { [[ "Monospaced" italic      ]] "VeraMoIt" }
+        { [[ "monospace" italic       ]] "VeraMoIt" }
-        { [[ "Sans Serif" plain       ]] "Vera"     }
+        { [[ "sans-serif" plain       ]] "Vera"     }
-        { [[ "Sans Serif" bold        ]] "VeraBd"   }
+        { [[ "sans-serif" bold        ]] "VeraBd"   }
-        { [[ "Sans Serif" bold-italic ]] "VeraBI"   }
+        { [[ "sans-serif" bold-italic ]] "VeraBI"   }
-        { [[ "Sans Serif" italic      ]] "VeraIt"   }
+        { [[ "sans-serif" italic      ]] "VeraIt"   }
-        { [[ "Serif" plain            ]] "VeraSe"   }
+        { [[ "serif" plain            ]] "VeraSe"   }
-        { [[ "Serif" bold             ]] "VeraSeBd" }
+        { [[ "serif" bold             ]] "VeraSeBd" }
-        { [[ "Serif" bold-italic      ]] "VeraBI"   }
+        { [[ "serif" bold-italic      ]] "VeraBI"   }
-        { [[ "Serif" italic           ]] "VeraIt"   }
+        { [[ "serif" italic           ]] "VeraIt"   }
     } hash ;
 
 : ttf-path ( name -- string )

library/help/markup.factor

@@ -87,8 +87,7 @@ M: simple-element print-element [ print-element ] each ;
 : $synopsis ( content -- )
     first dup
     word-vocabulary [ "Vocabulary" $subheading $snippet ] when*
-    dup parsing? [ $syntax ] [ $stack-effect ] if
+    dup parsing? [ $syntax ] [ $stack-effect ] if ;
-    terpri* ;
 
 : $description ( content -- )
     "Description" $subheading print-element ;
@@ -110,9 +109,7 @@ M: simple-element print-element [ print-element ] each ;
     [ "," format* bl ] interleave ; inline
 
 : $see ( content -- )
-    terpri*
+    code-style [ [ first see ] with-nesting* ] with-style ;
-    code-style [ [ first see ] with-nesting* ] with-style
-    terpri* ;
 
 : $example ( content -- )
     first2 swap dup <input>

library/help/stylesheet.factor

@@ -3,7 +3,7 @@ USING: styles ;
 
 : default-style
     H{
-        { font "Sans Serif" }
+        { font "sans-serif" }
         { font-size 12 }
         { wrap-margin 500 }
     } ;
@@ -14,22 +14,22 @@ USING: styles ;
 : emphasis-style
     H{ { font-style italic } } ;
 
-: heading-style H{ { font "Serif" } { font-size 16 } } ;
+: heading-style H{ { font "serif" } { font-size 16 } } ;
 
-: subheading-style H{ { font "Serif" } { font-style bold } } ;
+: subheading-style H{ { font "serif" } { font-style bold } } ;
 
 : subsection-style
-    H{ { font "Serif" } { font-size 14 } { font-style bold } } ;
+    H{ { font "serif" } { font-size 14 } { font-style bold } } ;
 
 : snippet-style
     H{
-        { font "Monospaced" }
+        { font "monospace" }
         { foreground { 0.3 0.3 0.3 1 } }
     } ;
 
 : code-style
     H{
-        { font "Monospaced" }
+        { font "monospace" }
         { page-color { 0.9 0.9 1 0.5 } }
         { border-width 5 }
         { wrap-margin f }
@@ -40,7 +40,7 @@ USING: styles ;
 
 : url-style
     H{
-        { font "Monospaced" }
+        { font "monospace" }
         { foreground { 0.0 0.0 1.0 1.0 } }
     } ;
 

library/syntax/prettyprint.factor

@@ -54,7 +54,7 @@ C: section ( length -- section )
         last-newline set
         line-limit? [ "..." write end-printing get continue ] when
         line-count inc
-        "\n" write do-indent
+        terpri do-indent
     ] if ;
 
 TUPLE: text string style ;

library/threads.factor

@@ -42,48 +42,8 @@ DEFER: next-thread
         try stop
     ] callcc0 drop ;
 
-TUPLE: timer object delay last ;
-
-: timer-now millis swap set-timer-last ;
-
-C: timer ( object delay -- timer )
-    [ set-timer-delay ] keep
-    [ set-timer-object ] keep
-    dup timer-now ;
-
-GENERIC: tick ( ms object -- )
-
-: timers ( -- hash ) \ timers global hash ;
-
-: add-timer ( object delay -- )
-    over >r <timer> r> timers set-hash ;
-
-: remove-timer ( object -- ) timers remove-hash ;
-
-: restart-timer ( object -- )
-    timers hash [ timer-now ] when* ;
-
-: next-time ( timer -- ms ) dup timer-delay swap timer-last + ;
-
-: advance-timer ( ms timer -- delay )
-    #! Outputs the time since the last firing.
-    [ timer-last - 0 max ] 2keep set-timer-last ;
-
-: do-timer ( ms timer -- )
-    #! Takes current time, and a timer. If the timer is set to
-    #! fire, calls its callback.
-    dup next-time pick <= [
-        [ advance-timer ] keep timer-object tick
-    ] [
-        2drop
-    ] if ;
-
-: do-timers ( -- )
-    millis timers hash-values [ do-timer ] each-with ;
-
 : init-threads ( -- )
     global [
         <queue> \ run-queue set
         V{ } clone \ sleep-queue set
-        H{ } clone \ timers set
     ] bind ;

library/ui/presentations.factor

@@ -29,7 +29,7 @@ M: gadget-stream stream-write1 ( char stream -- )
     background [ <solid> over set-gadget-interior ] apply-style ;
 
 : specified-font ( style -- font )
-    [ font swap hash [ "Monospaced" ] unless* ] keep
+    [ font swap hash [ "monospace" ] unless* ] keep
     [ font-style swap hash [ plain ] unless* ] keep
     font-size swap hash [ 12 ] unless* 3array ;
 

library/ui/theme.factor

@@ -76,13 +76,13 @@ USING: arrays gadgets kernel sequences styles ;
 
 : label-theme ( label -- )
     { 0.0 0.0 0.0 1.0 } over set-label-color
-    { "Monospaced" plain 12 } swap set-label-font ;
+    { "monospace" plain 12 } swap set-label-font ;
 
 : editor-theme ( label -- )
     { 0.0 0.0 0.0 1.0 } over set-label-color
-    { "Monospaced" bold 12 } swap set-label-font ;
+    { "monospace" bold 12 } swap set-label-font ;
 
 : status-theme ( label -- )
     dup reverse-video-theme
     { 1.0 1.0 1.0 1.0 } over set-label-color
-    { "Monospaced" plain 12 } swap set-label-font ;
+    { "monospace" plain 12 } swap set-label-font ;

library/ui/timers.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets
+USING: hashtables kernel math sequences ;
+
+TUPLE: timer object delay last ;
+
+: timer-now millis swap set-timer-last ;
+
+C: timer ( object delay -- timer )
+    [ set-timer-delay ] keep
+    [ set-timer-object ] keep
+    dup timer-now ;
+
+GENERIC: tick ( ms object -- )
+
+DEFER: timers
+
+: add-timer ( object delay -- )
+    over >r <timer> r> timers set-hash ;
+
+: remove-timer ( object -- ) timers remove-hash ;
+
+: restart-timer ( object -- )
+    timers hash [ timer-now ] when* ;
+
+: next-time ( timer -- ms ) dup timer-delay swap timer-last + ;
+
+: advance-timer ( ms timer -- delay )
+    [ timer-last - 0 max ] 2keep set-timer-last ;
+
+: do-timer ( ms timer -- )
+    dup next-time pick <= [
+        [ advance-timer ] keep timer-object tick
+    ] [
+        2drop
+    ] if ;
+
+: do-timers ( -- )
+    millis timers hash-values [ do-timer ] each-with ;

library/ui/ui.factor

@@ -21,16 +21,10 @@ global [ first-time on ] bind
         ] when
     ] bind ;
 
-: check-running
-    world get [
-        world-running?
-        [ "The UI is already running" throw ] when
-    ] when* ;
-
 IN: shells
 
 : ui ( -- )
-    check-running [
+    [
         init-world world get rect-dim first2
         [ listener-application run-world ] with-gl-screen
     ] with-freetype ;

library/ui/world.factor

@@ -9,13 +9,17 @@ sequences sequences strings styles threads ;
 ! gadgets are contained in. The current world is stored in the
 ! world variable. The invalid slot is a list of gadgets that
 ! need to be layout.
-TUPLE: world running? glass status invalid ;
+TUPLE: world running? glass status invalid timers ;
+
+: timers ( -- hash ) world get world-timers ;
 
 : add-layer ( gadget -- )
     world get add-gadget ;
 
 C: world ( -- world )
-    <stack> over set-delegate t over set-gadget-root? ;
+    <stack> over set-delegate
+    t over set-gadget-root?
+    H{ } clone over set-world-timers ;
 
 : add-invalid ( gadget -- )
     world get [ world-invalid cons ] keep set-world-invalid ;