diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index f7d1f4f08f..34c769db9a 100644 --- a/TODO.FACTOR.txt +++ b/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]; diff --git a/contrib/cont-responder/todo-example.factor b/contrib/cont-responder/todo-example.factor index 442249e2da..4476e668c8 100644 --- a/contrib/cont-responder/todo-example.factor +++ b/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 diff --git a/contrib/httpd/browser-responder.factor b/contrib/httpd/browser-responder.factor index 4d6d89a350..d3fc96ba5d 100644 --- a/contrib/httpd/browser-responder.factor +++ b/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 - memory sequences ; +USING: cont-responder hashtables help html io kernel lists +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 [ - [ see ] with-simple-html-output - ] when* ; - -: vm-statistics ( -- ) - #! Display statistics about the vm. - 
 room.
; + swap lookup [ [ help ] with-html-stream ] when* ; : 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 "Vocabularies" write "Words" write - "Source" write + "Documentation" write over vocab-list 2dup word-list word-source - - vm-statistics ; + ; : browser-title ( vocab word -- ) #! Output the HTML title for the browser. diff --git a/contrib/httpd/default-responders.factor b/contrib/httpd/default-responders.factor index aa995af38d..8c5a05ea61 100644 --- a/contrib/httpd/default-responders.factor +++ b/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 -namespaces prettyprint ; +USING: browser-responder cont-responder file-responder +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 diff --git a/contrib/httpd/help-responder.factor b/contrib/httpd/help-responder.factor new file mode 100644 index 0000000000..1430c30458 --- /dev/null +++ b/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 ; diff --git a/contrib/httpd/html.factor b/contrib/httpd/html.factor index 3a137f81a2..330bcbf3c9 100644 --- a/contrib/httpd/html.factor +++ b/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 -sequences strings styles words ; - -: html-entities ( -- alist ) - H{ - { CHAR: < "<" } - { CHAR: > ">" } - { CHAR: & "&" } - { CHAR: ' "'" } - { CHAR: " """ } - } ; - -: chars>entities ( str -- str ) - #! Convert <, >, &, ' and " to HTML entities. - [ - [ dup html-entities hash [ % ] [ , ] ?if ] each - ] "" make ; +USING: generic hashtables help http io kernel lists math +namespaces sequences strings styles words xml ; : hex-color, ( triplet -- ) 3 swap head [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ; -: fg-css, ( color -- ) - "color: #" % hex-color, "; " % ; +: fg-css, ( 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 ] [ call ] 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 + ] [ +
call
+ ] 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 ) - dup word-name swap word-vocabulary - [ +GENERIC: browser-link-href ( presented -- href ) + +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 ) - over presented swap hash dup word? [ - call +M: link browser-link-href + link-name [ \ f ] unless* dup word? [ + 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 + [ call ] [ 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 -- ) - [ - dup html-entities hash [ write ] [ write1 ] ?if - ] with-wrapper ; + >r ch>string r> stream-write ; + +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 [ [ 
 ] with-wrapper call ] keep
+        [
] with-wrapper + ] if ; + +M: html-stream with-nested-stream ( quot style stream -- ) + swap [ + [ swap with-stream ] pre-tag + ] div-tag ; + +M: html-stream stream-terpri [
] with-wrapper ; + +M: html-stream stream-terpri* [
] 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 diff --git a/contrib/httpd/load.factor b/contrib/httpd/load.factor index e46a6dc4a6..623438cea3 100644 --- a/contrib/httpd/load.factor +++ b/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" diff --git a/contrib/httpd/test/html.factor b/contrib/httpd/test/html.factor index 2fa0f3d109..ea85c5ef80 100644 --- a/contrib/httpd/test/html.factor +++ b/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 diff --git a/contrib/httpd/xml.factor b/contrib/httpd/xml.factor index c3e528029e..0c11914b01 100644 --- a/contrib/httpd/xml.factor +++ b/contrib/httpd/xml.factor @@ -1,5 +1,6 @@ -USING: kernel math infix parser namespaces sequences strings prettyprint - errors lists hashtables vectors html io generic words ; +USING: kernel math parser namespaces sequences strings +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: < ]] - [[ "gt" CHAR: > ]] - [[ "amp" CHAR: & ]] - [[ "apos" CHAR: ' ]] - [[ "quot" CHAR: " ]] + { "lt" CHAR: < } + { "gt" CHAR: > } + { "amp" CHAR: & } + { "apos" CHAR: ' } + { "quot" CHAR: " } + { CHAR: < "<" } + { CHAR: > ">" } + { CHAR: & "&" } + { CHAR: ' "'" } + { CHAR: " """ } } ; : parse-entity ( -- ch ) @@ -334,21 +341,13 @@ M: closer process GENERIC: (xml>string) ( object -- ) -: reverse-entities ! not as many as entities needed for printing - H{ - { CHAR: & "amp" } - { CHAR: < "lt" } - { CHAR: " "quot" } - } ; - -M: string (xml>string) +: chars>entities ( str -- str ) + #! Convert <, >, &, ' and " to HTML entities. [ - dup reverse-entities hash [ - CHAR: & , % CHAR: ; , - ] [ - , - ] ?if - ] each ; + [ dup entities hash [ % ] [ , ] ?if ] each + ] "" make ; + +M: string (xml>string) chars>entities % ; : print-open/close ( tag -- ) CHAR: > , diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 90a0e95818..cb4331a400 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/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 diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index b9ff813427..d4bdc1a5e3 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/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 diff --git a/library/freetype/freetype-gl.factor b/library/freetype/freetype-gl.factor index dc701b99c6..45e3011610 100644 --- a/library/freetype/freetype-gl.factor +++ b/library/freetype/freetype-gl.factor @@ -54,18 +54,18 @@ M: font = eq? ; : ttf-name ( font style -- name ) cons H{ - { [[ "Monospaced" plain ]] "VeraMono" } - { [[ "Monospaced" bold ]] "VeraMoBd" } - { [[ "Monospaced" bold-italic ]] "VeraMoBI" } - { [[ "Monospaced" italic ]] "VeraMoIt" } - { [[ "Sans Serif" plain ]] "Vera" } - { [[ "Sans Serif" bold ]] "VeraBd" } - { [[ "Sans Serif" bold-italic ]] "VeraBI" } - { [[ "Sans Serif" italic ]] "VeraIt" } - { [[ "Serif" plain ]] "VeraSe" } - { [[ "Serif" bold ]] "VeraSeBd" } - { [[ "Serif" bold-italic ]] "VeraBI" } - { [[ "Serif" italic ]] "VeraIt" } + { [[ "monospace" plain ]] "VeraMono" } + { [[ "monospace" bold ]] "VeraMoBd" } + { [[ "monospace" bold-italic ]] "VeraMoBI" } + { [[ "monospace" italic ]] "VeraMoIt" } + { [[ "sans-serif" plain ]] "Vera" } + { [[ "sans-serif" bold ]] "VeraBd" } + { [[ "sans-serif" bold-italic ]] "VeraBI" } + { [[ "sans-serif" italic ]] "VeraIt" } + { [[ "serif" plain ]] "VeraSe" } + { [[ "serif" bold ]] "VeraSeBd" } + { [[ "serif" bold-italic ]] "VeraBI" } + { [[ "serif" italic ]] "VeraIt" } } hash ; : ttf-path ( name -- string ) diff --git a/library/help/markup.factor b/library/help/markup.factor index 83f0cad2ea..5106fbf6bd 100644 --- a/library/help/markup.factor +++ b/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 - terpri* ; + dup parsing? [ $syntax ] [ $stack-effect ] if ; : $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 - terpri* ; + code-style [ [ first see ] with-nesting* ] with-style ; : $example ( content -- ) first2 swap dup diff --git a/library/help/stylesheet.factor b/library/help/stylesheet.factor index e57f1d5544..f438b61b54 100644 --- a/library/help/stylesheet.factor +++ b/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 } } } ; diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index e4d3edc461..93420453d1 100644 --- a/library/syntax/prettyprint.factor +++ b/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 ; diff --git a/library/threads.factor b/library/threads.factor index e3dd092842..2bb70a83ee 100644 --- a/library/threads.factor +++ b/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 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 [ \ run-queue set V{ } clone \ sleep-queue set - H{ } clone \ timers set ] bind ; diff --git a/library/ui/presentations.factor b/library/ui/presentations.factor index 3bef897684..d7025b371a 100644 --- a/library/ui/presentations.factor +++ b/library/ui/presentations.factor @@ -29,7 +29,7 @@ M: gadget-stream stream-write1 ( char stream -- ) background [ 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 ; diff --git a/library/ui/theme.factor b/library/ui/theme.factor index ed44d7117e..7a539f11d5 100644 --- a/library/ui/theme.factor +++ b/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 ; diff --git a/library/ui/timers.factor b/library/ui/timers.factor new file mode 100644 index 0000000000..cba33e0961 --- /dev/null +++ b/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 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 ; diff --git a/library/ui/ui.factor b/library/ui/ui.factor index fb80d5c90d..757ddeed3a 100644 --- a/library/ui/ui.factor +++ b/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 ; diff --git a/library/ui/world.factor b/library/ui/world.factor index e1d2a6254f..2ae83eac18 100644 --- a/library/ui/world.factor +++ b/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 ) - over set-delegate t over set-gadget-root? ; + 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 ;