cont-html is essentially rewritten to not use a quotation between the

opening and closing tags. This actually simplifies the code quite a bit.
The current downside is the the code using the tags is not pretty
printed very well (ie. no indenting).
cvs
Chris Double 2004-08-02 21:35:22 +00:00
parent 62c349a356
commit 4a562eb0c9
9 changed files with 288 additions and 340 deletions

View File

@ -55,7 +55,7 @@ USE: errors
: write-vocab-list ( -- )
#! Write out the HTML for the list of vocabularies
<select name= "vocabs" style= "width: 200" size= "20" onchange= "document.forms.main.submit()" select> [
<select name= "vocabs" style= "width: 200" size= "20" onchange= "document.forms.main.submit()" select>
vocabs [
dup "current-vocab" get [ "" ] unless* = [
"<option selected>" write
@ -65,11 +65,11 @@ USE: errors
chars>entities write
"</option>\n" write
] each
] </select> ;
</select> ;
: write-word-list ( vocab -- )
#! Write out the HTML for the list of words in a vocabulary.
<select name= "words" style= "width: 200" size= "20" onchange= "document.forms.main.submit()" select> [
<select name= "words" style= "width: 200" size= "20" onchange= "document.forms.main.submit()" select>
words [
dup "current-word" get [ "" ] unless* str-compare 0 = [
"<option selected>" write
@ -79,15 +79,15 @@ USE: errors
chars>entities write
"</option>\n" write
] each
] </select> ;
</select> ;
: write-editable-word-source ( vocab word -- )
#! Write the source in a manner allowing it to be edited.
<textarea name= "eval" rows= "30" cols= "80" textarea> [
<textarea name= "eval" rows= "30" cols= "80" textarea>
1024 <string-output-stream> dup >r [
>r words r> swap [ over swap dup word-name rot = [ see ] [ drop ] ifte ] each drop
] with-stream r> stream>str chars>entities write
] </textarea> <br/>
</textarea> <br/>
"Accept" button ;
: write-word-source ( vocab word -- )
@ -115,27 +115,31 @@ USE: errors
: write-vm-statistics ( -- )
#! Display statistics about the JVM in use.
<table> [
<tr> [ <td> [ "Free Memory" write ] </td>
<td> [ get-vm-runtime get-free-memory write ] </td> ] </tr>
<tr> [ <td> [ "Total Memory" write ] </td>
<td> [ get-vm-runtime get-total-memory write ] </td> ] </tr>
] </table> ;
<table>
<tr>
<td> "Free Memory" write </td>
<td> get-vm-runtime get-free-memory write </td>
</tr>
<tr>
<td> "Total Memory" write </td>
<td> get-vm-runtime get-total-memory write </td>
</tr>
</table> ;
: write-browser-body ( -- )
#! Write out the HTML for the body of the main browser page.
<table width= "100%" table> [
<tr> [
<td> [ "<b>Vocabularies</b>" write ] </td>
<td> [ "<b>Words</b>" write ] </td>
<td> [ "<b>Source</b>" write ] </td>
] </tr>
<tr> [
<td valign= "top" style= "width: 200" td> [ write-vocab-list ] </td>
<td valign= "top" style= "width: 200" td> [ "current-vocab" get write-word-list ] </td>
<td valign= "top" td> [ "current-vocab" get "current-word" get write-word-source ] </td>
] </tr>
] </table>
<table width= "100%" table>
<tr>
<td> "<b>Vocabularies</b>" write </td>
<td> "<b>Words</b>" write </td>
<td> "<b>Source</b>" write </td>
</tr>
<tr>
<td valign= "top" style= "width: 200" td> write-vocab-list </td>
<td valign= "top" style= "width: 200" td> "current-vocab" get write-word-list </td>
<td valign= "top" td> "current-vocab" get "current-word" get write-word-source </td>
</tr>
</table>
write-vm-statistics ;
: flatten ( tree - list )
@ -179,13 +183,13 @@ USE: errors
: show-parse-error ( error -- )
#! Show an error page describing the parse error.
[
<html> [
<head> [ <title> [ "Parse error" write ] </title> ] </head>
<body> [
<html>
<head> <title> "Parse error" write </title> </head>
<body>
swap [ write ] with-simple-html-output
<a href= a> [ "Ok" write ] </a>
] </body>
] </html>
<a href= a> "Ok" write </a>
</body>
</html>
] show drop drop ;
: eval-string ( vocab to-eval -- )
@ -204,16 +208,16 @@ USE: errors
[
[
[
<html> [
<head> [
<title> [ "Factor Browser" write ] </title>
] </head>
<body> [
<form name= "main" action= method= "post" form> [
<html>
<head>
<title> "Factor Browser" write </title>
</head>
<body>
<form name= "main" action= method= "post" form>
write-browser-body
] </form>
] </body>
] </html>
</form>
</body>
</html>
] show [
"allow-edit?" get [
"eval" get [

View File

@ -39,7 +39,7 @@ USE: prettyprint
#! The page has a link to the 'next' continuation.
[
swap [
<a href= a> [ "Next" write ] </a>
<a href= a> "Next" write </a>
] html-document
] show drop drop ;
@ -47,11 +47,11 @@ USE: prettyprint
#! Display a page prompting for input of a name and return that name.
[
"Enter your name" [
<form method= "post" action= form> [
<form method= "post" action= form>
"Name: " write
<input type= "text" name= "name" size= "20" input/>
<input type= "submit" value= "Ok" input/>
] </form>
</form>
] html-document
] show [
"name" get
@ -75,10 +75,10 @@ USE: prettyprint
[
drop
"Menu" [
<ol> [
<li> [ "Test responder1" [ test-cont-responder ] quot-href ] </li>
<li> [ "Test responder2" [ [ .s ] with-string-stream display-page test-cont-responder2 [ .s ] with-string-stream display-page ] quot-href ] </li>
] </ol>
<ol>
<li> "Test responder1" [ test-cont-responder ] quot-href </li>
<li> "Test responder2" [ [ .s ] with-string-stream display-page test-cont-responder2 [ .s ] with-string-stream display-page ] quot-href </li>
</ol>
] html-document
] show drop ;
@ -91,7 +91,7 @@ USE: prettyprint
#! And we don't need the 'url' argument
drop
"Counter: " over cat2 [
dup <h2> [ write ] </h2>
dup <h2> write </h2>
"++" over unit [ f ] swap append [ 1 + counter-example ] append quot-href
"--" over unit [ f ] swap append [ 1 - counter-example ] append quot-href
drop
@ -104,25 +104,16 @@ USE: prettyprint
#!
0 "counter" set
[
#! And we don't need the 'url' argument
#! We don't need the 'url' argument
drop
"Counter: " "counter" get cat2 [
<h2> [ "counter" get write ] </h2>
<h2> "counter" get write </h2>
"++" [ "counter" get 1 + "counter" set ] quot-href
"--" [ "counter" get 1 - "counter" set ] quot-href
] html-document
] show
drop ;
!: register-counter-example2 ( -- id )
! #! Register the counter-example word so that accessing the
! #! URL with the returned ID will call it.
! "httpd-responders" get [
! "cont" get [
! f [ counter-example2 ] register-continuation
! ] bind
! ] bind ;
#! Install the examples
"counter1" [ drop 0 counter-example ] install-cont-responder
"counter2" [ drop counter-example2 ] install-cont-responder

View File

@ -1,4 +1,4 @@
! cont-html v0.5
! cont-html v0.6
!
! Copyright (C) 2004 Chris Double.
!
@ -41,224 +41,160 @@ USE: logic
! HTML tags can be used in a number of different ways. The highest
! level involves a similar syntax to HTML:
!
! <p> [ "someoutput" write ] </p>
! <p> "someoutput" write </p>
!
! <p> will push the tag on the stack and </p> will call the
! quotation wrapping the output in the tag with no attributes.
! <p> will outupt the opening tag and </p> will output the closing
! tag with no attributes.
!
! <p class= "red" p> [ "someoutput" write ] </p>
! <p class= "red" p> "someoutput" write </p>
!
! This time the opening tag does not have the '>'. It pushes
! the tag on the stack with a boolean at the top for indicating no
! prior attribute value. The next word is assumed to be an attribute
! word. These words are the attribute name followed by '='.
! They set any previous attributes in tbe word and set in the tag
! the current attribute to be processed.
! Immediately after the attribute word should come the value
! that that attribute will be set to.
! The next attribute word or finishing word (which is the
! html word followed by '>') will actually set the attribute to
! that value in the tag.
! The remaining words are a quotation and the closing tag which
! calls the quotation and displays the attributed HTML tag around
! its output.
! a namespace on the stack to hold the attributes and values.
! Any attribute words used will store the attribute and values
! in that namespace. After the attribute word should come the
! value of that attribute. The next attribute word or
! finishing word (which is the html word followed by '>')
! will actually set the attribute to that value in the namespace.
! The finishing word will print out the operning tag including
! attributes.
! Any writes after this will appear after the opening tag.
!
! The opening tag words push the tag onto the namespace stack
! so values for attributes can be used directly without any stack
! Values for attributes can be used directly without any stack
! operations:
!
! (url -- )
! <a href= a> [ "Click me" write ] </a>
! <a href= a> "Click me" write </a>
!
! (url -- )
! <a href= "http://" swap cat2 a> [ "click" write ] </a>
! <a href= "http://" swap cat2 a> "click" write </a>
!
! (url -- )
! <a href= <% "http://" % % %> a> [ "click" write ] </a>
! <a href= <% "http://" % % %> a> "click" write </a>
!
! Tags that have no 'closing' equivalent have a trailing tag/> form:
!
! <input type= "text" name= "name" size= "20" input/>
: <tag> ( closed? name -- <tag> )
#! Return a <tag> object which describes the named
#! HTML tag. closed? should be true false if the
#! tag does not need have a closing tag printed
#! (eg. <br>, <input>). 'attrs' contains a
#! namespace of name/values for the attributes.
<namespace> [
"tag" set
"closed?" set
"attrs" <namespace> put
"last-name" f put
] extend ;
: set-attr ( value name <tag> -- )
#! Set the attribute of the <tag> to the given value.
[ "attrs" get [ set ] bind ] bind ;
: attribute-assign ( <tag> name value -- <tag> )
#! If value is not false then set the attribute in the
#! tag, otherwise do nothing (ie. just drop the false values).
2dup and [ swap pick set-attr ] [ 2drop ] ifte ;
: attrs>string ( namespace -- string )
#! Convert the attrs namespace to a string
: attrs>string ( alist -- string )
#! Convert the attrs alist to a string
#! suitable for embedding in an html tag.
[
vars-values
<% [ dup car % "='" % cdr % "' " % ] each %>
] bind ;
nreverse <% [ dup car % "='" % cdr % "'" % ] each %> ;
: write-open-tag ( <tag> -- )
#! Write to standard output the opening HTML tag plus
#! attributes if any.
[
"<" write
"tag" get write
"attrs" get [ " " write attrs>string write ] when*
">" write
] bind ;
: write-attributes ( n: namespace -- )
#! With the attribute namespace on the stack, get the attributes
#! and write them to standard output. If no attributes exist, write
#! nothing.
"attrs" get [ " " write attrs>string write ] when* ;
: write-close-tag ( <tag> -- )
#! Write to standard output the closing HTML tag if
#! the tag requires it.
[
"closed?" get [
"</" write
"tag" get write
">" write
] when
] bind ;
: write-tag ( <tag> quot -- )
#! Call the quotation, wrapping any output to standard
#! output within the given HTML tag.
over write-open-tag dip write-close-tag ;
: store-prev-attribute ( n: tag value -- )
#! Assumes an attribute namespace is on the stack.
#! Gets the previous attribute that was used (if any)
#! and sets it's value to the current value on the stack.
#! If there is no previous attribute, no value is expected
#! on the stack.
"current-attribute" get [ swons "attrs" cons@ ] when* ;
! HTML tag words
!
! Each closable HTML tag has four words defined. The example below is for
! <p>:
!
!: <p> ( -- <tag> )
! #! Pushes the HTML tag on the stack
! t "p" <tag> ;
!: <p> ( -- )
! #! Writes the opening tag to standard output.
! "<p>" write ;
!: <p ( -- n: <namespace> )
! #! Used for setting inline attributes. Prints out
! #! an unclosed opening tag.
! "<p" write <namespace> >n ;
!
!: <p ( -- attr-value n: <tag> )
! #! Used for setting inline attributes.
! t "p" <tag> >n f ;
!
!: p> ( n: <tag> last-value -- <tag> )
!: p> ( n: <namespace> -- )
! #! Used to close off inline attribute version of word.
! "last-name" get n> -rot swap attribute-assign ;
! #! Prints out attributes and closes opening tag.
! store-prev-attribute write-attributes n> drop ">" write ;
!
!: </p> ( <tag> quot -- )
! #! Calls the quotation, wrapping the output in the tag.
! write-tag ;
!: </p> ( -- )
! #! Write out the closing tag.
! "</foo>" write ;
!
! Each open only HTML tag has only three words:
!
! : <input/> ( -- )
! #! Used for printing the tag with no attributes.
! f "input" <tag> [ ] write-tag ;
! "<input>" write ;
!
! : <input ( -- n: <tag> attr-value )
! : <input ( -- n: <namespace> )
! #! Used for setting inline attributes.
! f "input" <tag> >n f ;
! "<input" write <namespace> >n ;
!
! : input/> ( n: <tag> value or f -- )
! : input/> ( n: <namespace> -- )
! #! Used to close off inline attribute version of word
! #! and print the tag/
! "last-name" get n> -rot swap attribute-assign [ ] write-tag ;
! store-prev-attribute write-attributes n> drop ">" write ;
!
! Each attribute word has the form xxxx= where 'xxxx' is the attribute
! name. The example below is for href:
!
!: href= ( n: <tag> value or f -- n: <tag> )
! "last-name" get n> -rot swap attribute-assign >n "href" "last-name" set ;
!: href= ( n: <namespace> optional-value -- )
! store-prev-attribute "href" "current-attribute" set ;
: define-compound ( vocab name def -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
>r 2dup swap create r> <compound> define ;
: def-for-html-word-<foo> ( name -- name quot )
#! Return the name and code for the <foo> patterned
#! word.
<% "<" % % ">" % %> dup [ write ] cons ;
: closed-html-word-names ( name -- )
#! Return a list of the names of the words
#! used for a closable HTML tag.
dup [ "<" swap ">" cat3 ] dip
dup [ "<" swap cat2 ] dip
dup [ ">" cat2 ] dip
"</" swap ">" cat3
3list cons ;
: def-for-html-word-<foo ( name -- name quot )
#! Return the name and code for the <foo patterned
#! word.
<% "<" % % %> dup [ write <namespace> >n ] cons ;
: closed-html-word-code ( name -- )
#! Return a list of the code for the words
#! used for the closable HTML tag.
dup [ <tag> ] cons t swons
swap [ <tag> >n f ] cons t swons
[ "last-name" get n> -rot swap attribute-assign ]
[ write-tag ]
3list cons ;
: def-for-html-word-foo> ( name -- name quot )
#! Return the name and code for the foo> patterned
#! word.
<% % ">" % %> [ store-prev-attribute write-attributes n> drop ">" write ] ;
: 2car>pair ( list1 list2 -- cdr cdr pair )
#! Take the car of two lists and put then in a
#! pair. The cdr of the two lists remain on the
#! stack.
>r uncons swap r> uncons -rot cons ;
: def-for-html-word-</foo> ( name -- name quot )
#! Return the name and code for the </foo> patterned
#! word.
<% "</" % % ">" % %> dup [ write ] cons ;
: def-for-html-word-<foo/> ( name -- name quot )
#! Return the name and code for the <foo/> patterned
#! word.
<% "<" % dup % "/>" % %> swap <% "<" % % ">" % %> [ write ] cons ;
: def-for-html-word-foo/> ( name -- name quot )
#! Return the name and code for the foo/> patterned
#! word.
<% % "/>" % %> [ store-prev-attribute write-attributes n> drop ">" write ] ;
: 2list>alist ( list1 list2 alist -- alist )
#! Append two lists to an alist by
#! taking the car of each list and
#! forming it into a pair recursively.
>r dup [
2car>pair r> swap add 2list>alist
] [
drop drop r>
] ifte ;
: define-closed-html-word ( name -- )
#! Given an HTML tag name, define the words for
#! that closable HTML tag.
dup closed-html-word-names
swap closed-html-word-code
[ ] 2list>alist
[ uncons "cont-html" -rot define-compound ] each ;
: open-html-word-names ( name -- )
#! Return a list of the names of the words
#! used for a open only HTML tag.
dup [ "<" swap "/>" cat3 ] dip
dup [ "<" swap cat2 ] dip
"/>" cat2
2list cons ;
: open-html-word-code ( name -- )
#! Return a list of the code for the words
#! used for the open only HTML tag.
dup [ <tag> [ ] write-tag ] cons f swons
swap [ <tag> >n f ] cons f swons
[ "last-name" get n> -rot swap attribute-assign [ ] write-tag ]
2list cons ;
"cont-html" swap
2dup def-for-html-word-<foo> define-compound
2dup def-for-html-word-<foo define-compound
2dup def-for-html-word-foo> define-compound
def-for-html-word-</foo> define-compound ;
: define-open-html-word ( name -- )
#! Given an HTML tag name, define the words for
#! that open only HTML tag.
dup open-html-word-names
swap open-html-word-code
[ ] 2list>alist
[ uncons "cont-html" -rot define-compound ] each ;
#! that open HTML tag.
"cont-html" swap
2dup def-for-html-word-<foo/> define-compound
2dup def-for-html-word-<foo define-compound
def-for-html-word-foo/> define-compound ;
: define-attribute-word ( name -- )
#! Given an attribute name, define the word for
#! that attribute.
"cont-html" swap
dup "=" cat2
swap [ "last-name" get n> -rot swap attribute-assign >n ] swap add
[ "last-name" set ] append
define-compound ;
"cont-html" swap dup "=" cat2 swap
[ store-prev-attribute ] cons reverse [ "current-attribute" set ] append define-compound ;
! Define some open HTML tags
! Define some closed HTML tags
[
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
@ -266,7 +202,7 @@ USE: logic
"script" "div" "span" "select" "option"
] [ define-closed-html-word ] each
! Define some closed HTML tags
! Define some open HTML tags
[
"input"
"br"

View File

@ -1,4 +1,4 @@
! cont-responder v0.5
! cont-responder v0.6
!
! Copyright (C) 2004 Chris Double.
!
@ -136,11 +136,11 @@ DEFER: show
drop
[
drop
<html> [
<body> [
<p> [ "This page has expired." write ] </p>
] </body>
] </html>
<html>
<body>
<p> "This page has expired." write </p>
</body>
</html>
] show drop ;
: get-registered-continuation ( id -- cont )
@ -281,16 +281,19 @@ DEFER: show
] with-exit-continuation
print drop ;
: callback-quot ( quot -- quot )
#! Convert the given quotation so it works as a callback
#! by returning a quotation that will pass the original
#! quotation to the callback continuation.
unit "callback-cc" get [ call ] cons append ;
: quot-href ( text quot -- )
#! Write to standard output an HTML HREF where the href,
#! when referenced, will call the quotation and then return
#! back to the most recent 'show' call (via the callback-cc).
#! The text of the link will be the 'text' argument on the
#! stack.
<a href=
unit "callback-cc" get [ call ] cons append t swap register-continuation
a>
swap unit [ write ] append </a> ;
<a href= callback-quot t swap register-continuation a> write </a> ;
: with-new-session ( quot -- )
#! Each cont-responder is bound inside their own

View File

@ -35,47 +35,47 @@ USE: html
: simple-page ( title quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title.
<html> [
<head> [ <title> [ swap write ] </title> ] </head>
<body> [ call ] </body>
] </html> ;
<html>
<head> <title> swap write </title> </head>
<body> call </body>
</html> ;
: styled-page ( title stylesheet-quot quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title. stylesheet-quot
#! is called to generate the required stylesheet.
<html> [
<head> [
<title> [ rot write ] </title>
<html>
<head>
<title> rot write </title>
swap call
] </head>
<body> [ call ] </body>
] </html> ;
</head>
<body> call </body>
</html> ;
: paragraph ( str -- )
#! Output the string as an html paragraph
<p> [ write ] </p> ;
<p> write </p> ;
: show-message-page ( message -- )
#! Display the message in an HTML page with an OK button.
[
"Press OK to Continue" [
swap paragraph
<a href= a> [ "OK" write ] </a>
<a href= a> "OK" write </a>
] simple-page
] show 2drop ;
: vertical-layout ( list -- )
#! Given a list of HTML components, arrange them vertically.
<table> [
[ <tr> [ <td> [ call ] </td> ] </tr> ] each
] </table> ;
<table>
[ <tr> <td> call </td> </tr> ] each
</table> ;
: horizontal-layout ( list -- )
#! Given a list of HTML components, arrange them horizontally.
<table> [
<tr valign= "top" tr> [ [ <td> [ call ] </td> ] each ] </tr>
] </table> ;
<table>
<tr valign= "top" tr> [ <td> call </td> ] each </tr>
</table> ;
: button ( label -- )
#! Output an HTML submit button with the given label.
@ -84,8 +84,8 @@ USE: html
: with-simple-html-output ( quot -- )
#! Run the quotation inside an HTML stream wrapped
#! around stdio.
<pre> [
<pre>
"stdio" get <html-stream> [
call
] with-stream
] </pre> ;
</pre> ;

View File

@ -55,18 +55,18 @@ USE: vocabularies
: display-eval-form ( url -- )
#! Display the components for allowing entry of
#! factor words to be evaluated.
<form name= "main" method= "post" action= form> [
<form name= "main" method= "post" action= form>
[
[
<textarea name= "eval" rows= "10" cols= "40" textarea> [
<textarea name= "eval" rows= "10" cols= "40" textarea>
"" write
] </textarea>
</textarea>
]
[
<input type= "submit" value= "Evaluate" accesskey= "e" input/>
]
] vertical-layout
] </form>
</form>
"<script language='javascript'>document.forms.main.eval.focus()</script>" write ;
: escape-quotes ( string -- string )
@ -82,14 +82,14 @@ USE: vocabularies
: write-eval-link ( string -- )
#! Given text to evaluate, create an A HREF link which when
#! clicked sets the eval textarea to that value.
<a href= "#" onclick= dup make-eval-javascript a> [ write ] </a> ;
<a href= "#" onclick= dup make-eval-javascript a> write </a> ;
: display-stack ( list -- )
#! Write out html to display the stack.
<table border= "1" table> [
<tr> [ <th> [ "Callstack" write ] </th> ] </tr>
[ <tr> [ <td> [ write-eval-link ] </td> ] </tr> ] each
] </table> ;
<table border= "1" table>
<tr> <th> "Callstack" write </th> </tr>
[ <tr> <td> write-eval-link </td> </tr> ] each
</table> ;
: display-clear-history-link ( -- )
#! Write out html to display a link that will clear
@ -100,10 +100,10 @@ USE: vocabularies
: display-history ( list -- )
#! Write out html to display the history.
<table border= "1" table> [
<tr> [ <th> [ "History" write display-clear-history-link ] </th> ] </tr>
[ <tr> [ <td> [ write-eval-link ] </td> ] </tr> ] each
] </table> ;
<table border= "1" table>
<tr> <th> "History" write display-clear-history-link </th> </tr>
[ <tr> <td> write-eval-link </td> </tr> ] each
</table> ;
: html-for-word-source ( word-string -- )
#! Return an html fragment dispaying the source
@ -111,38 +111,38 @@ USE: vocabularies
dup dup
<namespace> [
"responder" "inspect" put
<table border= "1" table> [
<tr> [ <th colspan= "2" th> [ "Source" write ] </th> ] </tr>
<tr> [ <td colspan= "2" td> [ [ see ] with-simple-html-output ] </td> ] </tr>
<tr> [ <th> [ "Apropos" write ] </th> <th> [ "Usages" write ] </th> ] </tr>
<tr> [ <td valign= "top" td> [ [ apropos. ] with-simple-html-output ] </td>
<td valign= "top" td> [ [ usages. ] with-simple-html-output ] </td>
] </tr>
] </table>
<table border= "1" table>
<tr> <th colspan= "2" th> "Source" write </th> </tr>
<tr> <td colspan= "2" td> [ see ] with-simple-html-output </td> </tr>
<tr> <th> "Apropos" write </th> <th> "Usages" write </th> </tr>
<tr> <td valign= "top" td> [ apropos. ] with-simple-html-output </td>
<td valign= "top" td> [ usages. ] with-simple-html-output </td>
</tr>
</table>
] bind ;
: display-word-see-form ( url -- )
#! Write out the html for code that accepts
#! the name of a word, and displays the source
#! code of that word.
<form method= "post" action= "." form> [
<form method= "post" action= "." form>
[
[
"Enter the name of a word: " write
"see" [ html-for-word-source ] live-search
]
[
<div id= "see" div> [ "" write ] </div>
<div id= "see" div> "" write </div>
]
] vertical-layout
] </form> ;
</form> ;
: display-last-output ( string -- )
#! Write out html to display the last output.
<table border= "1" table> [
<tr> [ <th> [ "Last Output" write ] </th> ] </tr>
<tr> [ <td> [ <pre> [ write ] </pre> ] </td> ] </tr>
] </table> ;
<table border= "1" table>
<tr> <th> "Last Output" write </th> </tr>
<tr> <td> <pre> write </pre> </td> </tr>
</table> ;
: get-expr-to-eval ( -- string )
@ -150,12 +150,12 @@ USE: vocabularies
#! evaluated. Return the form as a string. Assumes
#! an evaluator is on the namestack.
[
<html> [
<head> [
<title> [ "Factor Evaluator" write ] </title>
<html>
<head>
<title> "Factor Evaluator" write </title>
include-live-updater-js
] </head>
<body> [
</head>
<body>
"Use Alt+E to evaluate, or press 'Evaluate'" paragraph
[
[ display-eval-form ]
@ -164,8 +164,8 @@ USE: vocabularies
] horizontal-layout
display-word-see-form
"output" get display-last-output
] </body>
] </html>
</body>
</html>
] show [
"eval" get
] bind ;

View File

@ -41,41 +41,41 @@ USE: cont-responder
#! aporpos of that word.
<namespace> [
"responder" "inspect" put
<pre> [
<pre>
"stdio" get <html-stream> [
apropos.
] with-stream
] </pre>
</pre>
] bind ;
: live-updater-responder ( -- )
[
drop
<html> [
<head> [
<title> [ "Live Updater Example" write ] </title>
<html>
<head>
<title> "Live Updater Example" write </title>
include-live-updater-js
] </head>
<body> [
</head>
<body>
[
[
"millis" [ millis write ] "Display Server millis" live-anchor
<div id= "millis" div> [
<div id= "millis" div>
"The millisecond time from the server will appear here" write
] </div>
</div>
]
[
"Enter a word to apropos:" paragraph
"apropos" [ live-search-apropos-word ] live-search
]
[
<div id= "apropos" div> [
<div id= "apropos" div>
"" write
] </div>
</div>
]
] vertical-layout
] </body>
] </html>
</body>
</html>
] show ;
"live-updater" [ live-updater-responder ] install-cont-responder

View File

@ -52,9 +52,9 @@ USE: lists
: include-live-updater-js ( -- )
#! Write out the HTML script to include the live updater
#! javascript code.
<script language= "JavaScript" src= live-updater-url script> [
<script language= "JavaScript" src= live-updater-url script>
"" write
] </script> ;
</script> ;
: write-live-anchor-tag ( text -- id )
#! Write out the HTML for the clickable anchor. This
@ -62,9 +62,9 @@ USE: lists
#! an onclick is set via DHTML later to make it run a
#! quotation on the server. The randomly generated id
#! for the anchor is returned.
<a id= get-random-id dup href= "#" a> [
<a id= get-random-id dup href= "#" a>
swap write
] </a> ;
</a> ;
: register-live-anchor-quot ( div-id div-quot -- kid )
#! Register the 'quot' with the cont-responder so
@ -79,7 +79,7 @@ USE: lists
[
t "disable-initial-redirect?" set
[
<div id= "div-id" get div> [ "div-quot" get call ] </div>
<div id= "div-id" get div> "div-quot" get call </div>
] show
] bind
] cons t swap register-continuation ;
@ -92,13 +92,13 @@ USE: lists
#! in a 'div' tag with the 'div-id'. That 'div' tag will
#! replace whatever HTML DOM object currently has that same
#! id.
<script language= "JavaScript" script> [
<script language= "JavaScript" script>
"document.getElementById('" write
write
"').onclick=liveUpdaterUri('" write
register-live-anchor-quot write
"');" write
] </script> ;
</script> ;
: live-anchor ( id quot text -- )
#! Write out the HTML for an anchor that when clicked
@ -135,7 +135,7 @@ USE: lists
[
#! Don't need the URL as the 'show' won't be resumed.
drop
<div id= "div-id" get div> [ "div-quot" get call ] </div>
<div id= "div-id" get div> "div-quot" get call </div>
] show
] bind
] cons t swap register-continuation ;
@ -149,13 +149,13 @@ USE: lists
#! a 'div' with the id 'div-id' and will
#! replace whatever HTML DOM object currently has that same
#! id.
<script language= "JavaScript" script> [
<script language= "JavaScript" script>
"liveSearch('" write
write
"', '" write
register-live-search-quot write
"');" write
] </script> ;
</script> ;
: live-search ( div-id div-quot -- )
#! Write an input text field. The keydown of this

View File

@ -123,16 +123,16 @@ USE: kernel
: row ( list -- )
#! Output an html TR row with each element of the list
#! being called to produce the output for each TD.
<tr> [
[ <td> [ call ] </td> ] each
] </tr> ;
<tr>
[ <td> call </td> ] each
</tr> ;
: styled-row ( class list -- )
#! Output an html TR row with each element of the list
#! being called to produce the output for each TD.
<tr class= swap tr> [
[ <td> [ call ] </td> ] each
] </tr> ;
<tr class= swap tr>
[ <td> call </td> ] each
</tr> ;
: simple-input ( name -- )
#! Output a simple HTML input field which will have the
@ -147,12 +147,12 @@ USE: kernel
: textarea-input ( name -- )
#! Output a simple HTML textarea field which will have the
#! specified name.
<textarea name= rows= "10" cols= "40" textarea> [ "Enter description here." write ] </textarea> ;
<textarea name= rows= "10" cols= "40" textarea> "Enter description here." write </textarea> ;
: textarea-input-with-value ( name value -- )
#! Output a simple HTML textarea field which will have the
#! specified name and value.
<textarea name= swap rows= "10" cols= "40" textarea> [ write ] </textarea> ;
<textarea name= swap rows= "10" cols= "40" textarea> write </textarea> ;
: password-input ( name -- )
#! Output an HTML password input field which will have the
@ -162,7 +162,7 @@ USE: kernel
: form ( action quot -- )
#! Call quot with any output appearing inside an HTML form.
#! The form is a POST form where the action is as specified.
<form method= "post" action= swap form> swap </form> ;
<form method= "post" action= swap form> call </form> ;
: input-value ( name -- value )
#! Get the value of the variable "name". If it is f
@ -175,10 +175,10 @@ USE: kernel
#! in 'button-text'. The form will go to the given URL on
#! submission.
swap [
<table> [
<table>
[ [ "Name:" write ] [ "name" simple-input ] ] row
[ [ "Password:" write ] [ "password" password-input ] ] row
] </table>
</table>
button
] form ;
@ -239,11 +239,11 @@ USE: kernel
: login-request-paragraph ( -- )
#! Display the paragraph requesting the user to login or register.
<p> [
<p>
"Please enter your username and password (" write
"Click to Register" [ register-new-user ] quot-href
"):" write
] </p> ;
</p> ;
: get-login-information ( -- user password )
[
@ -274,12 +274,16 @@ USE: kernel
#! Display the HTML for a form allowing entry of a
#! todo item details.
[
<table> [
<tr class= "required" tr> [ <td class= "lbl" td> [ "Priority" write ] </td>
<td> [ "priority" simple-input ] </td> ] </tr>
<tr class= "required" tr> [ <td class= "lbl" td> [ "Description" write ] </td>
<td> [ "description" textarea-input ] </td> ] </tr>
] </table>
<table>
<tr class= "required" tr>
<td class= "lbl" td> "Priority" write </td>
<td> "priority" simple-input </td>
</tr>
<tr class= "required" tr>
<td class= "lbl" td> "Description" write </td>
<td> "description" textarea-input </td>
</tr>
</table>
"Add" button
] form ;
@ -288,12 +292,16 @@ USE: kernel
#! todo item details.
swap [
[
<table> [
<tr class= "required" tr> [ <td class= "lbl" td> [ "Priority" write ] </td>
<td> [ "priority" dup get simple-input-with-value ] </td> ] </tr>
<tr class= "required" tr> [ <td class= "lbl" td> [ "Description" write ] </td>
<td> [ "description" dup get textarea-input-with-value ] </td> ] </tr>
] </table>
<table>
<tr class= "required" tr>
<td class= "lbl" td> "Priority" write </td>
<td> "priority" dup get simple-input-with-value </td>
</tr>
<tr class= "required" tr>
<td class= "lbl" td> "Description" write </td>
<td> "description" dup get textarea-input-with-value </td>
</tr>
</table>
"Save" button
] form
] bind ;
@ -320,14 +328,20 @@ USE: kernel
#! Display the HTML for a form allowing entry of a
#! new password.
[
<table> [
<tr class= "required" tr> [ <td class= "lbl" td> [ "Old Password" write ] </td>
<td> [ "old-password" password-input ] </td> ] </tr>
<tr class= "required" tr> [ <td class= "lbl" td> [ "New Password" write ] </td>
<td> [ "new-password" password-input ] </td> ] </tr>
<tr class= "required" tr> [ <td class= "lbl" td> [ "Verify Password" write ] </td>
<td> [ "verify-password" password-input ] </td> ] </tr>
] </table>
<table>
<tr class= "required" tr>
<td class= "lbl" td> "Old Password" write </td>
<td> "old-password" password-input </td>
</tr>
<tr class= "required" tr>
<td class= "lbl" td> "New Password" write </td>
<td> "new-password" password-input </td>
</tr>
<tr class= "required" tr>
<td class= "lbl" td> "Verify Password" write </td>
<td> "verify-password" password-input </td>
</tr>
</table>
"Change Password" button
] form ;
@ -406,12 +420,12 @@ USE: kernel
: write-item-table ( <todo> -- )
#! Write the table of items for the todo list.
<table> [
<table>
"heading" [
[ "Priority" write ] [ "Complete?" write ] [ "Description" write ] [ "Action" write ] [ " " write ]
] styled-row
todo-items [ write-item-row ] each
] </table> ;
</table> ;
: do-add-new-item ( -- )
#! Request a new item from the user and add it to the current todo list.