107 lines
2.4 KiB
Factor
107 lines
2.4 KiB
Factor
|
! Copyright (C) 2008 Slava Pestov
|
||
|
|
! See http://factorcode.org/license.txt for BSD license.
|
||
|
|
USING: kernel accessors strings namespaces assocs hashtables
|
||
|
|
mirrors math fry sequences sequences.lib words continuations ;
|
||
|
|
IN: html.forms
|
||
|
|
|
||
|
|
TUPLE: form errors values validation-failed ;
|
||
|
|
|
||
|
|
: <form> ( -- form )
|
||
|
|
form new
|
||
|
|
V{ } clone >>errors
|
||
|
|
H{ } clone >>values ;
|
||
|
|
|
||
|
|
M: form clone
|
||
|
|
call-next-method
|
||
|
|
[ clone ] change-errors
|
||
|
|
[ clone ] change-values ;
|
||
|
|
|
||
|
|
: check-value-name ( name -- name )
|
||
|
|
dup string? [ "Value name not a string" throw ] unless ;
|
||
|
|
|
||
|
|
: values ( -- assoc )
|
||
|
|
form get values>> ;
|
||
|
|
|
||
|
|
: value ( name -- value )
|
||
|
|
check-value-name values at ;
|
||
|
|
|
||
|
|
: set-value ( value name -- )
|
||
|
|
check-value-name values set-at ;
|
||
|
|
|
||
|
|
: begin-form ( -- ) <form> form set ;
|
||
|
|
|
||
|
|
: prepare-value ( name object -- value name object )
|
||
|
|
[ [ value ] keep ] dip ; inline
|
||
|
|
|
||
|
|
: from-object ( object -- )
|
||
|
|
[ values ] [ make-mirror ] bi* update ;
|
||
|
|
|
||
|
|
: to-object ( destination names -- )
|
||
|
|
[ make-mirror ] [ values extract-keys ] bi* update ;
|
||
|
|
|
||
|
|
: with-each-value ( name quot -- )
|
||
|
|
[ value ] dip '[
|
||
|
|
[
|
||
|
|
form [ clone ] change
|
||
|
|
1+ "index" set-value
|
||
|
|
"value" set-value
|
||
|
|
@
|
||
|
|
] with-scope
|
||
|
|
] each-index ; inline
|
||
|
|
|
||
|
|
: with-each-object ( name quot -- )
|
||
|
|
[ value ] dip '[
|
||
|
|
[
|
||
|
|
begin-form
|
||
|
|
1+ "index" set-value
|
||
|
|
from-object
|
||
|
|
@
|
||
|
|
] with-scope
|
||
|
|
] each-index ; inline
|
||
|
|
|
||
|
|
SYMBOL: nested-forms
|
||
|
|
|
||
|
|
: with-form ( name quot -- )
|
||
|
|
'[
|
||
|
|
,
|
||
|
|
[ nested-forms [ swap prefix ] change ]
|
||
|
|
[ value form set ]
|
||
|
|
bi
|
||
|
|
@
|
||
|
|
] with-scope ; inline
|
||
|
|
|
||
|
|
: nest-form ( name quot -- )
|
||
|
|
swap [
|
||
|
|
[
|
||
|
|
<form> form set
|
||
|
|
call
|
||
|
|
form get
|
||
|
|
] with-scope
|
||
|
|
] dip set-value ; inline
|
||
|
|
|
||
|
|
TUPLE: validation-error value message ;
|
||
|
|
|
||
|
|
C: <validation-error> validation-error
|
||
|
|
|
||
|
|
: validation-error ( message -- )
|
||
|
|
form get
|
||
|
|
t >>validation-failed
|
||
|
|
errors>> push ;
|
||
|
|
|
||
|
|
: validation-failed? ( -- ? )
|
||
|
|
form get validation-failed>> ;
|
||
|
|
|
||
|
|
: define-validators ( class validators -- )
|
||
|
|
>hashtable "validators" set-word-prop ;
|
||
|
|
|
||
|
|
: validate ( value quot -- result )
|
||
|
|
[ <validation-error> ] recover ; inline
|
||
|
|
|
||
|
|
: validate-value ( name value quot -- )
|
||
|
|
validate
|
||
|
|
dup validation-error? [ form get t >>validation-failed drop ] when
|
||
|
|
swap set-value ;
|
||
|
|
|
||
|
|
: validate-values ( assoc validators -- assoc' )
|
||
|
|
swap '[ dup , at _ validate-value ] assoc-each ;
|