M: string error. print ;
+: :error ( -- )
+ error get error. ;
+
: :s ( -- )
error-continuation get data>> stack. ;
attrs>> '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
: a-start-tag ( tag -- )
- [ compile-link-attrs ] [ compile-a-url ] bi
- [ <a =href a> ] [code] ;
+ [ <a ] [code]
+ [ non-chloe-attrs-only compile-attrs ]
+ [ compile-link-attrs ]
+ [ compile-a-url ]
+ tri
+ [ =href a> ] [code] ;
: a-end-tag ( tag -- )
drop [ </a> ] [code] ;
[ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
] compile-with-scope ;
+CHLOE: base
+ compile-a-url [ <base =href base/> ] [code] ;
+
: compile-hidden-form-fields ( for -- )
'[
<div "display: none;" =style div>
--- /dev/null
+IN: help.html.tests
+USING: html.streams classes.predicate help.topics help.markup
+io.streams.string accessors prettyprint kernel tools.test ;
+
+[ ] [ [ [ \ predicate-instance? def>> . ] with-html-writer ] with-string-writer drop ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
+io.files html.streams html.elements html.components help kernel
+assocs sequences make words accessors arrays help.topics vocabs
+tools.vocabs tools.vocabs.browser namespaces prettyprint io
+vocabs.loader serialize fry memoize unicode.case ;
IN: help.html
+: escape-char ( ch -- )
+ dup H{
+ { CHAR: " "__quote__" }
+ { CHAR: * "__star__" }
+ { CHAR: : "__colon__" }
+ { CHAR: < "__lt__" }
+ { CHAR: > "__gt__" }
+ { CHAR: ? "__question__" }
+ { CHAR: \\ "__backslash__" }
+ { CHAR: | "__pipe__" }
+ { CHAR: _ "__underscore__" }
+ { CHAR: / "__slash__" }
+ { CHAR: \\ "__backslash__" }
+ { CHAR: , "__comma__" }
+ } at [ % ] [ , ] ?if ;
+: escape-filename ( string -- filename )
+ [ [ escape-char ] each ] "" make ;
+
+GENERIC: topic>filename* ( topic -- name prefix )
+
+M: word topic>filename* [ name>> ] [ vocabulary>> ] bi 2array "word" ;
+M: link topic>filename* name>> "article" ;
+M: word-link topic>filename* name>> topic>filename* ;
+M: vocab-spec topic>filename* vocab-name "vocab" ;
+M: vocab-tag topic>filename* name>> "tag" ;
+M: vocab-author topic>filename* name>> "author" ;
+
+: topic>filename ( topic -- filename )
+ [
+ topic>filename* % "-" %
+ dup array?
+ [ [ escape-filename ] map "," join ]
+ [ escape-filename ]
+ if % ".html" %
+ ] "" make ;
+
+M: topic browser-link-href topic>filename ;
+
+: help-stylesheet ( -- )
+ "resource:basis/help/html/stylesheet.css" ascii file-contents write ;
+
+: help>html ( topic -- )
+ dup topic>filename utf8 [
+ dup article-title
+ [ <style> help-stylesheet </style> ]
+ [ [ help ] with-html-writer ] simple-page
+ ] with-file-writer ;
+
+: all-vocabs-really ( -- seq )
+ #! Hack.
+ all-vocabs values concat
+ vocabs [ find-vocab-root not ] filter [ vocab ] map append ;
+
+: all-topics ( -- topics )
+ [
+ articles get keys [ >link ] map %
+ all-words [ >link ] map %
+ all-authors [ <vocab-author> ] map %
+ all-tags [ <vocab-tag> ] map %
+ all-vocabs-really %
+ ] { } make ;
+
+: serialize-index ( index file -- )
+ [ [ [ topic>filename ] dip ] { } assoc-map-as object>bytes ] dip
+ binary set-file-contents ;
+
+: generate-indices ( -- )
+ articles get keys [ [ >link ] [ article-title ] bi ] { } map>assoc "articles.idx" serialize-index
+ all-words [ dup name>> ] { } map>assoc "words.idx" serialize-index
+ all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
+
+: generate-help-files ( -- )
+ all-topics [ help>html ] each ;
+
+: generate-help ( -- )
+ { "resource:core" "resource:basis" "resource:extra" } vocab-roots [
+ load-everything
+
+ "/tmp/docs/" [
+ generate-indices
+ generate-help-files
+ ] with-directory
+ ] with-variable ;
+
+MEMO: load-index ( name -- index )
+ binary file-contents bytes>object ;
+
+TUPLE: result title href ;
+
+M: result link-title title>> ;
+
+M: result link-href href>> ;
+
+: offline-apropos ( string index -- results )
+ load-index swap >lower
+ '[ [ drop _ ] dip >lower subseq? ] assoc-filter
+ [ swap result boa ] { } assoc>map ;
+
+: article-apropos ( string -- results )
+ "articles.idx" offline-apropos ;
+
+: word-apropos ( string -- results )
+ "words.idx" offline-apropos ;
+
+: vocab-apropos ( string -- results )
+ "vocabs.idx" offline-apropos ;
--- /dev/null
+a:link { text-decoration: none; color: #00004c; }
+a:visited { text-decoration: none; color: #00004c; }
+a:active { text-decoration: none; color: #00004c; }
+a:hover { text-decoration: underline; color: #00004c; }
[ strong-style get print-element* ] ($span) ;
: $url ( children -- )
- [ url-style get print-element* ] ($span) ;
+ [
+ dup first href associate url-style get assoc-union
+ print-element*
+ ] ($span) ;
: $nl ( children -- )
nl nl drop ;
{ $class-description "Text area components display a multi-line editor for a string value. The " { $slot "rows" } " and " { $slot "cols" } " properties determine the size of the text area." } ;
HELP: link
-{ $description "Link components render a link to an object stored at a value, with the link title and URL determined by the " { $link link-title } " and " { $link link-href } " generic words." } ;
+{ $description "Link components render a link to an object stored at a value, with the link title and URL determined by the " { $link link-title } " and " { $link link-href } " generic words. The optional " { $slot "target" } " slot is a target frame to open the link in." } ;
HELP: link-title
{ $values { "obj" object } { "string" string } }
[ t ] [
[ "object" inspector render ] with-string-writer
- [ "object" value [ describe ] with-html-stream ] with-string-writer
+ [ "object" value [ describe ] with-html-writer ] with-string-writer
=
] unit-test
M: url link-title ;
M: url link-href ;
-SINGLETON: link
+TUPLE: link target ;
M: link render*
- 2drop
- <a dup link-href =href a>
+ nip
+ <a target>> [ =target ] when* dup link-href =href a>
link-title present escape-string write
</a> ;
SINGLETON: inspector
M: inspector render*
- 2drop [ describe ] with-html-stream ;
+ 2drop [ describe ] with-html-writer ;
! Diff component
SINGLETON: comparison
"hr"
"link"
"img"
+ "base"
] [ define-open-html-word ] each
! Define some attributes
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple" "checked"
"summary" "cellspacing" "align" "scope" "abbr"
- "nofollow" "alt"
+ "nofollow" "alt" "target"
] [ define-attribute-word ] each
>>
"<?xml version=\"1.0\"?>" write-html
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
-: simple-page ( title quot -- )
+: simple-page ( title head-quot body-quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title.
+ spin
xhtml-preamble
<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
- <head> <title> swap write </title> </head>
+ <head>
+ <title> write </title>
+ call
+ </head>
<body> call </body>
</html> ; inline
{ $values { "stream" "an output stream" } { "html-stream" html-stream } }
{ $description "Creates a new formatted output stream which emits HTML markup on " { $snippet "stream" } "." } ;
-HELP: with-html-stream
+HELP: with-html-writer
{ $values { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-stream } " wrapping the current " { $link output-stream } "." }
{ $examples
{ $example
"USING: io io.styles html.streams ;"
- "[ \"Hello\" { { font-style bold } } format nl ] with-html-stream"
+ "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer"
"<span style='font-style: normal; font-weight: bold; '>Hello</span><br/>"
}
} ;
"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "styles" } " by writing HTML markup to the wrapped stream."
{ $subsection html-stream }
{ $subsection <html-stream> }
-{ $subsection with-html-stream } ;
+{ $subsection with-html-writer } ;
ABOUT: "html.streams"
IN: html.streams.tests
: make-html-string
- [ with-html-stream ] with-string-writer ; inline
+ [ with-html-writer ] with-string-writer ; inline
[ [ ] make-html-string ] must-infer
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test
-[ ] [ [ { 1 2 3 } describe ] with-html-stream ] unit-test
+[ ] [ [ { 1 2 3 } describe ] with-html-writer ] unit-test
: not-a-div ( stream -- stream )
f >>last-div ; inline
-: a-div ( stream -- straem )
+: a-div ( stream -- stream )
t >>last-div ; inline
: <html-stream> ( stream -- html-stream )
] [ call ] if*
] [ call ] if* ; inline
+: href-link-tag ( style quot -- )
+ href pick at [ <a =href a> call </a> ] [ call ] if* ; inline
+
: hex-color, ( color -- )
[ red>> ] [ green>> ] [ blue>> ] tri
[ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
: format-html-span ( string style stream -- )
stream>> [
- [ [ drop write ] span-tag ] object-link-tag
+ [ [ [ drop write ] span-tag ] href-link-tag ] object-link-tag
] with-output-stream* ;
TUPLE: html-span-stream < html-sub-stream ;
M: html-stream dispose stream>> dispose ;
-: with-html-stream ( quot -- )
+: with-html-writer ( quot -- )
output-stream get <html-stream> swap with-output-stream* ; inline
{ $values { "name" "the tag name" } { "definition" "a quotation with stack effect " { $snippet "( tag -- )" } } }
{ $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ;
-HELP: CHLOE-SINGLETON:
-{ $syntax "CHLOE-SINGLETON: name" }
-{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering an HTML component with singleton class word " { $snippet "name" } ". See " { $link "html.components" } "." } ;
-
-HELP: CHLOE-TUPLE:
-{ $syntax "CHLOE-TUPLE: name" }
-{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering an HTML component with tuple class word " { $snippet "name" } ". See " { $link "html.components" } "." } ;
+HELP: COMPONENT:
+{ $syntax "COMPONENT: name" }
+{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering the HTML component with class word " { $snippet "name" } ". See " { $link "html.components" } "." } ;
HELP: reset-cache
{ $description "Resets the compiled template cache. Chloe automatically recompiles templates when their file changes on disk, however other when redefining Chloe tags or words which they call, the cache may have to be reset manually for the changes to take effect." } ;
"s</a>"
}
} }
+ { { $snippet "t:base" } { "Outputs an HTML " { $snippet "<base>" } " tag. The attributes are interpreted in the same manner as the attributes of " { $snippet "t:a" } "." } }
{ { $snippet "t:form" } {
"Renders a form; extends the standard XHTML " { $snippet "form" } " tag by providing some integration with other web framework features, for example by adding hidden fields for authentication credentials and session management allowing those features to work with form submission transparently. The following attributes are supported:"
{ $list
"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "html.elements" } ":"
{ $code "M: image render* 2drop <img =src img/> ;" }
"Finally, we can define a Chloe component:"
-{ $code "CHLOE-SINGLETON: image" }
+{ $code "COMPONENT: image" }
"We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":"
{ $code "<t:image t:name='image' />" } ;
ARTICLE: "html.templates.chloe.extend.components" "Extending Chloe with custom components"
"Custom HTML components implementing the " { $link render* } " word can be wired up with Chloe using the following syntax from " { $vocab-link "html.templates.chloe.components" } ":"
-{ $subsection POSTPONE: CHLOE-SINGLETON: }
-{ $subsection POSTPONE: CHLOE-TUPLE: }
+{ $subsection POSTPONE: COMPONENT: }
{ $subsection "html.templates.chloe.extend.components.example" } ;
ARTICLE: "html.templates.chloe" "Chloe templates"
CHLOE: if dup if>quot [ swap when ] append process-children ;
-CHLOE-SINGLETON: label
-CHLOE-SINGLETON: link
-CHLOE-SINGLETON: inspector
-CHLOE-SINGLETON: comparison
-CHLOE-SINGLETON: html
-CHLOE-SINGLETON: hidden
-
-CHLOE-TUPLE: farkup
-CHLOE-TUPLE: field
-CHLOE-TUPLE: textarea
-CHLOE-TUPLE: password
-CHLOE-TUPLE: choice
-CHLOE-TUPLE: checkbox
-CHLOE-TUPLE: code
+COMPONENT: label
+COMPONENT: link
+COMPONENT: inspector
+COMPONENT: comparison
+COMPONENT: html
+COMPONENT: hidden
+COMPONENT: farkup
+COMPONENT: field
+COMPONENT: textarea
+COMPONENT: password
+COMPONENT: choice
+COMPONENT: checkbox
+COMPONENT: code
SYMBOL: template-cache
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel parser fry quotations
-classes.tuple
+classes.tuple classes.singleton
html.components
html.templates.chloe.compiler
html.templates.chloe.syntax ;
IN: html.templates.chloe.components
+
+GENERIC: component-tag ( tag class -- )
-: singleton-component-tag ( tag class -- )
+M: singleton-class component-tag ( tag class -- )
[ "name" required-attr compile-attr ]
[ literalize [ render ] [code-with] ]
bi* ;
-: CHLOE-SINGLETON:
- scan-word
- [ name>> ] [ '[ _ singleton-component-tag ] ] bi
- define-chloe-tag ;
- parsing
-
: compile-component-attrs ( tag class -- )
[ attrs>> [ drop main>> "name" = not ] assoc-filter ] dip
[ all-slots swap '[ name>> _ at compile-attr ] each ]
[ [ boa ] [code-with] ]
bi ;
-: tuple-component-tag ( tag class -- )
+M: tuple-class component-tag ( tag class -- )
[ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi
[ render ] [code] ;
-: CHLOE-TUPLE:
+: COMPONENT:
scan-word
- [ name>> ] [ '[ _ tuple-component-tag ] ] bi
+ [ name>> ] [ '[ _ component-tag ] ] bi
define-chloe-tag ;
parsing
[ add-responder-nesting ] [ call-responder* ] 2bi ;
: http-error. ( error -- )
- "Internal server error" [
- [ print-error nl :c ] with-html-stream
+ "Internal server error" [ ] [
+ [ print-error nl :c ] with-html-writer
] simple-page ;
: <500> ( error -- response )
dup <a =href a> escape-string write </a> ;\r
\r
: directory. ( path -- )\r
- dup file-name [\r
+ dup file-name [ ] [\r
[ <h1> file-name escape-string write </h1> ]\r
[\r
<ul>\r
SYMBOL: presented-path
SYMBOL: presented-printer
+SYMBOL: href
+
! Paragraph styles
SYMBOL: page-color
SYMBOL: border-color
: pprint-; ( -- ) \ ; pprint-word ;
: (see) ( spec -- )
- <colon dup synopsis*
- <block dup definition pprint-elements block>
- dup definer nip [ pprint-word ] when* declarations.
- block> ;
+ [
+ 12 nesting-limit set
+ 100 length-limit set
+ <colon dup synopsis*
+ <block dup definition pprint-elements block>
+ dup definer nip [ pprint-word ] when* declarations.
+ block>
+ ] with-scope ;
M: object see
[ (see) ] with-use nl ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors http.server.dispatchers
+http.server.static furnace.actions furnace.redirection urls
+validators locals io.files html.forms help.html ;
+IN: webapps.help
+
+TUPLE: help-webapp < dispatcher ;
+
+:: <search-action> ( help-dir -- action )
+ <page-action>
+ { help-webapp "search" } >>template
+
+ [
+ {
+ { "search" [ 2 v-min-length 50 v-max-length v-one-line ] }
+ } validate-params
+
+ help-dir set-current-directory
+
+ "search" value article-apropos "articles" set-value
+ "search" value word-apropos "words" set-value
+ "search" value vocab-apropos "vocabs" set-value
+
+ { help-webapp "search" } <chloe-content>
+ ] >>submit ;
+
+: <main-action> ( -- action )
+ <page-action>
+ { help-webapp "help" } >>template ;
+
+: <help-webapp> ( help-dir -- webapp )
+ help-webapp new-dispatcher
+ <main-action> "" add-responder
+ over <search-action> "search" add-responder
+ swap <static> "content" add-responder ;
+
+
--- /dev/null
+<?xml version="1.0" encoding="iso-8859-1"?>
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title>Factor Documentation</title>
+ <t:base t:href="$help-webapp" />
+ </head>
+
+ <frameset cols="25%, 75%">
+ <frame src="search" name="search" />
+ <frame src="content/article-handbook.html" name="content" />
+ </frameset>
+ </html>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <t:base t:href="$help-webapp/content/" />
+ </head>
+
+ <body>
+ <h1>Factor documentation</h1>
+
+ <t:form t:action="$help-webapp/search">
+ <t:field t:name="search" />
+ <button>Search</button>
+ </t:form>
+
+ <t:if t:value="articles">
+ <h1>Articles</h1>
+
+ <ul>
+ <t:each t:name="articles">
+ <li> <t:link t:name="value" t:target="content" /> </li>
+ </t:each>
+ </ul>
+ </t:if>
+
+ <t:if t:value="vocabs">
+ <h1>Vocabularies</h1>
+
+ <ul>
+ <t:each t:name="vocabs">
+ <li> <t:link t:name="value" t:target="content" /> </li>
+ </t:each>
+ </ul>
+ </t:if>
+
+ <t:if t:value="words">
+ <h1>Words</h1>
+
+ <ul>
+ <t:each t:name="words">
+ <li> <t:link t:name="value" t:target="content" /> </li>
+ </t:each>
+ </ul>
+ </t:if>
+
+ </body>
+</html>
+
+</t:chloe>
TUPLE: factor-website < dispatcher ;
+: <factor-boilerplate> ( responder -- responder' )
+ <boilerplate>
+ { factor-website "page" } >>template ;
+
: <configuration> ( responder -- responder' )
"Factor website" <login-realm>
"Factor website" >>name
allow-password-recovery
allow-edit-profile
allow-deactivation
- <boilerplate>
- { factor-website "page" } >>template
test-db <alloy> ;
: <factor-website> ( -- responder )
<factor-website>
<pastebin> "pastebin" add-responder
<planet> "planet" add-responder
+ <factor-boilerplate>
<configuration>
main-responder set-global ;
: init-production ( -- )
common-configuration
<vhost-dispatcher>
- <factor-website> "concatenative.org" add-responder
- <pastebin> "paste.factorcode.org" add-responder
- <planet> "planet.factorcode.org" add-responder
+ <factor-website> <factor-boilerplate> "concatenative.org" add-responder
+ <pastebin> <factor-boilerplate> "paste.factorcode.org" add-responder
+ <planet> <factor-boilerplate> "planet.factorcode.org" add-responder
<configuration>
main-responder set-global ;
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
+ write_barrier((CELL)new_string);
new_string->aux = tag_object(new_aux);
F_BYTE_ARRAY *aux = untag_object(string->aux);
}
REGISTER_UNTAGGED(string);
+ REGISTER_UNTAGGED(new_string);
fill_string(new_string,to_copy,capacity,fill);
+ UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
return new_string;
projects / factor.git / commitdiff