! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
+! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
memory namespaces prettyprint sequences words xml ;
: option ( current text -- )
- #! Output the HTML option tag for the given text. If
- #! it is equal to the current string, make the option selected.
- 2dup = [
- "<option selected>" write
- ] [
- "<option>" write
- ] if
- chars>entities write
- "</option>\n" write drop ;
+ #! Output the HTML option tag for the given text. If
+ #! it is equal to the current string, make the option selected.
+ 2dup = [
+ "<option selected>" write
+ ] [
+ "<option>" write
+ ] if
+ chars>entities write
+ "</option>\n" write drop ;
: vocab-list ( vocab -- )
- #! Write out the HTML for the list of vocabularies. Make the currently
- #! selected vocab be 'vocab'.
- <select "vocab" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select>
- vocabs [ over swap option ] each drop
- </select> ;
+ #! Write out the HTML for the list of vocabularies. Make the currently
+ #! selected vocab be 'vocab'.
+ <select "vocab" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select>
+ vocabs [ over swap option ] each drop
+ </select> ;
: word-list ( vocab word -- )
- #! Write out the HTML for the list of words in a vocabulary. Make the 'word' item
- #! the currently selected option.
- <select "word" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select>
- swap words natural-sort
- [ word-name over swap option ] each drop
- </select> ;
+ #! Write out the HTML for the list of words in a vocabulary. Make the 'word' item
+ #! the currently selected option.
+ <select "word" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select>
+ swap words natural-sort
+ [ word-name over swap option ] each drop
+ </select> ;
: word-source ( vocab word -- )
- #! Write the source for the given word from the vocab as HTML.
- swap lookup [ [ help ] with-html-stream ] when* ;
+ #! Write the source for the given word from the vocab as HTML.
+ swap lookup [ [ (help) ] with-html-stream ] when* ;
: browser-body ( vocab word -- )
- #! Write out the HTML for the body of the main browser page.
- <table "100%" =width table>
- <tr>
- <td> <b> "Vocabularies" write </b> </td>
- <td> <b> "Words" 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> ;
+ #! Write out the HTML for the body of the main browser page.
+
<table "100%" =width table>
+ <tr>
+ <td> <b> "Vocabularies" write </b> </td>
+ <td> <b> "Words" 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> ;
: browser-title ( vocab word -- )
- #! Output the HTML title for the browser.
- <title>
- "Factor Browser - " write
- swap write
- " - " write
- write
- </title> ;
-
-: browser-style ( -- )
- #! Stylesheet for browser pages
- <style>
- "A:link { text-decoration:none}\n" write
- "A:visited { text-decoration:none}\n" write
- "A:active { text-decoration:none}\n" write
- "A:hover, A.nav:hover { border: 1px solid black; text-decoration: none; margin: 0px }\n" write
- "A { margin: 1px }" write
- </style> ;
+ #! Output the HTML title for the browser.
+ [ "Factor Browser - " % swap % " - " % % ] "" make ;
: browse ( vocab word -- )
- #! Display a Smalltalk like browser for exploring words.
- [
- <html>
- <head> 2dup browser-title browser-style </head>
- <body>
- <form "main" =name "" =action "get" =method form> browser-body </form>
- </body>
- </html>
- ] show-final ;
+ #! Display a Smalltalk like browser for exploring words.
+ [
+ 2dup browser-title [
+ <form "main" =name "" =action "get" =method form> browser-body </form>
+ ] html-document
+ ] show-final ;
: browser-responder ( -- )
- #! Start the Smalltalk-like browser.
- "vocab" "query" get hash [ "browser-responder" ] unless*
- "word" "query" get hash [ "browse" ] unless* browse ;
+ #! Start the Smalltalk-like browser.
+ "vocab" "query" get hash [ "browser-responder" ] unless*
+ "word" "query" get hash [ "browse" ] unless* browse ;
!
! <input "text" =type "name" =name "20" =size input/>
+SYMBOL: html
+
+: write-html H{ { html t } } format ;
+
: attrs>string ( alist -- string )
#! Convert the attrs alist to a string
#! suitable for embedding in an html tag.
#! With the attribute namespace on the stack, get the attributes
#! and write them to standard output. If no attributes exist, write
#! nothing.
- "attrs" get attrs>string write ;
+ "attrs" get attrs>string write-html ;
: html-word ( name def -- )
#! Define 'word creating' word to allow
: <foo> "<" swap ">" append3 ;
-: do-<foo> <foo> write ;
+: do-<foo> <foo> write-html ;
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
: <foo "<" swap append ;
-: do-<foo write H{ } clone >n V{ } clone "attrs" set ;
+: do-<foo write-html H{ } clone >n V{ } clone "attrs" set ;
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
: foo> ">" append ;
-: do-foo> write-attributes n> drop ">" write ;
+: do-foo> write-attributes n> drop ">" write-html ;
: def-for-html-word-foo> ( name -- )
#! Return the name and code for the foo> patterned
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
- </foo> dup [ write ] cons html-word define-close ;
+ </foo> dup [ write-html ] cons html-word define-close ;
: <foo/> [ "<" % % "/>" % ] "" make ;
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
IN: html
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 ;
+ 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, "; " % ;
+: bg-css, ( color -- )
+ "background-color: #" % hex-color, "; " % ;
: style-css, ( flag -- )
dup
] 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 ;
+ [
+ H{
+ { page-color [ bg-css, ] }
+ ! { border-color [ font-css, ] }
+ } hash-apply
+ ] "" make ;
: div-tag ( style quot -- )
over div-css-style dup empty? [
call
] if* ;
+: do-escaping ( string style -- string )
+ html swap hash [ chars>entities ] unless ;
+
GENERIC: browser-link-href ( presented -- href )
M: word browser-link-href
presented pick hash browser-link-href
[ <a =href a> call </a> ] [ call ] if* ;
-TUPLE: wrapper-stream scope ;
-
-C: wrapper-stream ( stream -- stream )
- 2dup set-delegate [
- >r stdio associate r> set-wrapper-stream-scope
- ] keep ;
-
-: with-wrapper ( stream quot -- )
- >r wrapper-stream-scope r> bind ; inline
-
TUPLE: nested-stream ;
C: nested-stream [ set-delegate ] keep ;
TUPLE: html-stream ;
+C: html-stream ( stream -- stream ) [ set-delegate ] keep ;
+
M: html-stream stream-write1 ( char stream -- )
>r ch>string r> stream-write ;
-M: html-stream stream-write ( char stream -- )
- [ chars>entities write ] with-wrapper ;
+: delegate-write delegate stream-write ;
+
+M: html-stream stream-write ( str stream -- )
+ >r chars>entities r> delegate-write ;
M: html-stream stream-format ( str style stream -- )
[
[
[
- [ drop chars>entities write ] span-tag
+ [
+ do-escaping stdio get delegate-write
+ ] span-tag
] file-link-tag
] browser-link-tag
- ] with-wrapper ;
+ ] with-stream* ;
-: pre-tag ( stream style quot -- )
+: pre-tag ( style quot -- )
wrap-margin rot hash [
call
] [
- over [ [ <pre> ] with-wrapper call ] keep
- [ </pre> ] with-wrapper
+ <pre> call </pre>
] 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
- #! written, and supports writing attributed strings with
- #! the following attributes:
- #!
- #! foreground - an rgb triplet in a list
- #! background - an rgb triplet in a list
- #! font
- #! font-style
- #! font-size
- #! file
- #! word
- #! vocab
- [ >r <wrapper-stream> r> set-delegate ] keep ;
+ [
+ [
+ [
+ stdio get <nested-stream> swap with-stream*
+ ] pre-tag
+ ] div-tag
+ ] with-stream* ;
+
+M: html-stream stream-terpri [ <br/> ] with-stream* ;
: with-html-stream ( quot -- )
- [ stdio [ <html-stream> ] change call ] with-scope ;
+ stdio get <html-stream> swap with-stream* ;
+
+: default-css ( -- )
+ <style>
+ "A:link { text-decoration:none}" print
+ "A:visited { text-decoration:none}" print
+ "A:active { text-decoration:none}" print
+ "A:hover, A.nav:hover { border: 1px solid black; text-decoration: none; margin: -1px }" print
+ </style> ;
: html-document ( title quot -- )
swap chars>entities dup
<html>
<head>
<title> write </title>
+ default-css
</head>
<body>
<h1> write </h1>
DEFER: http-get
-: do-redirect ( code headers stream -- code headers stream )
+: do-redirect ( code headers string -- code headers string )
#! Should this support Location: headers that are
#! relative URLs?
pick 302 = [
- stream-close "Location" swap hash nip http-get
+ drop "Location" swap hash nip http-get
] when ;
: http-get ( url -- code headers stream )
#! Opens a stream for reading from an HTTP URL.
parse-url over parse-host <client> [
- [ get-request read-response ] with-stream*
- ] keep do-redirect ;
+ get-request read-response stdio get contents
+ ] with-stream do-redirect ;
: download ( url file -- )
#! Downloads the contents of a URL to a file.
crlf
] keep write ;
-: http-post ( content-type content url -- code headers stream )
+: http-post ( content-type content url -- code headers string )
#! Make a POST request. The content is URL encoded for you.
parse-url over parse-host <client> [
- [ post-request flush read-response ] with-stream*
+ [
+ post-request flush read-response stdio get contents
+ ] with-stream
] keep ;
"Tags: " print
unclosed-tags [ " <" write write ">" print ] each ;
-: seq-last ( seq -- last )
- [ length 1 - ] keep nth ;
-
: push-datum ( object -- )
- xml-stack get seq-last cdr push ;
+ xml-stack get peek cdr push ;
GENERIC: process ( object -- )
closer-name xml-stack get pop uncons
>r [
opener-name [
- 2dup = [ 2drop ] [ swap <mismatched> throw ] if
- ] keep
+ 2dup = [ 2drop ] [ swap <mismatched> throw ] if
+ ] keep
] keep opener-props r> <tag> push-datum ;
: initialize-xml-stack ( -- )
: xml ( string -- tag )
#! Produces a tree of XML nodes
[
- initialize-xml-stack
+ initialize-xml-stack
[ process ] xml-each
xml-stack get
dup length 1 = [ <unclosed> throw ] unless
M: process-missing error.
"Tag <" write
process-missing-tag tag-name write
- "> not implemented on process process " write
+ "> not implemented on process " write
dup process-missing-process word-name print ;
: run-process ( tag word -- )
{ $subsection stream-write1 }
{ $subsection stream-write }
{ $subsection stream-terpri }
-{ $subsection stream-terpri* }
{ $subsection stream-format }
{ $subsection with-nested-stream }
"If your stream supports the first three but not the rest, wrap it in a " { $link <plain-writer> } ", which provides plain text implementations of the stream formatting words (the so called " { $emphasis "extended stream output protocol" } ")." ;
{ $subsection write }
{ $subsection print }
{ $subsection terpri }
-{ $subsection terpri* }
{ $subsection format }
{ $subsection with-nesting }
"A pair of combinators support rebinding the " { $link stdio } " variable:"
{ $subsection font-size }
{ $subsection font-style }
{ $subsection presented }
-{ $subsection file }
-{ $subsection word-break } ;
+{ $subsection file } ;
ARTICLE: "paragraph-styles" "Paragraph styles"
"Paragraph styles for " { $link with-nested-stream } ":"
IN: help
-USING: arrays hashtables io kernel ;
+USING: arrays hashtables io kernel namespaces ;
+
+SYMBOL: last-block
: (help) ( topic -- )
default-style [
- [ article-content print-element ] with-nesting* terpri*
- ] with-style ;
+ last-block on article-content print-element
+ ] with-nesting* terpri ;
DEFER: $heading
: help ( topic -- )
- dup article-title $heading (help) ;
+ default-style [ dup article-title $heading ] with-style
+ (help) ;
: glossary ( name -- ) <term> help ;
PREDICATE: array simple-element
dup empty? [ drop t ] [ first word? not ] if ;
-: write-term ( string -- )
- dup terms get hash [
- dup <term> presented associate [ format* ] with-style
- ] [
- format*
- ] if ;
+M: string print-element last-block off format* ;
-M: string print-element
- " " split
- [ dup empty? [ drop ] [ write-term ] if ]
- [ bl ] interleave ;
+M: array print-element unswons* execute ;
-M: array print-element
- unswons* execute ;
-
-M: word print-element
- { } swap execute ;
+M: word print-element { } swap execute ;
: ($span) ( content style -- )
- [ print-element ] with-style ;
+ last-block off [ print-element ] with-style ;
-: ($block) ( content style -- )
- terpri*
- [ [ print-element ] with-nesting* ] with-style
- terpri* ;
+: ($block) ( quot -- )
+ last-block [ [ terpri ] unless f ] change
+ call
+ terpri
+ last-block on ; inline
! Some spans
-: $heading heading-style ($block) ;
+: $heading [ heading-style ($span) ] ($block) ;
-: $subheading subheading-style ($block) ;
+: $subheading [ subheading-style ($span) ] ($block) ;
: $snippet snippet-style ($span) ;
: $url url-style ($span) ;
-: $terpri terpri terpri drop ;
+: $terpri last-block off terpri terpri drop ;
! Some blocks
-M: simple-element print-element [ print-element ] each ;
+M: simple-element print-element
+ [ print-element ] each ;
: ($code) ( presentation quot -- )
- terpri*
- code-style [
- >r current-style swap presented pick set-hash r>
- with-nesting
- ] with-style
- terpri* ; inline
+ [
+ code-style [
+ >r current-style swap presented pick set-hash r>
+ with-nesting
+ ] with-style
+ ] ($block) ; inline
: $code ( content -- )
"\n" join dup <input> [ format* ] ($code) ;
] if* ;
: $stack-effect ( word -- )
- stack-effect [ "Stack effect" $subheading $snippet ] when* ;
+ stack-effect [
+ "Stack effect" $subheading $snippet
+ ] when* ;
+
+: $vocabulary ( content -- )
+ "Vocabulary" $subheading $snippet ;
: $synopsis ( content -- )
first dup
- word-vocabulary [ "Vocabulary" $subheading $snippet ] when*
+ word-vocabulary [ $vocabulary ] when*
dup parsing? [ $syntax ] [ $stack-effect ] if ;
: $description ( content -- )
"Examples" $subheading print-element ;
: $warning ( content -- )
- terpri*
- current-style warning-style hash-union [
- "Warning" $subheading print-element
- ] with-nesting
- terpri* ;
+ [
+ current-style warning-style hash-union [
+ "Warning" $subheading print-element
+ ] with-nesting
+ ] ($block) ;
: textual-list ( seq quot -- )
- [ "," format* bl ] interleave ; inline
+ [ ", " print-element ] interleave ; inline
: $see ( content -- )
- code-style [ [ first see ] with-nesting* ] with-style ;
+ code-style [ first see ] with-nesting* ;
: $example ( content -- )
- first2 swap dup <input>
- [
+ first2 swap dup <input> [
input-style [ format* ] with-style terpri format*
] ($code) ;
DEFER: help
: $subsection ( object -- )
- terpri*
- subsection-style [
- first dup article-title swap <link>
- dup [ link-name (help) ] curry
- simple-outliner
- ] with-style ;
+ [
+ subsection-style [
+ first dup article-title swap <link>
+ dup [ link-name (help) ] curry
+ simple-outliner
+ ] with-style
+ ] ($block) ;
: $link ( article -- )
- first dup word? [
+ last-block off first dup word? [
pprint
] [
link-style [
] with-style
] if ;
-: $glossary ( element -- )
- first dup <term> simple-object ;
-
: $definition ( content -- )
"Definition" $subheading $see ;
"See also" $subheading [ 1array $link ] textual-list ;
: $values ( content -- )
- "Arguments and values" $subheading [
- unswons* $snippet " -- " format* print-element
- ] [
- terpri
- ] interleave ;
+ "Arguments and values" $subheading
+ [ unswons* $snippet " -- " format* print-element ]
+ [ terpri ] interleave ;
: $predicate ( content -- )
{ { "object" "an object" } } $values
- "Tests if the object is an instance of the " $description
- $link " class." format* ;
+ [
+ "Tests if the object is an instance of the " ,
+ { $link } swap append ,
+ " class." ,
+ ] { } make $description ;
: $list ( content -- )
- terpri* [ "- " format* print-element terpri* ] each ;
+ [
+ [
+ list-element-style [ print-element ] with-nesting*
+ ] ($block)
+ ] each ;
: $errors ( content -- )
"Errors" $subheading print-element ;
{ { "x" "a complex number" } { "y" "a complex number" } } $values ;
: $io-error
+ drop
"Throws an error if the I/O operation fails." $errors ;
{ border-color { 1 0 0 1 } }
{ border-width 5 }
} ;
+
+: list-element-style
+ H{ { border-color { 0.8 0.8 0.8 1 } } { border-width 5 } } ;
M: duplex-stream stream-terpri
duplex-stream-out stream-terpri ;
-M: duplex-stream stream-terpri*
- duplex-stream-out stream-terpri* ;
-
M: duplex-stream stream-format
duplex-stream-out stream-format ;
M: f stream-write1 2drop ;
M: f stream-write 2drop ;
M: f stream-terpri drop ;
-M: f stream-terpri* drop ;
M: f stream-flush drop ;
M: f stream-format 3drop ;
C: plain-writer ( stream -- stream ) [ set-delegate ] keep ;
M: plain-writer stream-terpri CHAR: \n swap stream-write1 ;
-M: plain-writer stream-terpri* stream-terpri ;
M: plain-writer stream-format nip stream-write ;
M: plain-writer with-nested-stream ( quot style stream -- )
- [ stdio set drop call ] with-scope ;
+ nip swap with-stream* ;
: flush ( -- ) stdio get stream-flush ;\r
\r
: terpri ( -- ) stdio get stream-terpri ;\r
-: terpri* ( -- ) stdio get stream-terpri* ;\r
: format ( string style -- ) stdio get stream-format ;\r
\r
: with-nesting ( style quot -- )\r
\r
: print ( string -- ) stdio get stream-print ;\r
\r
-: with-stream ( stream quot -- )\r
- [ swap stdio set [ close ] cleanup ] with-scope ; inline\r
-\r
: with-stream* ( stream quot -- )\r
- [ swap stdio set [ close rethrow ] recover ] with-scope ;\r
- inline\r
+ [ swap stdio set call ] with-scope ; inline\r
+\r
+: with-stream ( stream quot -- )\r
+ swap [ [ close ] cleanup ] with-stream* ; inline\r
\r
SYMBOL: style-stack\r
\r
\r
: format* ( string -- ) current-style format ;\r
\r
-: bl ( -- ) H{ { word-break t } } [ " " format* ] with-style ;\r
+: bl ( -- ) " " format* ;\r
\r
-: with-nesting* ( quot -- )\r
- current-style swap with-nesting ; inline\r
+: with-nesting* ( style quot -- )\r
+ swap [ current-style swap with-nesting ] with-style ; inline\r
\r
: write-object ( object quot -- )\r
>r presented associate r> with-style ;\r
[ format* ] write-object ;\r
\r
: write-outliner ( content caption -- )\r
- >r outline associate r> with-nesting terpri ;\r
+ >r outline associate r> with-nesting* ;\r
\r
: simple-outliner ( string object content -- )\r
[ simple-object ] write-outliner ;\r
{ $contract "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
-HELP: terpri* "( -- )"
-{ $contract "Writes a line terminator to the " { $link stdio } " stream, unless the stream is already positioned at the start of a line, in which case this word does nothing. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
-$io-error ;
-
HELP: format "( str style -- )"
{ $values { "str" "a string" } { "style" "a hashtable" } }
{ $contract "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
HELP: with-stream* "( stream quot -- )"
{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } }
-{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } ". The stream is closed if the quotation throws an error, however it is " { $emphasis "not" } " closed if the quotation returns without incident." }
+{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } "." }
+{ $notes "This word differs from " { $link with-stream } " in that if an error is thrown while the quotation is executing, the stream is " { $emphasis "not" } " closed." }
{ $see-also with-stream } ;
HELP: style-stack f
GENERIC: stream-write ( string stream -- )
GENERIC: stream-flush ( stream -- )
GENERIC: stream-terpri ( stream -- )
-GENERIC: stream-terpri* ( stream -- )
GENERIC: stream-format ( string style stream -- )
GENERIC: with-nested-stream ( quot style stream -- )
{ $contract "Writes a line terminator. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
$io-error ;
-HELP: stream-terpri* "( stream -- )"
-{ $values { "stream" "an output stream" } }
-{ $contract "Writes a line terminator unless the stream is already positioned at the start of a line, in which case this word does nothing. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
-$io-error ;
-
HELP: stream-format "( str style stream -- )"
{ $values { "str" "a string" } { "style" "a hashtable" } { "stream" "an output stream" } }
{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
512 <sbuf> <plain-writer> ;
: string-out ( quot -- str )
- [
- <string-writer> stdio set call stdio get >string
- ] with-scope ; inline
+ <string-writer> [ call stdio get >string ] with-stream* ;
+ inline
! Reversed string buffers support the stream input protocol.
M: sbuf stream-read1 ( sbuf -- char/f )
SYMBOL: font-style
SYMBOL: presented
SYMBOL: file
-SYMBOL: word-break
! Paragraph styles
SYMBOL: page-color
HELP: file f
{ $description "Character style. A pathname associated with the text. In the Factor HTTP server, this is rendered as a link to this path on the server." } ;
-HELP: word-break f
-{ $description "Character style. Denotes that this text is a point in the text where the line can be wrapped." }
-{ $see-also bl } ;
-
HELP: page-color f
{ $description "Paragraph style. Background color of the paragraph block, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
{ $examples
: sheet. ( sheet -- )
dup format-sheet swap peek
- [ dup [ describe ] curry simple-outliner ] 2each ;
+ [ dup [ describe ] curry simple-outliner terpri ] 2each ;
: describe ( object -- ) dup summary print sheet sheet. ;
: sequence-outliner ( seq quot -- | quot: obj -- )
swap [
- [ unparse-short ] keep rot dupd curry simple-outliner
+ [ unparse-short ] keep rot dupd curry
+ simple-outliner terpri
] each-with ;
: words. ( vocab -- )
over pane-output add-incremental
prepare-line ;
-M: pane stream-terpri* ( pane -- )
- dup pane-current gadget-children empty?
- [ dup stream-terpri ] unless drop ;
-
: pane-write ( pane seq -- )
[ over pane-current stream-write ]
[ dup stream-terpri ] interleave drop ;
M: pane stream-close ( pane -- ) drop ;
+: ?terpri
+ dup pane-current gadget-children empty?
+ [ dup stream-terpri ] unless drop ;
+
: with-pane ( pane quot -- )
#! Clear the pane and run the quotation in a scope with
#! stdio set to the pane.
- over pane-clear over >r with-stream*
- r> stream-terpri* ; inline
+ over pane-clear over >r with-stream* r> ?terpri ; inline
: make-pane ( quot -- pane )
#! Execute the quotation with output to an output-only pane.
! A word break gadget
TUPLE: word-break-gadget ;
-C: word-break-gadget ( gadget -- gadget ) [ set-delegate ] keep ;
+C: word-break-gadget ( gadget -- gadget )
+ [ set-delegate ] keep ;
! A gadget that arranges its children in a word-wrap style.
TUPLE: paragraph margin ;
gadgets-layouts gadgets-outliner gadgets-panes hashtables io
kernel sequences strings styles ;
-! Utility pseudo-stream for implementation of panes
-
-UNION: gadget-stream pack paragraph ;
-
-M: gadget-stream stream-close ( stream -- ) drop ;
-
-M: gadget-stream stream-write ( string stream -- )
- over empty? [ 2drop ] [ >r <label> r> add-gadget ] if ;
-
-M: gadget-stream stream-write1 ( char stream -- )
- >r ch>string r> stream-write ;
-
! Character styles
: apply-style ( style gadget key quot -- style gadget )
: apply-command-style ( style gadget -- style gadget )
presented [ <command-button> ] apply-style ;
-: apply-break-style ( style gadget -- style gadget )
- word-break [ drop <word-break-gadget> ] apply-style ;
-
: <presentation> ( style text -- gadget )
<label>
apply-foreground-style
apply-background-style
apply-font-style
- apply-break-style
apply-command-style
nip ;
-M: gadget-stream stream-format ( string style stream -- )
- pick empty? pick hash-empty? and
- [ 3drop ] [ >r swap <presentation> r> add-gadget ] if ;
-
! Paragraph styles
: apply-wrap-style ( style pane -- style pane )
M: pane with-nested-stream ( quot style stream -- )
>r <nested-pane> r> write-gadget ;
+
+! Stream utilities
+M: pack stream-close ( stream -- ) drop ;
+
+M: paragraph stream-close ( stream -- ) drop ;
+
+: gadget-write ( string gadget -- )
+ over empty? [ 2drop ] [ >r <label> r> add-gadget ] if ;
+
+M: pack stream-write ( string stream -- ) gadget-write ;
+
+: gadget-bl ( style stream -- )
+ >r " " <presentation> <word-break-gadget> r> add-gadget ;
+
+M: paragraph stream-write ( string stream -- )
+ swap " " split
+ [ over gadget-write ] [ H{ } over gadget-bl ] interleave
+ drop ;
+
+: gadget-write1 ( char gadget -- )
+ >r ch>string r> stream-write ;
+
+M: pack stream-write1 ( char stream -- ) gadget-write1 ;
+
+M: paragraph stream-write1 ( char stream -- )
+ over CHAR: \s =
+ [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
+
+: gadget-format ( string style stream -- )
+ pick empty? pick hash-empty? and
+ [ 3drop ] [ >r swap <presentation> r> add-gadget ] if ;
+
+M: pack stream-format ( string style stream -- )
+ gadget-format ;
+
+M: paragraph stream-format ( string style stream -- )
+ presented pick hash [
+ gadget-format
+ ] [
+ rot " " split
+ [ pick pick gadget-format ]
+ [ 2dup gadget-bl ] interleave
+ 2drop
+ ] if ;
M: win32-stream stream-terpri
win32-stream-this [ CHAR: \n do-write ] bind ;
-M: win32-stream stream-terpri*
- win32-stream-this stream-terpri ;
-
M: win32-stream stream-flush ( stream -- )
win32-stream-this [ maybe-flush-output ] bind ;
timeout get [ millis cutoff get > [ handle get CancelIo ] when ] when
] bind ;
-USE: inspector
M: win32-stream with-nested-stream ( quot style stream -- )
win32-stream-this [ drop stream get swap with-stream* ] bind ;
projects / factor.git / commitdiff