Various furnace improvements; add present vocabulary for converting objects to human-readable strings

extra/furnace/actions/actions-tests.factor

@@ -21,3 +21,21 @@ blah
     init-request
     { } "action-1" get call-responder
 ] unit-test
+
+<action>
+    "a" >>rest
+    [ "a" param string>number sq ] >>display
+"action-2" set
+
+STRING: action-request-test-2
+GET http://foo/bar/123 HTTP/1.1
+
+blah
+;
+
+[ 25 ] [
+    action-request-test-2 lf>crlf
+    [ read-request ] with-string-reader
+    init-request
+    { "5" } "action-2" get call-responder
+] unit-test

extra/furnace/actions/actions.factor

@@ -17,7 +17,7 @@ IN: furnace.actions
 
 SYMBOL: params
 
-SYMBOL: rest-param
+SYMBOL: rest
 
 : render-validation-messages ( -- )
     validation-messages get
@@ -29,7 +29,7 @@ SYMBOL: rest-param
 
 CHLOE: validation-messages drop render-validation-messages ;
 
-TUPLE: action rest-param init display validate submit ;
+TUPLE: action rest init display validate submit ;
 
 : new-action ( class -- action )
     new
@@ -83,13 +83,13 @@ TUPLE: action rest-param init display validate submit ;
         [ flashed-variables <flash-redirect> ] [ <403> ] if*
     ] unless* ;
 
-: handle-rest-param ( path action -- assoc )
+: handle-rest ( path action -- assoc )
-    rest-param>> dup [ associate ] [ 2drop f ] if ;
+    rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;
 
 : init-action ( path action -- )
     blank-values
     init-validation
-    handle-rest-param
+    handle-rest
     request get request-params assoc-union params set ;
 
 M: action call-responder* ( path action -- response )

extra/furnace/furnace-tests.factor

@@ -30,6 +30,6 @@ 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' name='foo' value='&amp;&amp;&amp;'/>" ]
 [ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
 unit-test

extra/furnace/furnace.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel combinators assocs
 continuations namespaces sequences splitting words
-vocabs.loader classes
+vocabs.loader classes strings
-fry urls multiline
+fry urls multiline present
 xml
 xml.data
 xml.entities
@@ -52,12 +52,16 @@ GENERIC: modify-query ( query responder -- query' )
 
 M: object modify-query drop ;
 
-: adjust-url ( url -- url' )
+GENERIC: adjust-url ( url -- url' )
+
+M: url adjust-url
     clone
         [ [ modify-query ] each-responder ] change-query
         [ resolve-base-path ] change-path
     relative-to-request ;
 
+M: string adjust-url ;
+
 : <redirect> ( url -- response )
     adjust-url request get method>> {
         { "GET" [ <temporary-redirect> ] }
@@ -138,11 +142,11 @@ CHLOE: a
         <input
             "hidden" =type
             =name
-            object>string =value
+            present =value
         input/>
     ] [ 2drop ] if ;
 
-: form-nesting-key "factorformnesting" ;
+: form-nesting-key "__n" ;
 
 : form-magic ( tag -- )
     [ modify-form ] each-responder

extra/html/components/components-tests.factor

@@ -17,8 +17,6 @@ TUPLE: color red green blue ;
 
 [ ] [ "jimmy" "red" set-value ] unit-test
 
-[ "123.5" ] [ 123.5 object>string ] unit-test
-
 [ "jimmy" ] [
     [
         "red" label render

extra/html/components/components.factor

@@ -5,7 +5,7 @@ classes.tuple words arrays sequences sequences.lib splitting
 mirrors hashtables combinators continuations math strings
 fry locals calendar calendar.format xml.entities validators
 html.elements html.streams xmode.code2html farkup inspector
-lcs.diff2html urls ;
+lcs.diff2html urls present ;
 IN: html.components
 
 SYMBOL: values
@@ -29,19 +29,25 @@ SYMBOL: values
 : deposit-slots ( destination names -- )
     [ <mirror> ] dip deposit-values ;
 
-: with-each-index ( name quot -- )
+: with-each-value ( name quot -- )
     [ value ] dip '[
         [
-            blank-values
+            values [ clone ] change
-            1+ "index" set-value @
+            1+ "index" set-value
+            "value" set-value
+            @
         ] with-scope
     ] each-index ; inline
 
-: with-each-value ( name quot -- )
-    '[ "value" set-value @ ] with-each-index ; inline
-
 : with-each-object ( name quot -- )
-    '[ from-object @ ] with-each-index ; inline
+    [ value ] dip '[
+        [
+            blank-values
+            1+ "index" set-value
+            from-object
+            @
+        ] with-scope
+    ] each-index ; inline
 
 SYMBOL: nested-values
 
@@ -75,13 +81,13 @@ GENERIC: render* ( value name render -- )
 <PRIVATE
 
 : render-input ( value name type -- )
-    <input =type =name object>string =value input/> ;
+    <input =type =name present =value input/> ;
 
 PRIVATE>
 
 SINGLETON: label
 
-M: label render* 2drop object>string escape-string write ;
+M: label render* 2drop present escape-string write ;
 
 SINGLETON: hidden
 
@@ -90,9 +96,9 @@ M: hidden render* drop "hidden" render-input ;
 : render-field ( value name size type -- )
     <input
         =type
-        [ object>string =size ] when*
+        [ present =size ] when*
         =name
-        object>string =value
+        present =value
     input/> ;
 
 TUPLE: field size ;
@@ -119,11 +125,11 @@ TUPLE: textarea rows cols ;
 
 M: textarea render*
     <textarea
-        [ rows>> [ object>string =rows ] when* ]
+        [ rows>> [ present =rows ] when* ]
-        [ cols>> [ object>string =cols ] when* ] bi
+        [ cols>> [ present =cols ] when* ] bi
         =name
     textarea>
-        object>string escape-string write
+        present escape-string write
     </textarea> ;
 
 ! Choice
@@ -134,7 +140,7 @@ TUPLE: choice size multiple choices ;
 
 : render-option ( text selected? -- )
     <option [ "true" =selected ] when option>
-        object>string escape-string write
+        present escape-string write
     </option> ;
 
 : render-options ( options selected -- )
@@ -143,7 +149,7 @@ TUPLE: choice size multiple choices ;
 M: choice render*
     <select
         swap =name
-        dup size>> [ object>string =size ] when*
+        dup size>> [ present =size ] when*
         dup multiple>> [ "true" =multiple ] when
     select>
         [ choices>> value ] [ multiple>> ] bi
@@ -170,12 +176,18 @@ M: checkbox render*
 GENERIC: link-title ( obj -- string )
 GENERIC: link-href ( obj -- url )
 
+M: string link-title ;
+M: string link-href ;
+
+M: url link-title ;
+M: url link-href ;
+
 SINGLETON: link
 
 M: link render*
     2drop
     <a dup link-href =href a>
-        link-title object>string escape-string write
+        link-title present escape-string write
     </a> ;
 
 ! XMode code component

extra/html/elements/elements.factor

@@ -5,7 +5,7 @@
 
 USING: io kernel namespaces prettyprint quotations
 sequences strings words xml.entities compiler.units effects
-urls math math.parser combinators calendar calendar.format ;
+urls math math.parser combinators present ;
 
 IN: html.elements
 
@@ -127,22 +127,11 @@ SYMBOL: html
     dup def-for-html-word-<foo
     def-for-html-word-foo/> ;
 
-: object>string ( object -- string )
-    #! Should this be generic and in the core?
-    {
-        { [ dup real? ] [ number>string ] }
-        { [ dup timestamp? ] [ timestamp>string ] }
-        { [ dup url? ] [ url>string ] }
-        { [ dup string? ] [ ] }
-        { [ dup word? ] [ word-name ] }
-        { [ dup not ] [ drop "" ] }
-    } cond ;
-
 : write-attr ( value name -- )
     " " write-html
     write-html
     "='" write-html
-    object>string escape-quoted-string write-html
+    present escape-quoted-string write-html
     "'" write-html ;
 
 : attribute-effect T{ effect f { "string" } 0 } ;

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

@@ -151,7 +151,7 @@ TUPLE: person first-name last-name ;
 
 [ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
 
-[ "<form method='POST' action='foo'><input type='hidden' name='factorformnesting' value='a'/></form>" ] [
+[ "<form method='POST' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
     [
         "test10" test-template call-template
     ] run-template
@@ -168,3 +168,15 @@ TUPLE: person first-name last-name ;
         "test11" test-template call-template
     ] run-template [ blank? not ] filter
 ] unit-test
+
+[ ] [
+    blank-values
+    { "a" "b" } "choices" set-value
+    "true" "b" set-value
+] unit-test
+
+[ "<input type='checkbox' name='a'>a</input><input type='checkbox' name='b' checked='true'>b</input>" ] [
+    [
+        "test12" test-template call-template
+    ] run-template
+] unit-test

extra/html/templates/chloe/chloe.factor

@@ -3,7 +3,7 @@
 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 mirrors fry math urls
+unicode.case tuple-syntax mirrors fry math urls present
 multiline xml xml.data xml.writer xml.utilities
 html.elements
 html.components
@@ -127,7 +127,7 @@ CHLOE-TUPLE: code
 : expand-attrs ( tag -- tag )
     dup [ tag? ] is? [
         clone [
-            [ "@" ?head [ value object>string ] when ] assoc-map
+            [ "@" ?head [ value present ] when ] assoc-map
         ] change-attrs
     ] when ;
 

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

@@ -0,0 +1,3 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:each t:name="choices"><t:checkbox t:name="@value" t:label="@value" /></t:each></t:chloe>

extra/http/http.factor

@@ -4,7 +4,7 @@ USING: accessors kernel combinators math namespaces
 
 assocs sequences splitting sorting sets debugger
 strings vectors hashtables quotations arrays byte-arrays
-math.parser calendar calendar.format
+math.parser calendar calendar.format present
 
 io io.server io.sockets.secure
 
@@ -54,11 +54,9 @@ IN: http
 
 : header-value>string ( value -- string )
     {
-        { [ dup number? ] [ number>string ] }
         { [ dup timestamp? ] [ timestamp>http-string ] }
-        { [ dup url? ] [ url>string ] }
+        { [ dup array? ] [ [ header-value>string ] map "; " join ] }
-        { [ dup string? ] [ ] }
+        [ present ]
-        { [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
     } cond ;
 
 : check-header-string ( str -- str )
@@ -231,7 +229,7 @@ TUPLE: post-data raw content content-type ;
     dup method>> write bl ;
 
 : write-request-url ( request -- request )
-    dup url>> relative-url url>string write bl ;
+    dup url>> relative-url present write bl ;
 
 : write-version ( request -- request )
     "HTTP/" write dup request-version write crlf ;

extra/http/server/dispatchers/dispatchers.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces sequences assocs accessors
+USING: kernel namespaces sequences assocs accessors splitting
-http http.server http.server.responses ;
+unicode.case http http.server http.server.responses ;
 IN: http.server.dispatchers
 
 TUPLE: dispatcher default responders ;
@@ -31,8 +31,11 @@ TUPLE: vhost-dispatcher default responders ;
 : <vhost-dispatcher> ( -- dispatcher )
     vhost-dispatcher new-dispatcher ;
 
+: canonical-host ( host -- host' )
+    >lower "www." ?head drop "." ?tail drop ;
+
 : find-vhost ( dispatcher -- responder )
-    request get url>> host>> over responders>> at*
+    request get url>> host>> canonical-host over responders>> at*
     [ nip ] [ drop default>> ] if ;
 
 M: vhost-dispatcher call-responder* ( path dispatcher -- response )

extra/http/server/redirection/redirection-tests.factor

@@ -1,6 +1,6 @@
 IN: http.server.redirection.tests
 USING: http http.server.redirection urls accessors
-namespaces tools.test ;
+namespaces tools.test present ;
 
 \ relative-to-request must-infer
 
@@ -15,34 +15,34 @@ namespaces tools.test ;
     request set
 
     [ "http://www.apple.com:80/xxx/bar" ] [ 
-        <url> relative-to-request url>string 
+        <url> relative-to-request present 
     ] unit-test
 
     [ "http://www.apple.com:80/xxx/baz" ] [
-        <url> "baz" >>path relative-to-request url>string
+        <url> "baz" >>path relative-to-request present
     ] unit-test
     
     [ "http://www.apple.com:80/xxx/baz?c=d" ] [
-        <url> "baz" >>path { { "c" "d" } } >>query relative-to-request url>string
+        <url> "baz" >>path { { "c" "d" } } >>query relative-to-request present
     ] unit-test
     
     [ "http://www.apple.com:80/xxx/bar?c=d" ] [
-        <url> { { "c" "d" } } >>query relative-to-request url>string
+        <url> { { "c" "d" } } >>query relative-to-request present
     ] unit-test
     
     [ "http://www.apple.com:80/flip" ] [
-        <url> "/flip" >>path relative-to-request url>string
+        <url> "/flip" >>path relative-to-request present
     ] unit-test
     
     [ "http://www.apple.com:80/flip?c=d" ] [
-        <url> "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string
+        <url> "/flip" >>path { { "c" "d" } } >>query relative-to-request present
     ] unit-test
     
     [ "http://www.jedit.org:80/" ] [
-        "http://www.jedit.org" >url relative-to-request url>string
+        "http://www.jedit.org" >url relative-to-request present
     ] unit-test
     
     [ "http://www.jedit.org:80/?a=b" ] [
-        "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request url>string
+        "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request present
     ] unit-test
 ] with-scope

extra/present/present.factor

@@ -0,0 +1,15 @@
+USING: math math.parser calendar calendar.format strings words
+kernel ;
+IN: present
+
+GENERIC: present ( object -- string )
+
+M: real present number>string ;
+
+M: timestamp present timestamp>string ;
+
+M: string present ;
+
+M: word present word-name ;
+
+M: f present drop "" ;

extra/rss/rss.factor

@@ -4,7 +4,7 @@ USING: xml.utilities kernel assocs xml.generator math.order
     strings sequences xml.data xml.writer
     io.streams.string combinators xml xml.entities io.files io
     http.client namespaces xml.generator hashtables
-    calendar.format accessors continuations urls ;
+    calendar.format accessors continuations urls present ;
 IN: rss
 
 : any-tag-named ( tag names -- tag-inside )
@@ -104,7 +104,7 @@ C: <entry> entry
 : entry, ( entry -- )
     "entry" [
         dup title>> "title" { { "type" "html" } } simple-tag*,
-        "link" over link>> dup url? [ url>string ] when "href" associate contained*,
+        "link" over link>> dup url? [ present ] when "href" associate contained*,
         dup pub-date>> timestamp>rfc3339 "published" simple-tag,
         description>> [ "content" { { "type" "html" } } simple-tag*, ] when*
     ] tag, ;
@@ -112,6 +112,6 @@ C: <entry> entry
 : feed>xml ( feed -- xml )
     "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
         dup title>> "title" simple-tag,
-        "link" over link>> dup url? [ url>string ] when "href" associate contained*,
+        "link" over link>> dup url? [ present ] when "href" associate contained*,
         entries>> [ entry, ] each
     ] make-xml* ;

extra/urls/urls-tests.factor

@@ -1,5 +1,7 @@
 IN: urls.tests
-USING: urls tools.test tuple-syntax arrays kernel assocs ;
+USING: urls urls.private tools.test
+tuple-syntax arrays kernel assocs
+present ;
 
 [ "hello%20world" ] [ "hello world" url-encode ] unit-test
 [ "hello world" ] [ "hello%20world" url-decode ] unit-test
@@ -110,7 +112,7 @@ urls [
 ] assoc-each
 
 urls [
-    swap [ 1array ] [ [ url>string ] curry ] bi* unit-test
+    swap [ 1array ] [ [ present ] curry ] bi* unit-test
 ] assoc-each
 
 [ "b" ] [ "a" "b" url-append-path ] unit-test

extra/urls/urls.factor

@@ -4,7 +4,7 @@ USING: kernel unicode.categories combinators sequences splitting
 fry namespaces assocs arrays strings io.sockets
 io.sockets.secure io.encodings.string io.encodings.utf8
 math math.parser accessors mirrors parser
-prettyprint.backend hashtables ;
+prettyprint.backend hashtables present ;
 IN: urls
 
 : url-quotable? ( ch -- ? )
@@ -14,19 +14,25 @@ IN: urls
         { [ dup letter? ] [ t ] }
         { [ dup LETTER? ] [ t ] }
         { [ dup digit? ] [ t ] }
-        { [ dup "/_-.:" member? ] [ t ] }
+        { [ dup "/_-." member? ] [ t ] }
         [ f ]
     } cond nip ; foldable
 
+<PRIVATE
+
 : push-utf8 ( ch -- )
     1string utf8 encode
     [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
 
+PRIVATE>
+
 : url-encode ( str -- str )
     [
         [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
     ] "" make ;
 
+<PRIVATE
+
 : url-decode-hex ( index str -- )
     2dup length 2 - >= [
         2drop
@@ -51,9 +57,13 @@ IN: urls
         ] if url-decode-iter
     ] if ;
 
+PRIVATE>
+
 : url-decode ( str -- str )
     [ 0 swap url-decode-iter ] "" make utf8 decode ;
 
+<PRIVATE
+
 : add-query-param ( value key assoc -- )
     [
         at [
@@ -65,6 +75,8 @@ IN: urls
         ] when*
     ] 2keep set-at ;
 
+PRIVATE>
+
 : query>assoc ( query -- assoc )
     dup [
         "&" split H{ } clone [
@@ -77,11 +89,7 @@ IN: urls
 
 : assoc>query ( hash -- str )
     [
-        {
+        dup array? [ [ present ] map ] [ present 1array ] if
-            { [ dup number? ] [ number>string 1array ] }
-            { [ dup string? ] [ 1array ] }
-            { [ dup sequence? ] [ ] }
-        } cond
     ] assoc-map
     [
         [
@@ -108,6 +116,8 @@ TUPLE: url protocol username password host port path query anchor ;
         ] when
     ] bi* ;
 
+<PRIVATE
+
 : parse-host-part ( url protocol rest -- url string' )
     [ >>protocol ] [
         "//" ?head [ "Invalid URL" throw ] unless
@@ -121,6 +131,8 @@ TUPLE: url protocol username password host port path query anchor ;
         ] [ "/" prepend ] bi*
     ] bi* ;
 
+PRIVATE>
+
 GENERIC: >url ( obj -- url )
 
 M: url >url ;
@@ -135,6 +147,8 @@ M: string >url
     ]
     [ url-decode >>anchor ] bi* ;
 
+<PRIVATE
+
 : unparse-username-password ( url -- )
     dup username>> dup [
         % password>> [ ":" % % ] when* "@" %
@@ -150,7 +164,7 @@ M: string >url
         [ path>> "/" head? [ "/" % ] unless ]
     } cleave ;
 
-: url>string ( url -- string )
+M: url present
     [
         {
             [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
@@ -169,6 +183,8 @@ M: string >url
         [ [ "/" last-split1 drop "/" ] dip 3append ]
     } cond ;
 
+PRIVATE>
+
 : derive-url ( base url -- url' )
     [ clone dup ] dip
     2dup [ path>> ] bi@ url-append-path
@@ -199,4 +215,4 @@ M: string >url
 ! Literal syntax
 : URL" lexer get skip-blank parse-string >url parsed ; parsing
 
-M: url pprint* dup url>string "URL\" " "\"" pprint-string ;
+M: url pprint* dup present "URL\" " "\"" pprint-string ;