steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

HTTPD cleanups, working on help responder

cvs
Slava Pestov 2006-01-20 06:26:50 +00:00
parent 978b3edc47
commit cb378cd2c0
21 changed files with 197 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
TODO.FACTOR.txt
View File

@ -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];

1
contrib/cont-responder/todo-example.factor
View File

@ -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

17
contrib/httpd/browser-responder.factor
View File

@ -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.
<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.
@ -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>
vm-statistics ;
</table> ;
: browser-title ( vocab word -- )
#! Output the HTML title for the browser.

10
contrib/httpd/default-responders.factor
View File

@ -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.
@ -15,6 +15,12 @@ global [
[ 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

9
contrib/httpd/help-responder.factor Normal file
View File

@ -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 ;

106
contrib/httpd/html.factor
View File

@ -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: < "&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 ;
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
] [
<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 )
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 )
@ -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 [ [ <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

2
contrib/httpd/load.factor
View File

@ -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"

4
contrib/httpd/test/html.factor
View File

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

41
contrib/httpd/xml.factor
View File

@ -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: < "&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
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: > ,

4
library/bootstrap/boot-stage1.factor
View File

@ -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

4
library/bootstrap/boot-stage2.factor
View File

@ -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

24
library/freetype/freetype-gl.factor
View File

@ -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 )

7
library/help/markup.factor
View File

@ -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 <input>

14
library/help/stylesheet.factor
View File

@ -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 } }
} ;

2
library/syntax/prettyprint.factor
View File

@ -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 ;

40
library/threads.factor
View File

@ -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 ;

2
library/ui/presentations.factor
View File

@ -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 ;

6
library/ui/theme.factor
View File

@ -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 ;

40
library/ui/timers.factor Normal file
View File

@ -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 ;

8
library/ui/ui.factor
View File

@ -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 ;

8
library/ui/world.factor
View File

@ -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 ;