Move templates to html vocabulary

extra/html/components/components-tests.factor

@@ -60,7 +60,7 @@ TUPLE: color red green blue ;
 
 [ ] [
     [
-        "green" <textarea> 25 >>rows 30 >>columns render
+        "green" <textarea> 25 >>rows 30 >>cols render
     ] with-null-writer
 ] unit-test
 
@@ -68,11 +68,13 @@ TUPLE: color red green blue ;
 
 [ ] [ "new york" "city1" set-value ] unit-test
 
+[ ] [ { "new york" "los angeles" "chicago" } "cities" set-value ] unit-test
+
 [ ] [
     [
         "city1"
         <choice>
-            { "new york" "los angeles" "chicago" } >>choices
+            "cities" >>choices
         render
     ] with-null-writer
 ] unit-test
@@ -83,7 +85,7 @@ TUPLE: color red green blue ;
     [
         "city2"
         <choice>
-            { "new york" "los angeles" "chicago" } >>choices
+            "cities" >>choices
             t >>multiple
         render
     ] with-null-writer
@@ -93,7 +95,7 @@ TUPLE: color red green blue ;
     [
         "city2"
         <choice>
-            { "new york" "los angeles" "chicago" } >>choices
+            "cities" >>choices
             t >>multiple
             5 >>size
         render

extra/html/components/components.factor

@@ -78,7 +78,7 @@ M: password render*
     [ drop "" ] 2dip size>> "password" render-field ;
 
 ! Text areas
-TUPLE: textarea rows columns ;
+TUPLE: textarea rows cols ;
 
 : <textarea> ( -- renderer )
     textarea new ;
@@ -86,14 +86,14 @@ TUPLE: textarea rows columns ;
 M: textarea render*
     <textarea
         [ rows>> [ number>string =rows ] when* ]
-        [ columns>> [ number>string =cols ] when* ] bi
+        [ cols>> [ number>string =cols ] when* ] bi
         =name
     textarea>
         object>string escape-string write
     </textarea> ;
 
 ! Choice
-TUPLE: choice size choices multiple ;
+TUPLE: choice size multiple choices ;
 
 : <choice> ( -- choice )
     choice new ;
@@ -112,7 +112,7 @@ M: choice render*
         dup size>> [ number>string =size ] when*
         dup multiple>> [ "true" =multiple ] when
     select>
-        [ choices>> ] [ multiple>> ] bi
+        [ choices>> value ] [ multiple>> ] bi
         [ swap ] [ swap 1array ] if
         render-options
     </select> ;

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

@@ -1,8 +1,8 @@
-USING: http.server.templating http.server.templating.chloe
-http.server.components http.server.boilerplate tools.test
-io.streams.string kernel sequences ascii boxes namespaces xml
+USING: html.templates html.templates.chloe
+tools.test io.streams.string kernel sequences ascii boxes
+namespaces xml
 splitting ;
-IN: http.server.templating.chloe.tests
+IN: html.templates.chloe.tests
 
 [ f ] [ f parse-query-attr ] unit-test
 
@@ -26,7 +26,7 @@ IN: http.server.templating.chloe.tests
     "?>" split1 nip ; inline
 
 : test-template ( name -- template )
-    "resource:extra/http/server/templating/chloe/test/"
+    "resource:extra/html/templates/chloe/test/"
     swap
     ".xml" 3append <chloe> ;
 

extra/html/templates/chloe/chloe.factor

@@ -3,13 +3,14 @@
 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 tuple-syntax html html.elements
+unicode.case tuple-syntax mirrors fry
 multiline xml xml.data xml.writer xml.utilities
+html.elements
+html.components
 http.server
 http.server.auth
 http.server.flows
 http.server.actions
-http.server.components
 http.server.sessions
 http.server.templating
 http.server.boilerplate ;
@@ -52,8 +53,11 @@ MEMO: chloe-name ( string -- name )
 : optional-attr ( tag name -- value )
     chloe-name swap at ;
 
+: process-tag-children ( tag -- )
+    [ process-template ] each ;
+
 : children>string ( tag -- string )
-    [ [ process-template ] each ] with-string-writer ;
+    [ process-tag-children ] with-string-writer ;
 
 : title-tag ( tag -- )
     children>string set-title ;
@@ -89,18 +93,6 @@ MEMO: chloe-name ( string -- name )
         atom-feed get value>> second write
     ] if ;
 
-: component-attr ( tag -- name )
-    "component" required-attr ;
-
-: view-tag ( tag -- )
-    component-attr component render-view ;
-
-: edit-tag ( tag -- )
-    component-attr component render-edit ;
-
-: summary-tag ( tag -- )
-    component-attr component render-summary ;
-
 : parse-query-attr ( string -- assoc )
     dup empty?
     [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
@@ -133,9 +125,6 @@ MEMO: chloe-name ( string -- name )
         a>
     ] with-scope ;
 
-: process-tag-children ( tag -- )
-    [ process-template ] each ;
-
 : a-tag ( tag -- )
     [ a-start-tag ]
     [ process-tag-children ]
@@ -156,7 +145,7 @@ MEMO: chloe-name ( string -- name )
             form>
         ] [
             hidden-form-field
-            "for" optional-attr [ component render-edit ] when*
+            "for" optional-attr [ hidden render ] when*
         ] bi
     ] with-scope ;
 
@@ -180,9 +169,9 @@ STRING: button-tag-markup
 : button-tag ( tag -- )
     button-tag-markup string>xml delegate
     {
-        [ >r tag-attrs chloe-attrs-only r> add-tag-attrs ]
-        [ >r tag-attrs non-chloe-attrs-only r> "button" tag-named add-tag-attrs ]
-        [ >r children>string 1array r> "button" tag-named set-tag-children ]
+        [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
+        [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
+        [ [ children>string 1array ] dip "button" tag-named set-tag-children ]
         [ nip ]
     } 2cleave process-chloe-tag ;
 
@@ -211,27 +200,58 @@ STRING: button-tag-markup
 : error-message-tag ( tag -- )
     children>string render-error ;
 
+: validation-messages-tag ( tag -- )
+    drop render-validation-messages ;
+
+: singleton-component-tag ( tag class -- )
+    [ "name" required-attr ] dip render ;
+
+: attrs>slots ( tag tuple -- )
+    [ attrs>> ] [ <mirror> ] bi* '[ swap tag>> , set-at ] assoc-each ;
+
+: tuple-component-tag ( tag class -- )
+    [ drop "name" required-attr ]
+    [ new [ attrs>slots ] keep ]
+    2bi render ;
+
 : process-chloe-tag ( tag -- )
     dup name-tag {
-        { "chloe" [ [ process-template ] each ] }
+        { "chloe" [ process-tag-children ] }
+
+        ! HTML head
         { "title" [ title-tag ] }
         { "write-title" [ write-title-tag ] }
         { "style" [ style-tag ] }
         { "write-style" [ write-style-tag ] }
         { "atom" [ atom-tag ] }
         { "write-atom" [ write-atom-tag ] }
-        { "view" [ view-tag ] }
-        { "edit" [ edit-tag ] }
-        { "summary" [ summary-tag ] }
+
+        ! HTML elements
         { "a" [ a-tag ] }
-        { "form" [ form-tag ] }
         { "button" [ button-tag ] }
+
+        ! Components
+        { "label" [ label singleton-component-tag ] }
+        { "link" [ link singleton-component-tag ] }
+        { "html" [ html singleton-component-tag ] }
+
+        ! Forms
+        { "form" [ form-tag ] }
         { "error-message" [ error-message-tag ] }
-        { "validation-message" [ drop render-validation-message ] }
+        { "validation-messages" [ validation-messages-tag ] }
+        { "hidden" [ hidden singleton-component-tag ] }
+        { "field" [ field tuple-component-tag ] }
+        { "password" [ password tuple-component-tag ] }
+        { "textarea" [ textarea tuple-component-tag ] }
+        { "choice" [ choice tuple-component-tag ] }
+        { "checkbox" [ checkbox tuple-component-tag ] }
+
+        ! Control flow
         { "if" [ if-tag ] }
         { "comment" [ drop ] }
         { "call-next-template" [ drop call-next-template ] }
-        [ "Unknown chloe tag: " swap append throw ]
+
+        [ "Unknown chloe tag: " prepend throw ]
     } case ;
 
 : process-tag ( tag -- )

extra/html/templates/chloe/test/test4.xml

@@ -2,7 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:if t:code="http.server.templating.chloe.tests:test4-aux?">
+	<t:if t:code="html.templates.chloe.tests:test4-aux?">
 		True
 	</t:if>
 

extra/html/templates/chloe/test/test5.xml

@@ -2,7 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:if t:code="http.server.templating.chloe.tests:test5-aux?">
+	<t:if t:code="html.templates.chloe.tests:test5-aux?">
 		True
 	</t:if>
 

extra/html/templates/chloe/test/test6.xml

@@ -2,7 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:if t:var="http.server.templating.chloe.tests:test6-aux?">
+	<t:if t:var="html.templates.chloe.tests:test6-aux?">
 		True
 	</t:if>
 

extra/html/templates/chloe/test/test7.xml

@@ -2,7 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:if t:var="http.server.templating.chloe.tests:test7-aux?">
+	<t:if t:var="html.templates.chloe.tests:test7-aux?">
 		True
 	</t:if>
 

extra/html/templates/fhtml/fhtml-tests.factor

@@ -1,10 +1,10 @@
 USING: io io.files io.streams.string io.encodings.utf8
-http.server.templating http.server.templating.fhtml kernel
+html.templates html.templates.fhtml kernel
 tools.test sequences parser ;
-IN: http.server.templating.fhtml.tests
+IN: html.templates.fhtml.tests
 
 : test-template ( path -- ? )
-    "resource:extra/http/server/templating/fhtml/test/"
+    "resource:extra/html/templates/fhtml/test/"
     prepend
     [
         ".fhtml" append <fhtml> [ call-template ] with-string-writer

extra/html/templates/fhtml/fhtml.factor

@@ -4,12 +4,10 @@
 USING: continuations sequences kernel namespaces debugger
 combinators math quotations generic strings splitting
 accessors assocs fry
-parser io io.files io.streams.string io.encodings.utf8 source-files
-html html.elements
-http.server.static http.server http.server.templating ;
-IN: http.server.templating.fhtml
-
-: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
+parser io io.files io.streams.string io.encodings.utf8
+html.elements
+html.templates ;
+IN: html.templates.fhtml
 
 ! We use a custom lexer so that %> ends a token even if not
 ! followed by whitespace
@@ -35,7 +33,7 @@ DEFER: <% delimiter
 : found-<% ( accum lexer col -- accum )
     [
         over line-text>>
-        >r >r column>> r> r> subseq parsed
+        [ column>> ] 2dip subseq parsed
         \ write-html parsed
     ] 2keep 2 + >>column drop ;
 
@@ -62,37 +60,20 @@ DEFER: <% delimiter
 
 : parse-template ( string -- quot )
     [
-        use [ clone ] change
-        templating-vocab use+
+        "quiet" on
+        parser-notes off
+        "html.templates.fhtml" use+
         string-lines parse-template-lines
-    ] with-scope ;
+    ] with-file-vocabs ;
 
-: eval-template ( string -- ) parse-template call ;
-
-: html-error. ( error -- )
-    <pre> error. </pre> ;
+: eval-template ( string -- )
+    parse-template call ;
 
 TUPLE: fhtml path ;
 
 C: <fhtml> fhtml
 
 M: fhtml call-template* ( filename -- )
-    '[
-        , path>> [
-            "quiet" on
-            parser-notes off
-            templating-vocab use+
-            ! so that reload works properly
-            dup source-file file set
-            utf8 file-contents
-            [ eval-template ] [ html-error. drop ] recover
-        ] with-file-vocabs
-    ] assert-depth ;
-
-! file responder integration
-: enable-fhtml ( responder -- responder )
-    [ <fhtml> serve-template ]
-    "application/x-factor-server-page"
-    pick special>> set-at ;
+    '[ , path>> utf8 file-contents eval-template ] assert-depth ;
 
 INSTANCE: fhtml template

extra/html/templates/templates.factor

@@ -0,0 +1,85 @@
+! Copyright (C) 2008 Slava Pestov.
+! 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.elements io.streams.string quotations ;
+IN: html.templates
+
+MIXIN: template
+
+GENERIC: call-template* ( template -- )
+
+M: string call-template* write ;
+
+M: callable call-template* call ;
+
+M: object call-template* output-stream get stream-copy ;
+
+ERROR: template-error template error ;
+
+M: template-error error.
+    "Error while processing template " write
+    [ template>> pprint ":" print nl ]
+    [ error>> error. ]
+    bi ;
+
+: call-template ( template -- )
+    [ call-template* ] [ template-error ] recover ;
+
+SYMBOL: title
+
+: set-title ( string -- )
+    title get >box ;
+
+: write-title ( -- )
+    title get value>> write ;
+
+SYMBOL: style
+
+: add-style ( string -- )
+    "\n" style get push-all
+         style get push-all ;
+
+: write-style ( -- )
+    style get >string write ;
+
+SYMBOL: atom-feed
+
+: set-atom-feed ( title url -- )
+    2array atom-feed get >box ;
+
+: write-atom-feed ( -- )
+    atom-feed get value>> [
+        <link "alternate" =rel "application/atom+xml" =type
+        [ first =title ] [ second =href ] bi
+        link/>
+    ] when* ;
+
+SYMBOL: nested-template?
+
+SYMBOL: next-template
+
+: call-next-template ( -- )
+    next-template get write-html ;
+
+M: f call-template* drop call-next-template ;
+
+: with-boilerplate ( body template -- )
+    [
+        title get [ <box> title set ] unless
+        atom-feed get [ <box> atom-feed set ] unless
+        style get [ SBUF" " clone style set ] unless
+
+        [
+            [
+                nested-template? on
+                call-template
+            ] with-string-writer
+            next-template set
+        ]
+        [ call-template ]
+        bi*
+    ] with-scope ; inline
+
+: template-convert ( template output -- )
+    utf8 [ call-template ] with-file-writer ;

extra/http/server/templating/templating.factor

@@ -1,27 +0,0 @@
-USING: accessors kernel fry io io.encodings.utf8 io.files
-http http.server debugger prettyprint continuations ;
-IN: http.server.templating
-
-MIXIN: template
-
-GENERIC: call-template* ( template -- )
-
-ERROR: template-error template error ;
-
-M: template-error error.
-    "Error while processing template " write
-    [ template>> pprint ":" print nl ]
-    [ error>> error. ]
-    bi ;
-
-: call-template ( template -- )
-    [ call-template* ] [ template-error ] recover ;
-
-M: template write-response-body* call-template ;
-
-: template-convert ( template output -- )
-    utf8 [ call-template ] with-file-writer ;
-
-! responder integration
-: serve-template ( template -- response )
-    '[ , call-template ] <html-content> ;

extra/validators/validators.factor

@@ -122,12 +122,7 @@ C: <validation-error> validation-error
     [ swap validation-error-for f ] recover ; inline
 
 : validate-value ( value name validators -- result )
-    '[
-        , at {
-            { [ dup pair? ] [ first ] }
-            { [ dup quotation? ] [ ] }
-        } cond call
-    ] validate ;
+    '[ , at call ] validate ;
 
 : required-values ( assoc -- )
     [ swap [ drop v-required ] validate drop ] assoc-each ;