1 ! Copyright (C) 2008 Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel accessors strings namespaces assocs hashtables
4 mirrors math fry sequences sequences.lib words continuations ;
7 TUPLE: form errors values validation-failed ;
16 [ clone ] change-errors
17 [ clone ] change-values ;
19 : check-value-name ( name -- name )
20 dup string? [ "Value name not a string" throw ] unless ;
25 : value ( name -- value )
26 check-value-name values at ;
28 : set-value ( value name -- )
29 check-value-name values set-at ;
31 : begin-form ( -- ) <form> form set ;
33 : prepare-value ( name object -- value name object )
34 [ [ value ] keep ] dip ; inline
36 : from-object ( object -- )
37 [ values ] [ make-mirror ] bi* update ;
39 : to-object ( destination names -- )
40 [ make-mirror ] [ values extract-keys ] bi* update ;
42 : with-each-value ( name quot -- )
52 : with-each-object ( name quot -- )
64 : with-form ( name quot -- )
67 [ nested-forms [ swap prefix ] change ]
73 : nest-form ( name quot -- )
80 ] dip set-value ; inline
82 TUPLE: validation-error value message ;
84 C: <validation-error> validation-error
86 : validation-error ( message -- )
91 : validation-failed? ( -- ? )
92 form get validation-failed>> ;
94 : define-validators ( class validators -- )
95 >hashtable "validators" set-word-prop ;
97 : validate ( value quot -- result )
98 [ <validation-error> ] recover ; inline
100 : validate-value ( name value quot -- )
102 dup validation-error? [ form get t >>validation-failed drop ] when
105 : validate-values ( assoc validators -- assoc' )
106 swap '[ dup , at _ validate-value ] assoc-each ;