factor/extra/html/components/components.factor

! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces io math.parser assocs classes
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 ;
IN: html.components

SYMBOL: values

: value values get at ;

: set-value values get set-at ;

: blank-values H{ } clone values set ;

: prepare-value ( name object -- value name object )
    [ [ value ] keep ] dip ; inline

: from-assoc ( assoc -- ) values get swap update ;

: from-tuple ( tuple -- ) <mirror> from-assoc ;

: deposit-values ( destination names -- )
    [ dup value ] H{ } map>assoc update ;

: deposit-slots ( destination names -- )
    [ <mirror> ] dip deposit-values ;

: with-each-index ( seq quot -- )
    '[
        [
            blank-values 1+ "index" set-value @
        ] with-scope
    ] each-index ; inline

: with-each-value ( seq quot -- )
    '[ "value" set-value @ ] with-each-index ; inline

: with-each-assoc ( seq quot -- )
    '[ from-assoc @ ] with-each-index ; inline

: with-each-tuple ( seq quot -- )
    '[ from-tuple @ ] with-each-index ; inline

: with-assoc-values ( assoc quot -- )
    '[ blank-values , from-assoc @ ] with-scope ; inline

: with-tuple-values ( assoc quot -- )
    '[ blank-values , from-tuple @ ] with-scope ; inline

: nest-values ( name quot -- )
    swap [
        [
            H{ } clone [ values set call ] keep
        ] with-scope
    ] dip set-value ; inline

: nest-tuple ( name quot -- )
    swap [
        [
            H{ } clone [ <mirror> values set call ] keep
        ] with-scope
    ] dip set-value ; inline

: object>string ( object -- string )
    {
        { [ dup real? ] [ number>string ] }
        { [ dup timestamp? ] [ timestamp>string ] }
        { [ dup string? ] [ ] }
        { [ dup word? ] [ word-name ] }
        { [ dup not ] [ drop "" ] }
    } cond ;

GENERIC: render* ( value name render -- )

: render ( name renderer -- )
    over named-validation-messages get at [
        [ value>> ] [ message>> ] bi
        [ -rot render* ] dip
        render-error
    ] [
        prepare-value render*
    ] if* ;

<PRIVATE

: render-input ( value name type -- )
    <input =type =name object>string =value input/> ;

PRIVATE>

SINGLETON: label

M: label render* 2drop object>string escape-string write ;

SINGLETON: hidden

M: hidden render* drop "hidden" render-input ;

: render-field ( value name size type -- )
    <input
        =type
        [ object>string =size ] when*
        =name
        object>string =value
    input/> ;

TUPLE: field size ;

: <field> ( -- field )
    field new ;

M: field render* size>> "text" render-field ;

TUPLE: password size ;

: <password> ( -- password )
    password new ;

M: password render*
    #! Don't send passwords back to the user
    [ drop "" ] 2dip size>> "password" render-field ;

! Text areas
TUPLE: textarea rows cols ;

: <textarea> ( -- renderer )
    textarea new ;

M: textarea render*
    <textarea
        [ rows>> [ object>string =rows ] when* ]
        [ cols>> [ object>string =cols ] when* ] bi
        =name
    textarea>
        object>string escape-string write
    </textarea> ;

! Choice
TUPLE: choice size multiple choices ;

: <choice> ( -- choice )
    choice new ;

: render-option ( text selected? -- )
    <option [ "true" =selected ] when option>
        object>string escape-string write
    </option> ;

: render-options ( options selected -- )
    '[ dup , member? render-option ] each ;

M: choice render*
    <select
        swap =name
        dup size>> [ object>string =size ] when*
        dup multiple>> [ "true" =multiple ] when
    select>
        [ choices>> value ] [ multiple>> ] bi
        [ swap ] [ swap 1array ] if
        render-options
    </select> ;

! Checkboxes
TUPLE: checkbox label ;

: <checkbox> ( -- checkbox )
    checkbox new ;

M: checkbox render*
    <input
        "checkbox" =type
        swap =name
        swap [ "true" =selected ] when
    input>
        label>> escape-string write
    </input> ;

! Link components
GENERIC: link-title ( obj -- string )
GENERIC: link-href ( obj -- url )

SINGLETON: link

M: link render*
    2drop
    <a dup link-href =href a>
        link-title object>string escape-string write
    </a> ;

! XMode code component
TUPLE: code mode ;

: <code> ( -- code )
    code new ;

M: code render*
    [ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;

! Farkup component
SINGLETON: farkup

M: farkup render*
    2drop string-lines "\n" join convert-farkup write ;

! Inspector component
SINGLETON: inspector

M: inspector render*
    2drop [ describe ] with-html-stream ;

! HTML component
SINGLETON: html

M: html render* 2drop write ;