From f1bb2cca2048f169ff922877ddb6b171cc4ff1b7 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Sun, 31 Aug 2008 23:45:31 +0200
Subject: [PATCH 01/18] Fixing xml.generator tests
---
basis/xml/generator/generator-tests.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/xml/generator/generator-tests.factor b/basis/xml/generator/generator-tests.factor
index d44b713e55..052e5eab7f 100644
--- a/basis/xml/generator/generator-tests.factor
+++ b/basis/xml/generator/generator-tests.factor
@@ -1,3 +1,3 @@
-USING: tools.test io.streams.string xml.generator xml.writer ;
+USING: tools.test io.streams.string xml.generator xml.writer accessors ;
[ "<html><body><a href=\"blah\"/></body></html>" ]
-[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ write-item ] with-string-writer ] unit-test
+[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ body>> write-item ] with-string-writer ] unit-test
From 4044da2c510adb41839f83d49f65d00848d9832a Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Sun, 7 Sep 2008 01:33:06 +0200
Subject: [PATCH 02/18] Removing multimehtod dependency in perisistent.heaps
---
basis/persistent/heaps/heaps.factor | 11 ++++++-----
1 file changed, 6 insertions(+), 5 deletions(-)
diff --git a/basis/persistent/heaps/heaps.factor b/basis/persistent/heaps/heaps.factor
index 81c9959f84..6381b91dc3 100644
--- a/basis/persistent/heaps/heaps.factor
+++ b/basis/persistent/heaps/heaps.factor
@@ -1,4 +1,4 @@
-USING: kernel accessors multi-methods locals combinators math arrays
+USING: kernel accessors locals combinators math arrays
assocs namespaces sequences ;
IN: persistent.heaps
! These are minheaps
@@ -36,14 +36,15 @@ PRIVATE>
GENERIC: sift-down ( value prio left right -- heap )
-METHOD: sift-down { empty-heap empty-heap } <branch> ;
-
-METHOD: sift-down { singleton-heap empty-heap }
+: singleton-sift-down ( value prio singleton empty -- heap )
3dup drop prio>> <= [ <branch> ] [
drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip
<singleton-heap> <persistent-heap> <branch>
] if ;
+M: empty-heap sift-down
+ over singleton-heap? [ singleton-sift-down ] [ <branch> ] if ;
+
:: reroot-left ( value prio left right -- heap )
left value>> left prio>>
value prio left left>> left right>> sift-down
@@ -54,7 +55,7 @@ METHOD: sift-down { singleton-heap empty-heap }
value prio right left>> right right>> sift-down
<branch> ;
-METHOD: sift-down { branch branch }
+M: branch sift-down ! both arguments are branches
3dup [ prio>> <= ] both-with? [ <branch> ] [
2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if
] if ;
From 510da880a424bb11c39ce455013a8b3eb3229fc7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 7 Sep 2008 18:05:45 -0500
Subject: [PATCH 03/18] Tweak prettyprinting
---
basis/logging/logging.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor
index 7cc2f3d8d9..aa4e46fad1 100755
--- a/basis/logging/logging.factor
+++ b/basis/logging/logging.factor
@@ -46,6 +46,7 @@ SYMBOL: log-service
dup array? [ dup length 1 = [ first ] when ] when
dup string? [
[
+ boa-tuples? on
string-limit? off
1 line-limit set
3 nesting-limit set
From 41c70afd8689d3aaa16449ce76051116f444dcbe Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 7 Sep 2008 18:05:58 -0500
Subject: [PATCH 04/18] Fix typo
---
extra/webapps/wiki/initial-content/Farkup.txt | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/webapps/wiki/initial-content/Farkup.txt b/extra/webapps/wiki/initial-content/Farkup.txt
index 9c1fb5e7db..b8de408588 100644
--- a/extra/webapps/wiki/initial-content/Farkup.txt
+++ b/extra/webapps/wiki/initial-content/Farkup.txt
@@ -34,7 +34,7 @@ CAN HAS STDIO?
VISIBLE "HAI WORLD!"
KTHXBYE}]
-There is syntax highlighting various languages, too:
+There is syntax highlighting for various languages, too:
[factor{PEG: parse-request-line ( string -- triple )
#! Triple is { method url version }
From e8f739401b45e041b06a3cfe8559605283db0c6d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 7 Sep 2008 18:06:20 -0500
Subject: [PATCH 05/18] Some improvements to farkup link handling
---
basis/farkup/farkup-tests.factor | 18 ++++++++++++-----
basis/farkup/farkup.factor | 31 +++++++++++++++--------------
basis/html/elements/elements.factor | 3 +++
3 files changed, 32 insertions(+), 20 deletions(-)
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index 0f96934798..0280c1a08d 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -1,8 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: farkup kernel peg peg.ebnf tools.test ;
+USING: farkup kernel peg peg.ebnf tools.test namespaces ;
IN: farkup.tests
+[ "Baz" ] [ "Foo/Bar/Baz" simple-link-title ] unit-test
+[ "Baz" ] [ "Baz" simple-link-title ] unit-test
+
[ ] [
"abcd-*strong*\nasdifj\nweouh23ouh23"
"paragraph" \ farkup rule parse drop
@@ -81,10 +84,15 @@ IN: farkup.tests
[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
-[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
-[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
-[ "<p><a href=\"lol.com\">lol.com</a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
-[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
+[ "<p><img src='lol.jpg'/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
+[ "<p><img src='lol.jpg' alt='teh lol'/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
+[ "<p><a href='http://lol.com'>http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
+[ "<p><a href='http://lol.com'>haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
+[ "<p><a href='Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
+
+"/wiki/view/" relative-link-prefix [
+ [ "<p><a href='/wiki/view/Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
+] with-variable
[ ] [ "[{}]" convert-farkup drop ] unit-test
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index c029423714..7005232517 100644
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -28,6 +28,12 @@ TUPLE: link href text ;
TUPLE: image href text ;
TUPLE: code mode string ;
+: absolute-url? ( string -- ? )
+ { "http://" "https://" "ftp://" } [ head? ] with contains? ;
+
+: simple-link-title ( string -- string' )
+ dup absolute-url? [ "/" last-split1 swap or ] unless ;
+
EBNF: farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
2nl = nl nl
@@ -67,7 +73,7 @@ image-link = "[[image:" (!("|") .)+ "|" (!("]]").)+ "]]"
=> [[ second >string f image boa ]]
simple-link = "[[" (!("|]" | "]]") .)+ "]]"
- => [[ second >string dup link boa ]]
+ => [[ second >string dup simple-link-title link boa ]]
labelled-link = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
=> [[ [ second >string ] [ fourth >string ] bi link boa ]]
@@ -119,31 +125,26 @@ stand-alone
{ [ dup empty? ] [ drop invalid-url ] }
{ [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
- { [ CHAR: : over member? ] [
- dup { "http://" "https://" "ftp://" } [ head? ] with contains?
- [ drop invalid-url ] unless
- ] }
+ { [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
[ relative-link-prefix get prepend ]
} cond ;
: escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ;
-: write-link ( text href -- )
+: write-link ( href text -- )
escape-link
- "<a" write
- " href=\"" write write "\"" write
- link-no-follow? get [ " nofollow=\"true\"" write ] when
- ">" write write "</a>" write ;
+ [ <a =href link-no-follow? get [ "true" =nofollow ] when a> ]
+ [ write </a> ]
+ bi* ;
: write-image-link ( href text -- )
disable-images? get [
- 2drop "<strong>Images are not allowed</strong>" write
+ 2drop
+ <strong> "Images are not allowed" write </strong>
] [
escape-link
- >r "<img src=\"" write write "\"" write r>
- [ " alt=\"" write write "\"" write ] unless-empty
- "/>" write
+ [ <img =src ] [ [ =alt ] unless-empty img/> ] bi*
] if ;
: render-code ( string mode -- string' )
@@ -170,7 +171,7 @@ M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
-M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
+M: link write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-link ;
M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
M: table-row write-farkup ( obj -- )
diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor
index 35e01227b5..89f8b01a19 100644
--- a/basis/html/elements/elements.factor
+++ b/basis/html/elements/elements.factor
@@ -142,6 +142,7 @@ SYMBOL: html
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
"script" "div" "span" "select" "option" "style" "input"
+ "strong"
] [ define-closed-html-word ] each
! Define some open HTML tags
@@ -160,6 +161,8 @@ SYMBOL: html
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple" "checked"
+ "summary" "cellspacing" "align" "scope" "abbr"
+ "nofollow" "alt"
] [ define-attribute-word ] each
>>
From 17bfe2583ec9ed3e84f17cff8260de0768bf47e0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 7 Sep 2008 18:20:31 -0500
Subject: [PATCH 06/18] Document farkup
---
basis/farkup/farkup-docs.factor | 51 +++++++++++++++++++++++++++++++--
basis/farkup/farkup.factor | 51 +++++++++++++++++----------------
2 files changed, 75 insertions(+), 27 deletions(-)
diff --git a/basis/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor
index b2b662db82..f2d53d2362 100644
--- a/basis/farkup/farkup-docs.factor
+++ b/basis/farkup/farkup-docs.factor
@@ -1,6 +1,51 @@
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax strings io ;
IN: farkup
HELP: convert-farkup
-{ $values { "string" "a string" } { "string'" "a string" } }
-{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ;
+{ $values { "string" string } { "string'" string } }
+{ $description "Parse a Farkup string and convert it to an HTML string." } ;
+
+HELP: write-farkup
+{ $values { "string" string } }
+{ $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ;
+
+HELP: farkup ( string -- farkup )
+{ $values { "string" string } { "farkup" "a Farkup syntax tree node" } }
+{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
+
+HELP: (write-farkup)
+{ $values { "farkup" "a Farkup syntax tree node" } }
+{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
+
+ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
+"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
+{ $subsection heading1 }
+{ $subsection heading2 }
+{ $subsection heading3 }
+{ $subsection heading4 }
+{ $subsection strong }
+{ $subsection emphasis }
+{ $subsection superscript }
+{ $subsection subscript }
+{ $subsection inline-code }
+{ $subsection paragraph }
+{ $subsection list-item }
+{ $subsection list }
+{ $subsection table }
+{ $subsection table-row }
+{ $subsection link }
+{ $subsection image }
+{ $subsection code } ;
+
+ARTICLE: "farkup" "Farkup"
+"The " { $vocab-link "farkup" } " vocabulary implements Farkup (Factor mARKUP), a simple markup language. Farkup was loosely based on the markup languages employed by MediaWiki and " { $url "http://reddit.com" } "."
+$nl
+"The main entry points for converting Farkup to HTML:"
+{ $subsection convert-farkup }
+{ $subsection write-farkup }
+"The syntax tree of a piece of Farkup can also be inspected and modified:"
+{ $subsection farkup }
+{ $subsection (write-farkup) }
+{ $subsection "farkup-ast" } ;
+
+ABOUT: "farkup"
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index 7005232517..154ab0db00 100644
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -155,32 +155,35 @@ stand-alone
</pre>
] with-string-writer write ;
-GENERIC: write-farkup ( obj -- )
+GENERIC: (write-farkup) ( farkup -- )
: <foo.> ( string -- ) <foo> write ;
: </foo.> ( string -- ) </foo> write ;
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
-M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
-M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
-M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
-M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
-M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
-M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
-M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
-M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
-M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
-M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
-M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
-M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
-M: link write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-link ;
-M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
-M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
-M: table-row write-farkup ( obj -- )
- obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
-M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
-M: fixnum write-farkup ( obj -- ) write1 ;
-M: string write-farkup ( obj -- ) write ;
-M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
-M: f write-farkup ( obj -- ) drop ;
+M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ;
+M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ;
+M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ;
+M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ;
+M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ;
+M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ;
+M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ;
+M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ;
+M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ;
+M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ;
+M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ;
+M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ;
+M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ;
+M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
+M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
+M: table-row (write-farkup) ( obj -- )
+ obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
+M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ;
+M: fixnum (write-farkup) ( obj -- ) write1 ;
+M: string (write-farkup) ( obj -- ) write ;
+M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ;
+M: f (write-farkup) ( obj -- ) drop ;
+
+: write-farkup ( string -- )
+ farkup (write-farkup) ;
: convert-farkup ( string -- string' )
- farkup [ write-farkup ] with-string-writer ;
+ farkup [ (write-farkup) ] with-string-writer ;
From a604a2f30b7bf0464ba3f9be05f9ccfea317960a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 7 Sep 2008 18:57:09 -0500
Subject: [PATCH 07/18] Minor simplification
---
basis/html/components/components.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor
index b6b7f22b1d..0969dd7ef3 100644
--- a/basis/html/components/components.factor
+++ b/basis/html/components/components.factor
@@ -156,7 +156,7 @@ M: farkup render*
[
[ no-follow>> [ string>boolean link-no-follow? set ] when* ]
[ disable-images>> [ string>boolean disable-images? set ] when* ] bi
- drop string-lines "\n" join convert-farkup write
+ drop string-lines "\n" join write-farkup
] with-scope ;
! Inspector component
From 9f342ad69763232e674e682316ef3540955c8ae0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 7 Sep 2008 18:57:14 -0500
Subject: [PATCH 08/18] Fix init-wiki
---
.../wiki/initial-content/Front Page.txt | 4 +---
.../wiki/initial-content/Wiki Help.txt | 5 +++++
extra/webapps/wiki/wiki.factor | 22 ++++++++++++-------
3 files changed, 20 insertions(+), 11 deletions(-)
create mode 100644 extra/webapps/wiki/initial-content/Wiki Help.txt
diff --git a/extra/webapps/wiki/initial-content/Front Page.txt b/extra/webapps/wiki/initial-content/Front Page.txt
index 37351eed38..2f390f7349 100644
--- a/extra/webapps/wiki/initial-content/Front Page.txt
+++ b/extra/webapps/wiki/initial-content/Front Page.txt
@@ -1,5 +1,3 @@
Congratulations, you are now running your very own Wiki.
-You can now click *Edit* below and begin editing the content of the [[Front Page]]. This Wiki uses [[Farkup]] to mark up text.
-
-Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
+You can now click *Edit* below and begin editing the content of the [[Front Page]]. More information at [[Wiki Help]].
diff --git a/extra/webapps/wiki/initial-content/Wiki Help.txt b/extra/webapps/wiki/initial-content/Wiki Help.txt
new file mode 100644
index 0000000000..9c65876377
--- /dev/null
+++ b/extra/webapps/wiki/initial-content/Wiki Help.txt
@@ -0,0 +1,5 @@
+This Wiki uses [[Farkup]] to mark up text.
+
+Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
+
+The Wiki supports hierarchical article organization. You can separate components in article names with slashes, and Wiki links only display the last component. An example: [[Factor/Features]].
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 623c8aabe5..380f41cf97 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -89,6 +89,9 @@ M: revision feed-entry-url id>> revision-url ;
<article> select-tuple
dup [ revision>> <revision> select-tuple ] when ;
+: init-relative-link-prefix ( -- )
+ URL" $wiki/view/" adjust-url present relative-link-prefix set ;
+
: <view-article-action> ( -- action )
<action>
@@ -96,6 +99,7 @@ M: revision feed-entry-url id>> revision-url ;
[
validate-title
+ init-relative-link-prefix
] >>init
[
@@ -118,7 +122,7 @@ M: revision feed-entry-url id>> revision-url ;
validate-integer-id
"id" value <revision>
select-tuple from-object
- URL" $wiki/view/" adjust-url present relative-link-prefix set
+ init-relative-link-prefix
] >>init
{ wiki "view" } >>template
@@ -370,11 +374,13 @@ M: revision feed-entry-url id>> revision-url ;
: init-wiki ( -- )
"resource:extra/webapps/wiki/initial-content" directory* keys
[
- [ ascii file-contents ] [ file-name "." split1 drop ] bi
- f <revision>
- swap >>title
- swap >>content
- "slava" >>author
- now >>date
- add-revision
+ dup file-name ".txt" ?tail [
+ swap ascii file-contents
+ f <revision>
+ swap >>content
+ swap >>title
+ "slava" >>author
+ now >>date
+ add-revision
+ ] [ 2drop ] if
] each ;
From 0691bde5446d346a7234d2119d7859a9fbf2f6fd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 7 Sep 2008 21:32:06 -0500
Subject: [PATCH 09/18] Tweak deploy tests to take less time
---
basis/tools/deploy/backend/backend.factor | 2 +-
basis/tools/deploy/deploy-tests.factor | 8 ++++----
basis/tools/deploy/test/1/deploy.factor | 16 ++++++++--------
basis/tools/deploy/test/2/deploy.factor | 14 +++++++-------
basis/tools/deploy/test/3/deploy.factor | 14 +++++++-------
basis/tools/deploy/test/4/deploy.factor | 14 +++++++-------
basis/tools/deploy/test/5/deploy.factor | 14 +++++++-------
7 files changed, 41 insertions(+), 41 deletions(-)
diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor
index 723f9461a8..ae4f6a8d62 100755
--- a/basis/tools/deploy/backend/backend.factor
+++ b/basis/tools/deploy/backend/backend.factor
@@ -42,9 +42,9 @@ IN: tools.deploy.backend
: bootstrap-profile ( -- profile )
{
- { "threads" deploy-threads? }
{ "math" deploy-math? }
{ "compiler" deploy-compiler? }
+ { "threads" deploy-threads? }
{ "ui" deploy-ui? }
{ "random" deploy-random? }
} [ nip get ] assoc-filter keys
diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor
index 3d007e566c..acee098b8f 100755
--- a/basis/tools/deploy/deploy-tests.factor
+++ b/basis/tools/deploy/deploy-tests.factor
@@ -26,7 +26,7 @@ namespaces continuations layouts accessors ;
[ t ] [ 1300000 small-enough? ] unit-test
-[ "staging.threads-math-compiler-ui-strip.image" ] [
+[ "staging.math-compiler-threads-ui-strip.image" ] [
"hello-ui" deploy-config
[ bootstrap-profile staging-image-name file-name ] bind
] unit-test
@@ -39,9 +39,9 @@ namespaces continuations layouts accessors ;
!
! [ t ] [ 1500000 small-enough? ] unit-test
!
-! [ ] [ "bunny" shake-and-bake ] unit-test
-!
-! [ t ] [ 2500000 small-enough? ] unit-test
+[ ] [ "bunny" shake-and-bake ] unit-test
+
+[ t ] [ 2500000 small-enough? ] unit-test
{
"tools.deploy.test.1"
diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor
index 098e99719e..6846b3b53e 100755
--- a/basis/tools/deploy/test/1/deploy.factor
+++ b/basis/tools/deploy/test/1/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-c-types? f }
- { deploy-name "tools.deploy.test.1" }
- { deploy-io 2 }
- { deploy-random? f }
- { deploy-math? t }
- { deploy-compiler? t }
- { deploy-reflection 2 }
- { "stop-after-last-window?" t }
{ deploy-threads? t }
+ { deploy-random? f }
+ { deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
+ { deploy-math? t }
+ { deploy-io 2 }
+ { deploy-name "tools.deploy.test.1" }
+ { deploy-compiler? t }
+ { deploy-reflection 1 }
+ { "stop-after-last-window?" t }
}
diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor
index c6f46eede6..4c34a77b66 100755
--- a/basis/tools/deploy/test/2/deploy.factor
+++ b/basis/tools/deploy/test/2/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-io 2 }
- { deploy-ui? f }
{ deploy-threads? t }
+ { deploy-random? f }
{ deploy-c-types? f }
+ { deploy-ui? f }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { deploy-math? t }
+ { deploy-io 2 }
{ deploy-name "tools.deploy.test.2" }
{ deploy-compiler? t }
- { deploy-word-props? f }
- { deploy-reflection 2 }
- { deploy-word-defs? f }
+ { deploy-reflection 1 }
{ "stop-after-last-window?" t }
- { deploy-random? f }
- { deploy-math? t }
}
diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor
index 5f45b87e0d..84347164b6 100755
--- a/basis/tools/deploy/test/3/deploy.factor
+++ b/basis/tools/deploy/test/3/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-io 3 }
- { deploy-ui? f }
{ deploy-threads? t }
+ { deploy-random? f }
{ deploy-c-types? f }
+ { deploy-ui? f }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { deploy-math? t }
+ { deploy-io 3 }
{ deploy-name "tools.deploy.test.3" }
{ deploy-compiler? t }
- { deploy-word-props? f }
- { deploy-reflection 2 }
- { deploy-word-defs? f }
+ { deploy-reflection 1 }
{ "stop-after-last-window?" t }
- { deploy-random? f }
- { deploy-math? t }
}
diff --git a/basis/tools/deploy/test/4/deploy.factor b/basis/tools/deploy/test/4/deploy.factor
index ea899e64c0..b1a6736bde 100644
--- a/basis/tools/deploy/test/4/deploy.factor
+++ b/basis/tools/deploy/test/4/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-io 2 }
- { deploy-ui? f }
{ deploy-threads? t }
+ { deploy-random? f }
{ deploy-c-types? f }
+ { deploy-ui? f }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { deploy-math? t }
+ { deploy-io 2 }
{ deploy-name "tools.deploy.test.4" }
{ deploy-compiler? t }
- { deploy-word-props? f }
- { deploy-reflection 2 }
- { deploy-word-defs? f }
+ { deploy-reflection 1 }
{ "stop-after-last-window?" t }
- { deploy-random? f }
- { deploy-math? t }
}
diff --git a/basis/tools/deploy/test/5/deploy.factor b/basis/tools/deploy/test/5/deploy.factor
index 797116e09b..f5f8bc0352 100644
--- a/basis/tools/deploy/test/5/deploy.factor
+++ b/basis/tools/deploy/test/5/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-io 3 }
- { deploy-ui? f }
{ deploy-threads? t }
+ { deploy-random? f }
{ deploy-c-types? f }
+ { deploy-ui? f }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { deploy-math? t }
+ { deploy-io 3 }
{ deploy-name "tools.deploy.test.5" }
{ deploy-compiler? t }
- { deploy-word-props? f }
- { deploy-reflection 2 }
- { deploy-word-defs? f }
+ { deploy-reflection 1 }
{ "stop-after-last-window?" t }
- { deploy-random? f }
- { deploy-math? t }
}
From 8fb26cd759c6fbb7729c6ebb54c8b86ac9a0c224 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 7 Sep 2008 21:32:15 -0500
Subject: [PATCH 10/18] Tweak stage2
---
basis/bootstrap/stage2.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor
index 2388d7b8f0..58ea725d1e 100755
--- a/basis/bootstrap/stage2.factor
+++ b/basis/bootstrap/stage2.factor
@@ -50,7 +50,7 @@ SYMBOL: bootstrap-time
default-image-name "output-image" set-global
- "threads math compiler help io random tools ui ui.tools unicode handbook" "include" set-global
+ "math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global
"" "exclude" set-global
parse-command-line
From 5cbd1fe8fc6ac5fc0d0eb70eb8462d4383538d5e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 8 Sep 2008 01:09:52 -0500
Subject: [PATCH 11/18] Remove unnecessary dependency on peg.expr
---
extra/lisp/parser/parser.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
index 428e1221da..1b14f5bb34 100644
--- a/extra/lisp/parser/parser.factor
+++ b/extra/lisp/parser/parser.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings
+USING: kernel peg peg.ebnf math.parser sequences arrays strings
combinators.lib math fry accessors lists combinators.short-circuit ;
IN: lisp.parser
From 59623414b6bac96d5c5015c4e55f711992b043cd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 8 Sep 2008 01:10:12 -0500
Subject: [PATCH 12/18] Fix bug spotted by Ed
---
basis/http/http.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/http/http.factor b/basis/http/http.factor
index e450631d94..03cca05ff3 100755
--- a/basis/http/http.factor
+++ b/basis/http/http.factor
@@ -113,7 +113,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
{ [ dup real? ] [ number>string ] }
[ ]
} cond
- check-cookie-string "=" swap check-cookie-string 3append ,
+ [ check-cookie-string ] bi@ "=" swap 3append ,
]
} case ;
From 63d45679c9929bd1cb79c4e01451dec6acf8dcab Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 8 Sep 2008 01:10:25 -0500
Subject: [PATCH 13/18] Better logging
---
basis/io/servers/connection/connection.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor
index 1ed83956c3..f789f7b114 100755
--- a/basis/io/servers/connection/connection.factor
+++ b/basis/io/servers/connection/connection.factor
@@ -73,7 +73,7 @@ M: threaded-server handle-client* handler>> call ;
] with-stream ;
: thread-name ( server-name addrspec -- string )
- unparse " connection from " swap 3append ;
+ unparse-short " connection from " swap 3append ;
: accept-connection ( threaded-server -- )
[ accept ] [ addr>> ] bi
From 7a9806495f9a24a0d044829268b22512041f0711 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 8 Sep 2008 01:11:09 -0500
Subject: [PATCH 14/18] Major Chloe overhaul: compiled templatess
---
basis/furnace/auth/auth.factor | 27 ++--
.../features/registration/registration.factor | 3 +-
.../chloe-tags/chloe-tags-tests.factor | 19 +++
basis/furnace/chloe-tags/chloe-tags.factor | 121 +++++++++++++++
.../conversations/conversations.factor | 3 +-
basis/furnace/furnace.factor | 141 +++---------------
basis/furnace/redirection/redirection.factor | 18 ++-
basis/html/templates/chloe/chloe-tests.factor | 17 +--
basis/html/templates/chloe/chloe.factor | 132 +++++-----------
.../templates/chloe/compiler/compiler.factor | 127 ++++++++++++++++
.../chloe/components/components.factor | 35 +++++
.../html/templates/chloe/syntax/syntax.factor | 29 +---
basis/xml/writer/writer.factor | 7 +-
13 files changed, 394 insertions(+), 285 deletions(-)
create mode 100644 basis/furnace/chloe-tags/chloe-tags-tests.factor
create mode 100644 basis/furnace/chloe-tags/chloe-tags.factor
create mode 100644 basis/html/templates/chloe/compiler/compiler.factor
create mode 100644 basis/html/templates/chloe/components/components.factor
diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor
index 4487759719..54e936a313 100755
--- a/basis/furnace/auth/auth.factor
+++ b/basis/furnace/auth/auth.factor
@@ -134,22 +134,21 @@ TUPLE: protected < filter-responder description capabilities ;
swap >>responder ;
: have-capabilities? ( capabilities -- ? )
- logged-in-user get {
- { [ dup not ] [ 2drop f ] }
- { [ dup deleted>> 1 = ] [ 2drop f ] }
- [ capabilities>> subset? ]
- } cond ;
+ realm get secure>> secure-connection? not and [ drop f ] [
+ logged-in-user get {
+ { [ dup not ] [ 2drop f ] }
+ { [ dup deleted>> 1 = ] [ 2drop f ] }
+ [ capabilities>> subset? ]
+ } cond
+ ] if ;
M: protected call-responder* ( path responder -- response )
- '[
- , ,
- dup protected set
- dup capabilities>> have-capabilities?
- [ call-next-method ] [
- [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
- realm get login-required*
- ] if
- ] if-secure-realm ;
+ dup protected set
+ dup capabilities>> have-capabilities?
+ [ call-next-method ] [
+ [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
+ realm get login-required*
+ ] if ;
: <auth-boilerplate> ( responder -- responder' )
<boilerplate> { realm "boilerplate" } >>template ;
diff --git a/basis/furnace/auth/features/registration/registration.factor b/basis/furnace/auth/features/registration/registration.factor
index 20a48d07d2..da58e2b2ed 100644
--- a/basis/furnace/auth/features/registration/registration.factor
+++ b/basis/furnace/auth/features/registration/registration.factor
@@ -36,7 +36,8 @@ IN: furnace.auth.features.registration
URL" $realm" <redirect>
] >>submit
- <auth-boilerplate> ;
+ <auth-boilerplate>
+ <secure-realm-only> ;
: allow-registration ( login -- login )
<register-action> "register" add-responder ;
diff --git a/basis/furnace/chloe-tags/chloe-tags-tests.factor b/basis/furnace/chloe-tags/chloe-tags-tests.factor
new file mode 100644
index 0000000000..f172ce36f6
--- /dev/null
+++ b/basis/furnace/chloe-tags/chloe-tags-tests.factor
@@ -0,0 +1,19 @@
+USING: html.forms furnace.chloe-tags tools.test ;
+IN: furnace.chloe-tags.tests
+
+[ f ] [ f parse-query-attr ] unit-test
+
+[ f ] [ "" parse-query-attr ] unit-test
+
+[ H{ { "a" "b" } } ] [
+ begin-form
+ "b" "a" set-value
+ "a" parse-query-attr
+] unit-test
+
+[ H{ { "a" "b" } { "c" "d" } } ] [
+ begin-form
+ "b" "a" set-value
+ "d" "c" set-value
+ "a,c" parse-query-attr
+] unit-test
diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor
new file mode 100644
index 0000000000..22eddd77a2
--- /dev/null
+++ b/basis/furnace/chloe-tags/chloe-tags.factor
@@ -0,0 +1,121 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel combinators assocs
+namespaces sequences splitting words
+fry urls multiline present qualified
+xml
+xml.data
+xml.entities
+xml.writer
+xml.utilities
+html.components
+html.elements
+html.forms
+html.templates
+html.templates.chloe
+html.templates.chloe.compiler
+html.templates.chloe.syntax
+http
+http.server
+http.server.redirection
+http.server.responses
+furnace ;
+QUALIFIED-WITH: assocs a
+IN: furnace.chloe-tags
+
+! Chloe tags
+: parse-query-attr ( string -- assoc )
+ [ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ;
+
+: a-url-path ( href rest -- string )
+ dup [ value ] when
+ [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
+
+: a-url ( href rest query value-name -- url )
+ dup [ >r 3drop r> value ] [
+ drop
+ <url>
+ swap parse-query-attr >>query
+ -rot a-url-path >>path
+ adjust-url relative-to-request
+ ] if ;
+
+: compile-a-url ( tag -- )
+ {
+ [ "href" required-attr compile-attr ]
+ [ "rest" optional-attr compile-attr ]
+ [ "query" optional-attr compile-attr ]
+ [ "value" optional-attr compile-attr ]
+ } cleave [ a-url ] [code] ;
+
+CHLOE: atom
+ [ compile-children>string ] [ compile-a-url ] bi
+ [ add-atom-feed ] [code] ;
+
+CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
+
+: compile-link-attrs ( tag -- )
+ #! Side-effects current namespace.
+ attrs>> '[ [ , _ link-attr ] each-responder ] [code] ;
+
+: a-start-tag ( tag -- )
+ [ compile-link-attrs ] [ compile-a-url ] bi
+ [ <a =href a> ] [code] ;
+
+: a-end-tag ( tag -- )
+ drop [ </a> ] [code] ;
+
+CHLOE: a [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri ;
+
+: compile-hidden-form-fields ( for -- )
+ '[
+ , [ "," split [ hidden render ] each ] when*
+ nested-forms get " " join f like nested-forms-key hidden-form-field
+ [ modify-form ] each-responder
+ ] [code] ;
+
+: compile-form-attrs ( method action attrs -- )
+ [ <form ] [code]
+ [ compile-attr [ =method ] [code] ]
+ [ compile-attr [ resolve-base-path =action ] [code] ]
+ [ compile-attrs ]
+ tri*
+ [ form> ] [code] ;
+
+: form-start-tag ( tag -- )
+ [
+ [ "method" optional-attr "post" or ]
+ [ "action" required-attr ]
+ [ attrs>> non-chloe-attrs-only ] tri
+ compile-form-attrs
+ ]
+ [ "for" optional-attr compile-hidden-form-fields ] bi ;
+
+: form-end-tag ( tag -- )
+ drop [ </form> ] [code] ;
+
+CHLOE: form
+ {
+ [ compile-link-attrs ]
+ [ form-start-tag ]
+ [ compile-children ]
+ [ form-end-tag ]
+ } cleave ;
+
+STRING: button-tag-markup
+<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
+ <button type="submit"></button>
+</t:form>
+;
+
+: add-tag-attrs ( attrs tag -- )
+ attrs>> swap update ;
+
+CHLOE: button
+ button-tag-markup string>xml body>>
+ {
+ [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
+ [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
+ [ [ children>> ] dip "button" tag-named (>>children) ]
+ [ nip ]
+ } 2cleave compile-chloe-tag ;
diff --git a/basis/furnace/conversations/conversations.factor b/basis/furnace/conversations/conversations.factor
index 7216978110..26b62f9b07 100644
--- a/basis/furnace/conversations/conversations.factor
+++ b/basis/furnace/conversations/conversations.factor
@@ -130,7 +130,8 @@ M: conversations call-responder*
over post-data>> >>post-data
over url>> >>url
] change
- url>> path>> split-path
+ [ url>> url set ]
+ [ url>> path>> split-path ] bi
conversations get responder>> call-responder ;
\ end-aside-post DEBUG add-input-logging
diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor
index 9dfaa49028..b90587fba8 100644
--- a/basis/furnace/furnace.factor
+++ b/basis/furnace/furnace.factor
@@ -1,30 +1,14 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel combinators assocs
-continuations namespaces sequences splitting words
-vocabs.loader classes strings
-fry urls multiline present
-xml
-xml.data
-xml.entities
-xml.writer
-html.components
-html.elements
-html.forms
-html.templates
-html.templates.chloe
-html.templates.chloe.syntax
-http
-http.server
-http.server.redirection
-http.server.responses
-qualified ;
-QUALIFIED-WITH: assocs a
-EXCLUDE: xml.utilities => children>string ;
+USING: namespaces assocs sequences kernel classes splitting
+vocabs.loader accessors strings combinators arrays
+continuations present fry
+urls html.elements
+http http.server http.server.redirection ;
IN: furnace
: nested-responders ( -- seq )
- responder-nesting get a:values ;
+ responder-nesting get values ;
: each-responder ( quot -- )
nested-responders swap each ; inline
@@ -63,10 +47,25 @@ M: url adjust-url
M: string adjust-url ;
+GENERIC: link-attr ( tag responder -- )
+
+M: object link-attr 2drop ;
+
GENERIC: modify-form ( responder -- )
M: object modify-form drop ;
+: hidden-form-field ( value name -- )
+ over [
+ <input
+ "hidden" =type
+ =name
+ present =value
+ input/>
+ ] [ 2drop ] if ;
+
+: nested-forms-key "__n" ;
+
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ url>> query>> ] }
@@ -110,98 +109,4 @@ SYMBOL: exit-continuation
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
-! Chloe tags
-: parse-query-attr ( string -- assoc )
- [ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ;
-
-: a-url-path ( tag -- string )
- [ "href" required-attr ]
- [ "rest" optional-attr dup [ value ] when ] bi
- [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
-
-: a-url ( tag -- url )
- dup "value" optional-attr
- [ value ] [
- <url>
- swap
- [ a-url-path >>path ]
- [ "query" optional-attr parse-query-attr >>query ]
- bi
- adjust-url relative-to-request
- ] ?if ;
-
-CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
-
-CHLOE: write-atom drop write-atom-feeds ;
-
-GENERIC: link-attr ( tag responder -- )
-
-M: object link-attr 2drop ;
-
-: link-attrs ( tag -- )
- #! Side-effects current namespace.
- '[ , _ link-attr ] each-responder ;
-
-: a-start-tag ( tag -- )
- [ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
-
-CHLOE: a
- [ a-start-tag ]
- [ process-tag-children ]
- [ drop </a> ]
- tri ;
-
-: hidden-form-field ( value name -- )
- over [
- <input
- "hidden" =type
- =name
- present =value
- input/>
- ] [ 2drop ] if ;
-
-: nested-forms-key "__n" ;
-
-: form-magic ( tag -- )
- [ modify-form ] each-responder
- nested-forms get " " join f like nested-forms-key hidden-form-field
- "for" optional-attr [ "," split [ hidden render ] each ] when* ;
-
-: form-start-tag ( tag -- )
- [
- [
- <form
- {
- [ link-attrs ]
- [ "method" optional-attr "post" or =method ]
- [ "action" required-attr resolve-base-path =action ]
- [ attrs>> non-chloe-attrs-only print-attrs ]
- } cleave
- form>
- ]
- [ form-magic ] bi
- ] with-scope ;
-
-CHLOE: form
- [ form-start-tag ]
- [ process-tag-children ]
- [ drop </form> ]
- tri ;
-
-STRING: button-tag-markup
-<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
- <button type="submit"></button>
-</t:form>
-;
-
-: add-tag-attrs ( attrs tag -- )
- attrs>> swap update ;
-
-CHLOE: button
- button-tag-markup string>xml body>>
- {
- [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
- [ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
- [ [ children>string 1array ] dip "button" tag-named (>>children) ]
- [ nip ]
- } 2cleave process-chloe-tag ;
+"furnace.chloe-tags" require
diff --git a/basis/furnace/redirection/redirection.factor b/basis/furnace/redirection/redirection.factor
index 83941cd08f..942cafd21a 100644
--- a/basis/furnace/redirection/redirection.factor
+++ b/basis/furnace/redirection/redirection.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces fry
-io.servers.connection urls
-http http.server http.server.redirection http.server.filters
-furnace ;
+io.servers.connection urls http http.server
+http.server.redirection http.server.responses
+http.server.filters furnace ;
IN: furnace.redirection
: <redirect> ( url -- response )
@@ -32,10 +32,14 @@ TUPLE: secure-only < filter-responder ;
C: <secure-only> secure-only
-: if-secure ( quot -- )
- >r url get protocol>> "http" =
- [ url get <secure-redirect> ]
- r> if ; inline
+: secure-connection? ( -- ? ) url get protocol>> "https" = ;
+
+: if-secure ( quot -- response )
+ {
+ { [ secure-connection? ] [ call ] }
+ { [ request get method>> "POST" = ] [ drop <400> ] }
+ [ drop url get <secure-redirect> ]
+ } cond ; inline
M: secure-only call-responder*
'[ , , call-next-method ] if-secure ;
diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor
index 0305b738af..9eb4a5709c 100644
--- a/basis/html/templates/chloe/chloe-tests.factor
+++ b/basis/html/templates/chloe/chloe-tests.factor
@@ -4,22 +4,7 @@ namespaces xml html.components html.forms
splitting unicode.categories furnace accessors ;
IN: html.templates.chloe.tests
-[ f ] [ f parse-query-attr ] unit-test
-
-[ f ] [ "" parse-query-attr ] unit-test
-
-[ H{ { "a" "b" } } ] [
- begin-form
- "b" "a" set-value
- "a" parse-query-attr
-] unit-test
-
-[ H{ { "a" "b" } { "c" "d" } } ] [
- begin-form
- "b" "a" set-value
- "d" "c" set-value
- "a,c" parse-query-attr
-] unit-test
+reset-templates
: run-template
with-string-writer [ "\r\n\t" member? not ] filter
diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor
index f40fc43b32..a03e42bb37 100644
--- a/basis/html/templates/chloe/chloe.factor
+++ b/basis/html/templates/chloe/chloe.factor
@@ -1,78 +1,53 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences combinators kernel namespaces
-classes.tuple assocs splitting words arrays memoize
-io io.files io.encodings.utf8 io.streams.string
-unicode.case mirrors fry math urls present
-multiline xml xml.data xml.writer xml.utilities
+USING: accessors kernel sequences combinators kernel fry
+namespaces classes.tuple assocs splitting words arrays memoize
+io io.files io.encodings.utf8 io.streams.string unicode.case
+mirrors math urls present multiline quotations xml xml.data
html.forms
html.elements
html.components
html.templates
+html.templates.chloe.compiler
+html.templates.chloe.components
html.templates.chloe.syntax ;
IN: html.templates.chloe
! Chloe is Ed's favorite web designer
-SYMBOL: tag-stack
-
TUPLE: chloe path ;
C: <chloe> chloe
-DEFER: process-template
+CHLOE: chloe compile-children ;
-: chloe-attrs-only ( assoc -- assoc' )
- [ drop url>> chloe-ns = ] assoc-filter ;
-
-: non-chloe-attrs-only ( assoc -- assoc' )
- [ drop url>> chloe-ns = not ] assoc-filter ;
-
-: chloe-tag? ( tag -- ? )
- dup xml? [ body>> ] when
- {
- { [ dup tag? not ] [ f ] }
- { [ dup url>> chloe-ns = not ] [ f ] }
- [ t ]
- } cond nip ;
-
-: process-tag-children ( tag -- )
- [ process-template ] each ;
-
-CHLOE: chloe process-tag-children ;
-
-: children>string ( tag -- string )
- [ process-tag-children ] with-string-writer ;
-
-CHLOE: title children>string set-title ;
+CHLOE: title compile-children>string [ set-title ] [code] ;
CHLOE: write-title
drop
"head" tag-stack get member?
"title" tag-stack get member? not and
- [ <title> write-title </title> ] [ write-title ] if ;
+ [ <title> write-title </title> ] [ write-title ] ? [code] ;
CHLOE: style
- dup "include" optional-attr dup [
- swap children>string empty? [
- "style tag cannot have both an include attribute and a body" throw
- ] unless
- utf8 file-contents
+ dup "include" optional-attr [
+ utf8 file-contents [ add-style ] [code-with]
] [
- drop children>string
- ] if add-style ;
+ compile-children>string [ add-style ] [code]
+ ] ?if ;
CHLOE: write-style
- drop <style> write-style </style> ;
+ drop [ <style> write-style </style> ] [code] ;
-CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ;
+CHLOE: even
+ [ "index" value even? swap when ] process-children ;
-CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
+CHLOE: odd
+ [ "index" value odd? swap when ] process-children ;
: (bind-tag) ( tag quot -- )
[
- [ "name" required-attr ] keep
- '[ , process-tag-children ]
- ] dip call ; inline
+ [ "name" required-attr compile-attr ] keep
+ ] dip process-children ; inline
CHLOE: each [ with-each-value ] (bind-tag) ;
@@ -80,22 +55,23 @@ CHLOE: bind-each [ with-each-object ] (bind-tag) ;
CHLOE: bind [ with-form ] (bind-tag) ;
-: error-message-tag ( tag -- )
- children>string render-error ;
-
CHLOE: comment drop ;
-CHLOE: call-next-template drop call-next-template ;
+CHLOE: call-next-template
+ drop reset-buffer \ call-next-template , ;
: attr>word ( value -- word/f )
":" split1 swap lookup ;
-: if-satisfied? ( tag -- ? )
- [ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ]
- [ "value" optional-attr [ value ] [ t ] if* ]
- bi and ;
+: if>quot ( tag -- quot )
+ [
+ [ "code" optional-attr [ attr>word [ , ] [ f , ] if* ] [ t , ] if* ]
+ [ "value" optional-attr [ , \ value , ] [ t , ] if* ]
+ bi
+ \ and ,
+ ] [ ] make ;
-CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
+CHLOE: if dup if>quot [ swap when ] append process-children ;
CHLOE-SINGLETON: label
CHLOE-SINGLETON: link
@@ -112,51 +88,13 @@ CHLOE-TUPLE: choice
CHLOE-TUPLE: checkbox
CHLOE-TUPLE: code
-: process-chloe-tag ( tag -- )
- dup main>> dup tags get at
- [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
+MEMO: template-quot ( chloe -- quot )
+ path>> ".xml" append utf8 <file-reader> read-xml
+ compile-template ;
-: process-tag ( tag -- )
- {
- [ main>> >lower tag-stack get push ]
- [ write-start-tag ]
- [ process-tag-children ]
- [ write-end-tag ]
- [ drop tag-stack get pop* ]
- } cleave ;
-
-: expand-attrs ( tag -- tag )
- dup [ tag? ] [ xml? ] bi or [
- clone [
- [ "@" ?head [ value present ] when ] assoc-map
- ] change-attrs
- ] when ;
-
-: process-template ( xml -- )
- expand-attrs
- {
- { [ dup chloe-tag? ] [ process-chloe-tag ] }
- { [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] }
- { [ t ] [ write-item ] }
- } cond ;
-
-: process-chloe ( xml -- )
- [
- V{ } clone tag-stack set
-
- nested-template? get [
- process-template
- ] [
- {
- [ prolog>> write-prolog ]
- [ before>> write-chunk ]
- [ process-template ]
- [ after>> write-chunk ]
- } cleave
- ] if
- ] with-scope ;
+: reset-templates ( -- ) \ template-quot reset-memoized ;
M: chloe call-template*
- path>> ".xml" append utf8 <file-reader> read-xml process-chloe ;
+ template-quot call ;
INSTANCE: chloe template
diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor
new file mode 100644
index 0000000000..5722245f89
--- /dev/null
+++ b/basis/html/templates/chloe/compiler/compiler.factor
@@ -0,0 +1,127 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs namespaces kernel sequences accessors combinators
+strings splitting io io.streams.string xml.writer xml.data
+xml.entities html.forms html.templates.chloe.syntax ;
+IN: html.templates.chloe.compiler
+
+: chloe-attrs-only ( assoc -- assoc' )
+ [ drop url>> chloe-ns = ] assoc-filter ;
+
+: non-chloe-attrs-only ( assoc -- assoc' )
+ [ drop url>> chloe-ns = not ] assoc-filter ;
+
+: chloe-tag? ( tag -- ? )
+ dup xml? [ body>> ] when
+ {
+ { [ dup tag? not ] [ f ] }
+ { [ dup url>> chloe-ns = not ] [ f ] }
+ [ t ]
+ } cond nip ;
+
+SYMBOL: string-buffer
+
+SYMBOL: tag-stack
+
+DEFER: compile-element
+
+: compile-children ( tag -- )
+ [ compile-element ] each ;
+
+: [write] ( string -- ) string-buffer get push-all ;
+
+: reset-buffer ( -- )
+ string-buffer get [
+ [ >string , \ write , ] [ delete-all ] bi
+ ] unless-empty ;
+
+: [code] ( quot -- )
+ reset-buffer % ;
+
+: [code-with] ( obj quot -- )
+ reset-buffer [ , ] [ % ] bi* ;
+
+: expand-attr ( value -- )
+ [ value write ] [code-with] ;
+
+: compile-attr ( value -- )
+ reset-buffer "@" ?head [ , \ value ] when , ;
+
+: compile-attrs ( assoc -- )
+ [
+ " " [write]
+ swap name>string [write]
+ "=\"" [write]
+ "@" ?head [ expand-attr ] [ escape-quoted-string [write] ] if
+ "\"" [write]
+ ] assoc-each ;
+
+: compile-start-tag ( tag -- )
+ "<" [write]
+ [ name>string [write] ] [ compile-attrs ] bi
+ ">" [write] ;
+
+: compile-end-tag ( tag -- )
+ "</" [write]
+ name>string [write]
+ ">" [write] ;
+
+: compile-tag ( tag -- )
+ {
+ [ main>> tag-stack get push ]
+ [ compile-start-tag ]
+ [ compile-children ]
+ [ compile-end-tag ]
+ [ drop tag-stack get pop* ]
+ } cleave ;
+
+: compile-chloe-tag ( tag -- )
+ ! "Unknown chloe tag: " prepend throw
+ dup main>> dup tags get at
+ [ curry assert-depth ] [ 2drop ] ?if ;
+
+: compile-element ( element -- )
+ {
+ { [ dup chloe-tag? ] [ compile-chloe-tag ] }
+ { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
+ { [ dup string? ] [ escape-string [write] ] }
+ { [ dup comment? ] [ drop ] }
+ [ [ write-item ] [code-with] ]
+ } cond ;
+
+: with-compiler ( quot -- quot' )
+ [
+ SBUF" " string-buffer set
+ V{ } clone tag-stack set
+ call
+ reset-buffer
+ ] [ ] make ; inline
+
+: compile-nested-template ( xml -- quot )
+ [ compile-element ] with-compiler ;
+
+: compile-chunk ( seq -- )
+ [ compile-element ] each ;
+
+: process-children ( tag quot -- )
+ reset-buffer
+ [
+ [
+ SBUF" " string-buffer set
+ compile-children
+ reset-buffer
+ ] [ ] make ,
+ ] [ % ] bi* ;
+
+: compile-children>string ( tag -- )
+ [ with-string-writer ] process-children ;
+
+: compile-template ( xml -- quot )
+ [
+ {
+ [ prolog>> [ write-prolog ] [code-with] ]
+ [ before>> compile-chunk ]
+ [ compile-element ]
+ [ after>> compile-chunk ]
+ } cleave
+ ] with-compiler ;
diff --git a/basis/html/templates/chloe/components/components.factor b/basis/html/templates/chloe/components/components.factor
new file mode 100644
index 0000000000..e8703a1235
--- /dev/null
+++ b/basis/html/templates/chloe/components/components.factor
@@ -0,0 +1,35 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sequences kernel parser fry quotations
+classes.tuple
+html.components
+html.templates.chloe.compiler
+html.templates.chloe.syntax ;
+IN: html.templates.chloe.components
+
+: singleton-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 -- )
+ [ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi
+ [ render ] [code] ;
+
+: CHLOE-TUPLE:
+ scan-word
+ [ name>> ] [ '[ , tuple-component-tag ] ] bi
+ define-chloe-tag ;
+ parsing
diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor
index 65b5cd8790..90c171917b 100644
--- a/basis/html/templates/chloe/syntax/syntax.factor
+++ b/basis/html/templates/chloe/syntax/syntax.factor
@@ -21,7 +21,7 @@ tags global [ H{ } clone or ] change-at
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
-MEMO: chloe-name ( string -- name )
+: chloe-name ( string -- name )
name new
swap >>main
chloe-ns >>url ;
@@ -32,30 +32,3 @@ MEMO: chloe-name ( string -- name )
: optional-attr ( tag name -- value )
chloe-name swap at ;
-
-: singleton-component-tag ( tag class -- )
- [ "name" required-attr ] dip render ;
-
-: CHLOE-SINGLETON:
- scan-word
- [ name>> ] [ '[ , singleton-component-tag ] ] bi
- define-chloe-tag ;
- parsing
-
-: attrs>slots ( tag tuple -- )
- [ attrs>> ] [ <mirror> ] bi*
- '[
- swap main>> dup "name" =
- [ 2drop ] [ , set-at ] if
- ] assoc-each ;
-
-: tuple-component-tag ( tag class -- )
- [ drop "name" required-attr ]
- [ new [ attrs>slots ] keep ]
- 2bi render ;
-
-: CHLOE-TUPLE:
- scan-word
- [ name>> ] [ '[ , tuple-component-tag ] ] bi
- define-chloe-tag ;
- parsing
diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor
index 0c98e9a48e..6b60ec8a6d 100644
--- a/basis/xml/writer/writer.factor
+++ b/basis/xml/writer/writer.factor
@@ -37,10 +37,11 @@ SYMBOL: indenter
[ [ empty? ] [ string? ] bi and not ] filter
] when ;
+: name>string ( name -- string )
+ [ main>> ] [ space>> ] bi [ ":" swap 3append ] unless-empty ;
+
: print-name ( name -- )
- dup space>> f like
- [ write CHAR: : write1 ] when*
- main>> write ;
+ name>string write ;
: print-attrs ( assoc -- )
[
From 977febf1fa4942daef8f876e571d1347def065a1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 8 Sep 2008 01:11:27 -0500
Subject: [PATCH 15/18] Wiki: cache Farkup HTML output
---
extra/webapps/wiki/view.xml | 2 +-
extra/webapps/wiki/wiki-common.xml | 4 ++--
extra/webapps/wiki/wiki.factor | 12 +++++++++---
3 files changed, 12 insertions(+), 6 deletions(-)
diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml
index 38d9d39d55..5136e4945d 100644
--- a/extra/webapps/wiki/view.xml
+++ b/extra/webapps/wiki/view.xml
@@ -5,7 +5,7 @@
<t:title><t:label t:name="title" /></t:title>
<div class="description">
- <t:farkup t:name="content" />
+ <t:html t:name="html" />
</div>
<p>
diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml
index dea79670a3..89a0f17706 100644
--- a/extra/webapps/wiki/wiki-common.xml
+++ b/extra/webapps/wiki/wiki-common.xml
@@ -41,7 +41,7 @@
</t:a>
</h2>
- <t:farkup t:name="content" />
+ <t:html t:name="html" />
</t:bind>
</td>
</t:if>
@@ -52,7 +52,7 @@
<td>
<t:bind t:name="footer">
<small>
- <t:farkup t:name="content" />
+ <t:html t:name="html" />
</small>
</t:bind>
</td>
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 380f41cf97..5f679be431 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -3,7 +3,7 @@
USING: accessors kernel hashtables calendar random assocs
namespaces splitting sequences sorting math.order present
io.files io.encodings.ascii
-syndication
+syndication farkup
html.components html.forms
http.server
http.server.dispatchers
@@ -47,7 +47,7 @@ article "ARTICLES" {
: <article> ( title -- article ) article new swap >>title ;
-TUPLE: revision id title author date content description ;
+TUPLE: revision id title author date content html description ;
revision "REVISIONS" {
{ "id" "ID" INTEGER +db-assigned-id+ }
@@ -55,6 +55,7 @@ revision "REVISIONS" {
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
{ "date" "DATE" TIMESTAMP +not-null+ }
{ "content" "CONTENT" TEXT +not-null+ }
+ { "html" "HTML" TEXT +not-null+ } ! Farkup converted to HTML
{ "description" "DESCRIPTION" TEXT }
} define-persistent
@@ -71,6 +72,9 @@ M: revision feed-entry-url id>> revision-url ;
: <revision> ( id -- revision )
revision new swap >>id ;
+: compute-html ( revision -- )
+ dup content>> convert-farkup >>html drop ;
+
: validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ;
@@ -144,11 +148,13 @@ M: revision feed-entry-url id>> revision-url ;
[ title>> ] [ id>> ] bi article boa insert-tuple ;
: add-revision ( revision -- )
+ [ compute-html ]
[ insert-tuple ]
[
dup title>> <article> select-tuple
[ amend-article ] [ add-article ] if*
- ] bi ;
+ ]
+ tri ;
: <edit-article-action> ( -- action )
<page-action>
From b9f0795c53b086322a2013648dfea81d359b2079 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 8 Sep 2008 01:11:36 -0500
Subject: [PATCH 16/18] Minor tweak
---
extra/websites/concatenative/concatenative.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor
index 11d8fa27c2..5e94e4e88a 100644
--- a/extra/websites/concatenative/concatenative.factor
+++ b/extra/websites/concatenative/concatenative.factor
@@ -4,6 +4,7 @@ USING: accessors kernel sequences assocs io.files io.sockets
io.sockets.secure io.servers.connection
namespaces db db.tuples db.sqlite smtp urls
logging.insomniac
+html.templates.chloe
http.server
http.server.dispatchers
http.server.redirection
@@ -68,6 +69,7 @@ SYMBOL: key-file
SYMBOL: dh-file
: common-configuration ( -- )
+ reset-templates
"concatenative.org" 25 <inet> smtp-server set-global
"noreply@concatenative.org" lost-password-from set-global
"website@concatenative.org" insomniac-sender set-global
From d470bde42b85ed3e3ca8fbe53ba363f3a4c32ece Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 8 Sep 2008 02:52:42 -0500
Subject: [PATCH 17/18] Assorted fixes
---
basis/furnace/chloe-tags/chloe-tags.factor | 19 +++++++++-----
basis/html/templates/chloe/chloe.factor | 18 +++++++++----
.../templates/chloe/compiler/compiler.factor | 26 +++++++++++--------
basis/xml/writer/writer-tests.factor | 5 ++++
basis/xml/writer/writer.factor | 2 +-
5 files changed, 46 insertions(+), 24 deletions(-)
create mode 100644 basis/xml/writer/writer-tests.factor
diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor
index 22eddd77a2..8822bca519 100644
--- a/basis/furnace/chloe-tags/chloe-tags.factor
+++ b/basis/furnace/chloe-tags/chloe-tags.factor
@@ -65,7 +65,10 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
: a-end-tag ( tag -- )
drop [ </a> ] [code] ;
-CHLOE: a [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri ;
+CHLOE: a
+ [
+ [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
+ ] compile-with-scope ;
: compile-hidden-form-fields ( for -- )
'[
@@ -95,12 +98,14 @@ CHLOE: a [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri ;
drop [ </form> ] [code] ;
CHLOE: form
- {
- [ compile-link-attrs ]
- [ form-start-tag ]
- [ compile-children ]
- [ form-end-tag ]
- } cleave ;
+ [
+ {
+ [ compile-link-attrs ]
+ [ form-start-tag ]
+ [ compile-children ]
+ [ form-end-tag ]
+ } cleave
+ ] compile-with-scope ;
STRING: button-tag-markup
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor
index a03e42bb37..45e59c3b6d 100644
--- a/basis/html/templates/chloe/chloe.factor
+++ b/basis/html/templates/chloe/chloe.factor
@@ -88,13 +88,21 @@ CHLOE-TUPLE: choice
CHLOE-TUPLE: checkbox
CHLOE-TUPLE: code
-MEMO: template-quot ( chloe -- quot )
- path>> ".xml" append utf8 <file-reader> read-xml
- compile-template ;
+: read-template ( chloe -- xml )
+ path>> ".xml" append utf8 <file-reader> read-xml ;
-: reset-templates ( -- ) \ template-quot reset-memoized ;
+MEMO: template-quot ( chloe -- quot )
+ read-template compile-template ;
+
+MEMO: nested-template-quot ( chloe -- quot )
+ read-template compile-nested-template ;
+
+: reset-templates ( -- )
+ { template-quot nested-template-quot } [ reset-memoized ] each ;
M: chloe call-template*
- template-quot call ;
+ nested-template? get
+ [ nested-template-quot ] [ template-quot ] if
+ assert-depth ;
INSTANCE: chloe template
diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor
index 5722245f89..044d2edb90 100644
--- a/basis/html/templates/chloe/compiler/compiler.factor
+++ b/basis/html/templates/chloe/compiler/compiler.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces kernel sequences accessors combinators
-strings splitting io io.streams.string xml.writer xml.data
-xml.entities html.forms html.templates.chloe.syntax ;
+strings splitting io io.streams.string present xml.writer
+xml.data xml.entities html.forms html.templates.chloe.syntax ;
IN: html.templates.chloe.compiler
: chloe-attrs-only ( assoc -- assoc' )
@@ -42,10 +42,10 @@ DEFER: compile-element
reset-buffer [ , ] [ % ] bi* ;
: expand-attr ( value -- )
- [ value write ] [code-with] ;
+ [ value present write ] [code-with] ;
: compile-attr ( value -- )
- reset-buffer "@" ?head [ , \ value ] when , ;
+ reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ;
: compile-attrs ( assoc -- )
[
@@ -103,19 +103,23 @@ DEFER: compile-element
: compile-chunk ( seq -- )
[ compile-element ] each ;
-: process-children ( tag quot -- )
+: compile-quot ( quot -- )
reset-buffer
[
- [
- SBUF" " string-buffer set
- compile-children
- reset-buffer
- ] [ ] make ,
- ] [ % ] bi* ;
+ SBUF" " string-buffer set
+ call
+ reset-buffer
+ ] [ ] make , ; inline
+
+: process-children ( tag quot -- )
+ [ [ compile-children ] compile-quot ] [ % ] bi* ; inline
: compile-children>string ( tag -- )
[ with-string-writer ] process-children ;
+: compile-with-scope ( quot -- )
+ compile-quot [ with-scope ] [code] ; inline
+
: compile-template ( xml -- quot )
[
{
diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor
new file mode 100644
index 0000000000..acfe4bfe1e
--- /dev/null
+++ b/basis/xml/writer/writer-tests.factor
@@ -0,0 +1,5 @@
+IN: xml.writer.tests
+USING: xml.data xml.writer tools.test ;
+
+[ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test
+[ "ns:foo" ] [ T{ name { space "ns" } { main "foo" } } name>string ] unit-test
diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor
index 6b60ec8a6d..ae6fddacc3 100644
--- a/basis/xml/writer/writer.factor
+++ b/basis/xml/writer/writer.factor
@@ -38,7 +38,7 @@ SYMBOL: indenter
] when ;
: name>string ( name -- string )
- [ main>> ] [ space>> ] bi [ ":" swap 3append ] unless-empty ;
+ [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;
: print-name ( name -- )
name>string write ;
From 24b42d40081903022d2a323a5201d4a613d60ac4 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 8 Sep 2008 04:22:58 -0500
Subject: [PATCH 18/18] locals: Add some tests for locals in literals
---
basis/locals/locals-tests.factor | 14 ++++++++++++++
1 file changed, 14 insertions(+)
diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor
index a37c429471..59ec325f39 100755
--- a/basis/locals/locals-tests.factor
+++ b/basis/locals/locals-tests.factor
@@ -316,3 +316,17 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
! [ f ] [ 3 wlet-&&-test ] unit-test
! [ f ] [ 8 wlet-&&-test ] unit-test
! [ t ] [ 12 wlet-&&-test ] unit-test
+
+[ { 10 } ] [ 10 [| a | { a } ] call ] unit-test
+[ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test
+[ { 10 20 30 } ] [ 10 20 30 [| a b c | { a b c } ] call ] unit-test
+
+[ { 10 20 30 } ] [ [let | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test
+
+[ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
+
+[ H{ { 10 "a" } { 20 "b" } { 30 "c" } } ]
+[ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
+
+[ T{ slice f 0 3 "abc" } ]
+[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test
\ No newline at end of file