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
parent
62c349a356
commit
4a562eb0c9
|
@ -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 [
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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> ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
Loading…
Reference in New Issue