1 ! Copyright (C) 2008, 2009 Slava Pestov
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs classes continuations hashtables kernel
4 math mirrors namespaces sequences strings words xml.syntax
8 TUPLE: form errors values validation-failed ;
17 [ clone ] change-errors
18 [ clone ] change-values ;
20 : check-value-name ( name -- name )
21 string check-instance ;
26 : value ( name -- value )
27 check-value-name values at ;
29 : set-value ( value name -- )
30 check-value-name values set-at ;
32 : begin-form ( -- ) <form> form set ;
34 : prepare-value ( name object -- value name object )
35 [ [ value ] keep ] dip ; inline
37 : from-object ( object -- )
38 [ values ] [ make-mirror ] bi* assoc-union! drop ;
40 : to-object ( destination names -- )
41 [ make-mirror ] [ values extract-keys ] bi* assoc-union! drop ;
43 : with-each-value ( name quot -- )
53 : with-each-object ( name quot -- )
65 : with-form ( name quot -- )
68 [ nested-forms [ swap prefix ] change ]
74 : nest-form ( name quot -- )
81 ] dip set-value ; inline
83 TUPLE: validation-error-state value message ;
85 C: <validation-error-state> validation-error-state
87 : validation-error ( message -- )
92 : validation-failed? ( -- ? )
93 form get validation-failed>> ;
95 : define-validators ( class validators -- )
96 >hashtable "validators" set-word-prop ;
98 : validate ( value quot -- result )
99 '[ _ call( value -- validated ) ] [ <validation-error-state> ] recover ;
101 : validate-value ( name value quot -- )
103 dup validation-error-state? [ form get t >>validation-failed drop ] when
106 : validate-values ( assoc validators -- )
107 swap '[ [ dup _ at ] dip validate-value ] assoc-each ;
109 : render-validation-errors ( -- )
112 [ [XML <li><-></li> XML] ] map
113 [XML <ul class="errors"><-></ul> XML] write-xml