Merge branch 'master' of git://factorcode.org/git/factor

basis/furnace/chloe-tags/chloe-tags.factor

@@ -10,7 +10,6 @@ xml.writer
 xml.traversal
 xml.syntax
 html.components
-html.elements
 html.forms
 html.templates
 html.templates.chloe
@@ -20,6 +19,7 @@ http
 http.server
 http.server.redirection
 http.server.responses
+io.streams.string
 furnace.utilities ;
 IN: furnace.chloe-tags
 
@@ -58,62 +58,67 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
     #! Side-effects current namespace.
     '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
 
-: a-start-tag ( tag -- )
-    [ <a ] [code]
-    [ attrs>> non-chloe-attrs-only compile-attrs ]
-    [ compile-link-attrs ]
-    [ compile-a-url ]
-    tri
-    [ =href a> ] [code] ;
+: process-attrs ( assoc -- newassoc )
+    [ "@" ?head [ value present ] when ] assoc-map ;
 
-: a-end-tag ( tag -- )
-    drop [ </a> ] [code] ;
+: non-chloe-attrs ( tag -- )
+    attrs>> non-chloe-attrs-only [ process-attrs ] [code-with] ;
+
+: a-attrs ( tag -- )
+    [ non-chloe-attrs ]
+    [ compile-link-attrs ]
+    [ compile-a-url ] tri
+    [ present swap "href" swap [ set-at ] keep ] [code] ;
 
 CHLOE: a
     [
-        [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
+        [ a-attrs ]
+        [ compile-children>string ] bi
+        [ <unescaped> [XML <a><-></a> XML] second swap >>attrs ]
+        [xml-code]
     ] compile-with-scope ;
 
 CHLOE: base
-    compile-a-url [ <base =href base/> ] [code] ;
+    compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
 
 : compile-hidden-form-fields ( for -- )
     '[
-        <div "display: none;" =style div>
-            _ [ "," split [ hidden render ] each ] when*
-            nested-forms get " " join f like nested-forms-key hidden-form-field
-            [ modify-form ] each-responder
-        </div>
+        _ [ "," split [ hidden render>xml ] map ] [ f ] if*
+        nested-forms get " " join f like nested-forms-key hidden-form-field>xml
+        [ [ modify-form ] each-responder ] with-string-writer <unescaped>
+        [XML <div style="display: none;"><-><-><-></div> XML]
     ] [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] ;
+: (compile-form-attrs) ( method action -- )
+    ! Leaves an assoc on the stack at runtime
+    [ compile-attr [ "method" pick set-at ] [code] ]
+    [ compile-attr [ resolve-base-path "action" pick set-at ] [code] ]
+    bi* ;
 
-: 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 ;
+: compile-method/action ( tag -- )
+    ! generated code is ( assoc -- assoc )
+    [ "method" optional-attr "post" or ]
+    [ "action" required-attr ] bi
+    (compile-form-attrs) ;
 
-: form-end-tag ( tag -- )
-    drop [ </form> ] [code] ;
+: compile-form-attrs ( tag -- )
+    [ non-chloe-attrs ]
+    [ compile-link-attrs ]
+    [ compile-method/action ] tri ;
+
+: hidden-fields ( tag -- )
+    "for" optional-attr compile-hidden-form-fields ;
 
 CHLOE: form
     [
-        {
-            [ compile-link-attrs ]
-            [ form-start-tag ]
-            [ compile-children ]
-            [ form-end-tag ]
-        } cleave
+        [ compile-form-attrs ]
+        [ hidden-fields ]
+        [ compile-children>string ] tri
+        [
+            <unescaped> [XML <form><-><-></form> XML] second
+                swap >>attrs
+            write-xml
+        ] [code]
     ] compile-with-scope ;
 
 : button-tag-markup ( -- xml )
@@ -121,13 +126,13 @@ CHLOE: form
         <t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
             <div style="display: inline;"><button type="submit"></button></div>
         </t:form>
-    XML> ;
+    XML> body>> clone ;
 
 : add-tag-attrs ( attrs tag -- )
     attrs>> swap update ;
 
 CHLOE: button
-    button-tag-markup body>>
+    button-tag-markup
     {
         [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
         [ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]

basis/furnace/furnace-tests.factor

@@ -30,7 +30,7 @@ M: base-path-check-responder call-responder*
     "a/b/c" split-path main-responder get call-responder body>>
 ] unit-test
 
-[ "<input type='hidden' name='foo' value='&amp;&amp;&amp;'/>" ]
+[ "<input type=\"hidden\" value=\"&amp;&amp;&amp;\" name=\"foo\"/>" ]
 [ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
 unit-test
 

basis/furnace/sessions/sessions.factor

@@ -5,7 +5,7 @@ strings random accessors quotations hashtables sequences
 continuations fry calendar combinators combinators.short-circuit
 destructors alarms io.sockets db db.tuples db.types
 http http.server http.server.dispatchers http.server.filters
-html.elements furnace.cache furnace.scopes furnace.utilities ;
+furnace.cache furnace.scopes furnace.utilities ;
 IN: furnace.sessions
 
 TUPLE: session < scope user-agent client ;

basis/furnace/utilities/utilities.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces make assocs sequences kernel classes splitting
 words vocabs.loader accessors strings combinators arrays
-continuations present fry urls html.elements http http.server
+continuations present fry urls http http.server xml.syntax xml.writer
 http.server.redirection http.server.remapping ;
 IN: furnace.utilities
 
@@ -81,14 +81,13 @@ GENERIC: modify-form ( responder -- )
 
 M: object modify-form drop ;
 
-: hidden-form-field ( value name -- )
+: hidden-form-field>xml ( value name -- xml )
     over [
-        <input
-            "hidden" =type
-            =name
-            present =value
-        input/>
-    ] [ 2drop ] if ;
+        [XML <input type="hidden" value=<-> name=<->/> XML]
+    ] [ drop ] if ;
+
+: hidden-form-field ( value name -- )
+    hidden-form-field>xml write-xml ;
 
 : nested-forms-key "__n" ;
 

basis/html/components/components.factor

@@ -11,7 +11,7 @@ IN: html.components
 
 GENERIC: render* ( value name renderer -- xml )
 
-: render ( name renderer -- )
+: render>xml ( name renderer -- xml )
     prepare-value
     [
         dup validation-error?
@@ -20,7 +20,10 @@ GENERIC: render* ( value name renderer -- xml )
         if
     ] 2dip
     render*
-    swap 2array write-xml ;
+    swap 2array ;
+
+: render ( name renderer -- )
+    render>xml write-xml ;
 
 SINGLETON: label
 

basis/html/templates/chloe/chloe-docs.factor

@@ -128,7 +128,7 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags"
             "<a href=\"http://mysite.org/wiki/view/Factor\""
             "   class=\"small-link\">"
             "    View"
-            "s</a>"
+            "</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" } "." } }
@@ -261,8 +261,8 @@ $nl
 ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component"
 "As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:"
 { $code "SINGLETON: image" }
-"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/> ;" }
+"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "xml.literals" } ":"
+{ $code "M: image render* 2drop [XML <img src=<-> /> XML] ;" }
 "Finally, we can define a Chloe component:"
 { $code "COMPONENT: image" }
 "We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":"

basis/html/templates/chloe/chloe-tests.factor

@@ -135,7 +135,7 @@ TUPLE: person first-name last-name ;
 
 [ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
 
-[ "<form method='post' action='foo'><div style='display: none;'><input type='hidden' name='__n' value='a'/></div></form>" ] [
+[ "<form method=\"post\" action=\"foo\"><div style=\"display: none;\"><input type=\"hidden\" value=\"a\" name=\"__n\"/></div></form>" ] [
     [
         "test10" test-template call-template
     ] run-template

basis/html/templates/chloe/chloe.factor

@@ -8,7 +8,6 @@ logging continuations
 xml.data xml.writer xml.syntax strings
 html.forms
 html
-html.elements
 html.components
 html.templates
 html.templates.chloe.compiler
@@ -28,7 +27,9 @@ CHLOE: write-title
     drop
     "head" tag-stack get member?
     "title" tag-stack get member? not and
-    [ <title> write-title </title> ] [ write-title ] ? [code] ;
+    [ get-title [XML <title><-></title> XML] ]
+    [ get-title ] ?
+    [xml-code] ;
 
 CHLOE: style
     dup "include" optional-attr [
@@ -39,10 +40,9 @@ CHLOE: style
 
 CHLOE: write-style
     drop [
-        <style "text/css" =type style>
-            write-style
-        </style>
-    ] [code] ;
+        get-style
+        [XML <style type="text/css"> <-> </style> XML]
+    ] [xml-code] ;
 
 CHLOE: even
     [ "index" value even? swap when ] process-children ;

basis/html/templates/chloe/compiler/compiler.factor

@@ -42,6 +42,9 @@ DEFER: compile-element
 : [code-with] ( obj quot -- )
     reset-buffer [ , ] [ % ] bi* ;
 
+: [xml-code] ( quot -- )
+    [ write-xml ] compose [code] ;
+
 : expand-attr ( value -- )
     [ value present write ] [code-with] ;
 

basis/html/templates/templates.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel fry io io.encodings.utf8 io.files
 debugger prettyprint continuations namespaces boxes sequences
-arrays strings html io.streams.string
+arrays strings html io.streams.string assocs
 quotations xml.data xml.writer xml.syntax ;
 IN: html.templates
 
@@ -34,8 +34,11 @@ SYMBOL: title
 : set-title ( string -- )
     title get >box ;
 
+: get-title ( -- string )
+    title get value>> ;
+
 : write-title ( -- )
-    title get value>> write ;
+    get-title write ;
 
 SYMBOL: style
 
@@ -43,24 +46,30 @@ SYMBOL: style
     "\n" style get push-all
          style get push-all ;
 
+: get-style ( -- string )
+    style get >string ;
+
 : write-style ( -- )
-    style get >string write ;
+    get-style write ;
 
 SYMBOL: atom-feeds
 
 : add-atom-feed ( title url -- )
     2array atom-feeds get push ;
 
-: write-atom-feeds ( -- )
+: get-atom-feeds ( -- xml )
     atom-feeds get [
-        first2 [XML
+        [XML
             <link
                 rel="alternate"
                 type="application/atom+xml"
                 title=<->
                 href=<->/>
-        XML] write-xml
-    ] each ;
+        XML]
+    ] { } assoc>map ;
+
+: write-atom-feeds ( -- )
+    get-atom-feeds write-xml ;
 
 SYMBOL: nested-template?
 

basis/unicode/case/case-tests.factor

@@ -1,4 +1,7 @@
-USING: unicode.case tools.test namespaces ;
+! Copyright (C) 2008, 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: unicode.case unicode.case.private tools.test namespaces strings unicode.normalize ;
+IN: unicode.case.tests
 
 \ >upper must-infer
 \ >lower must-infer
@@ -9,12 +12,21 @@ USING: unicode.case tools.test namespaces ;
 [ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test
 [ t ] [ "hello how are you?" lower? ] unit-test
 [
+    [ f ] [ i-dot? ] unit-test
+    [ f ] [ lt? ] unit-test
     "tr" locale set
+    [ t ] [ i-dot? ] unit-test
+    [ f ] [ lt? ] unit-test
     [ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test
     [ "I\u000307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
     [ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test
     "lt" locale set
-    ! Lithuanian casing tests
+    [ f ] [ i-dot? ] unit-test
+    [ t ] [ lt? ] unit-test
+    [ "i\u000307\u000300" ] [ HEX: CC 1string nfd >lower ] unit-test
+    [ "\u00012f\u000307" ] [ HEX: 12E 1string nfd >lower nfc ] unit-test
+    [ "I\u000300" ] [ "i\u000307\u000300" >upper ] unit-test
+!    [ "I\u000300" ] [ "i\u000307\u000300" >title ] unit-test
 ] with-scope
 
 [ t ] [ "asdf" lower? ] unit-test

basis/unicode/case/case.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Daniel Ehrenberg.
+! Copyright (C) 2008, 2009 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: unicode.data sequences namespaces
 sbufs make unicode.syntax unicode.normalize math hints
-unicode.categories combinators unicode.syntax assocs
+unicode.categories combinators unicode.syntax assocs combinators.short-circuit
 strings splitting kernel accessors unicode.breaks fry locals ;
 QUALIFIED: ascii
 IN: unicode.case
@@ -26,6 +26,9 @@ SYMBOL: locale ! Just casing locale, or overall?
 : i-dot? ( -- ? )
     locale get { "tr" "az" } member? ;
 
+: lt? ( -- ? )
+    locale get "lt" = ;
+
 : lithuanian? ( -- ? ) locale get "lt" = ;
 
 : dot-over ( -- ch ) HEX: 307 ;
@@ -37,18 +40,21 @@ SYMBOL: locale ! Just casing locale, or overall?
 : mark-above? ( ch -- ? )
     combining-class 230 = ;
 
-: with-rest ( seq quot: ( seq -- seq ) -- seq )
-    [ unclip ] dip swap slip prefix ; inline
+:: with-rest ( seq quot: ( seq -- seq ) -- seq )
+    seq unclip quot dip prefix ; inline
 
 : add-dots ( seq -- seq )
-    [ [ "" ] [
-        dup first mark-above?
-        [ CHAR: combining-dot-above prefix ] when
+    [ [ { } ] [
+        [
+            dup first
+            { [ mark-above? ] [ CHAR: combining-ogonek = ] } 1||
+            [ CHAR: combining-dot-above prefix ] when
+        ] map
     ] if-empty ] with-rest ; inline
 
 : lithuanian>lower ( string -- lower )
-    "i" split add-dots "i" join
-    "j" split add-dots "i" join ; inline
+    "I" split add-dots "I" join
+    "J" split add-dots "J" join ; inline
 
 : turk>upper ( string -- upper-i )
     "i" "I\u000307" replace ; inline
@@ -88,13 +94,16 @@ SYMBOL: locale ! Just casing locale, or overall?
 PRIVATE>
 
 : >lower ( string -- lower )
-    i-dot? [ turk>lower ] when final-sigma
+    i-dot? [ turk>lower ] when
+    lt? [ lithuanian>lower ] when
+    final-sigma
     [ lower>> ] [ ch>lower ] map-case ;
 
 HINTS: >lower string ;
 
 : >upper ( string -- upper )
     i-dot? [ turk>upper ] when
+    lt? [ lithuanian>upper ] when
     [ upper>> ] [ ch>upper ] map-case ;
 
 HINTS: >upper string ;
@@ -103,6 +112,7 @@ HINTS: >upper string ;
 
 : (>title) ( string -- title )
     i-dot? [ turk>upper ] when
+    lt? [ lithuanian>upper ] when
     [ title>> ] [ ch>title ] map-case ; inline
 
 : title-word ( string -- title )

extra/webapps/user-admin/user-admin.factor

@@ -3,7 +3,6 @@
 USING: kernel sequences accessors namespaces combinators words
 assocs db.tuples arrays splitting strings validators urls
 html.forms
-html.elements
 html.components
 furnace
 furnace.boilerplate