-- FUNCTION: not updating crossref correctly\r
- need line and paragraph spacing\r
- update HTML stream\r
- help cross-referencing\r
- alien calls\r
- port ffi to win64\r
- intrinsic char-slot set-char-slot for x86\r
-- closing ui does not stop timers\r
-- adding/removing timers automatically for animated gadgets\r
-- saving image with UI open\r
- fix up the min thumb size hack\r
- the invalid recursion form case needs to be fixed, for inlines too\r
-- what about tasks and timers between image restarts\r
- code walker & exceptions\r
- signal handler should not lose stack pointers\r
- FIELD: char key_vector[32];\r
! 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
! 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
: 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.
- <pre> room. </pre> ;
+ swap lookup [ [ help ] with-html-stream ] when* ;
: browser-body ( vocab word -- )
#! Write out the HTML for the body of the main browser page.
<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>
- vm-statistics ;
+ </table> ;
: browser-title ( vocab word -- )
#! Output the HTML title for the browser.
! 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.
"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
--- /dev/null
+! 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 ;
! 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: " % % "; " % ;
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, ] }
] "" 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.
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? [
- <a browser-link-href =href a> call </a>
+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
+ [ <a =href a> call </a> ] [ call ] if* ;
+
TUPLE: wrapper-stream scope ;
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 -- )
[
] 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
USING: words kernel parser sequences io compiler ;
{
+ "xml"
"http-common"
"mime"
"html-tags"
"responder"
"httpd"
"file-responder"
+ "help-responder"
"cont-responder"
"browser-responder"
"default-responders"
IN: temporary
-USING: html io kernel namespaces styles test ;
+USING: html io kernel namespaces styles test xml ;
[
"<html>&'sgml'"
[
[
"car"
- H{ { font "Monospaced" } }
+ H{ { font "monospace" } }
html-format
] string-out
] unit-test
-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
] 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 )
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: > ,
"/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"
"!syntax" vocabularies get remove-hash
-H{ } clone crossref set
-recrossref
-
"Building generic words..." print flush
all-words [ generic? ] subset [ make-generic ] each
0 exit\r
] set-boot\r
\r
+"Building cross-referencing database..." print\r
+H{ } clone crossref set\r
+recrossref\r
+\r
[ compiled? ] word-subset length\r
number>string write " compiled words" print\r
\r
: 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 )
: $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 ;
[ "," 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 <input>
: default-style
H{
- { font "Sans Serif" }
+ { font "sans-serif" }
{ font-size 12 }
{ wrap-margin 500 }
} ;
: 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 }
: url-style
H{
- { font "Monospaced" }
+ { font "monospace" }
{ foreground { 0.0 0.0 1.0 1.0 } }
} ;
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 ;
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 ;
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 ;
: 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 ;
--- /dev/null
+! 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 ;
] 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 ;
! 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 ;
projects / factor.git / commitdiff