: set-value values get set-at ;
-: validate ( value component -- result )
- '[
- ,
- over empty? [
- [ default>> [ v-default ] when* ]
- [ required>> [ v-required ] when ]
- bi
- ] [ validate* ] if
- ] with-validator ;
+: blank-values H{ } clone values set ;
-: render-view ( component -- )
- [ id>> value ] [ render-view* ] bi ;
+: from-tuple <mirror> values set ;
-: render-error ( error -- )
- <span "error" =class span> write </span> ;
+: values-tuple values get mirror-object ;
-: render-edit ( component -- )
- dup id>> value dup validation-error? [
- [ reason>> ] [ value>> ] bi rot render-error*
- ] [
- swap [ default>> or ] keep render-edit*
- ] if ;
-
-: <component> ( id class -- component )
- \ component new
- swap construct-delegate
- swap >>id ; inline
-
-! Forms
-TUPLE: form view-template edit-template components ;
-
-: <form> ( id -- form )
- form <component>
- V{ } clone >>components ;
-
-: add-field ( form component -- form )
- dup id>> pick components>> set-at ;
-
-: with-form ( form quot -- )
- >r components>> components r> with-variable ; inline
-
-: set-defaults ( form -- )
- [
- components get [
- swap values get [
- swap default>> or
- ] change-at
- ] assoc-each
- ] with-form ;
-
-: view-form ( form -- )
- dup view-template>> '[ , run-template ] with-form ;
-
-: edit-form ( form -- )
- dup edit-template>> '[ , run-template ] with-form ;
-
-: validate-param ( id component -- )
- [ [ params get at ] [ validate ] bi* ]
- [ drop set-value ] 2bi ;
-
-: (validate-form) ( form -- error? )
- [
- validation-failed? off
- components get [ validate-param ] assoc-each
- validation-failed? get
- ] with-form ;
-
-: validate-form ( form -- )
- (validate-form) [ validation-failed ] when ;
+: render-view ( component -- )
+ [ id>> value ] [ component-string ] [ renderer>> ] tri
+ render-view* ;
-: blank-values H{ } clone values set ;
+<PRIVATE
-: from-tuple <mirror> values set ;
+: render-edit-string ( string component -- )
+ [ id>> ] [ renderer>> ] bi render-edit* ;
-: values-tuple values get mirror-object ;
+: render-edit-error ( component -- )
+ [ id>> value ] keep
+ [ [ value>> ] dip render-edit-string ]
+ [ drop reason>> render-error ] 2bi ;
-! ! !
-! Canned components: for simple applications and prototyping
-! ! !
+: value-or-default ( component -- value )
+ [ id>> value ] [ default>> ] bi or ;
-: render-input ( value component type -- )
- <input
- =type
- id>> [ =id ] [ =name ] bi
- =value
- input/> ;
+: render-edit-value ( component -- )
+ [ value-or-default ]
+ [ component-string ]
+ [ render-edit-string ]
+ tri ;
-! Hidden fields
-TUPLE: hidden ;
+PRIVATE>
-: <hidden> ( component -- component )
- hidden construct-delegate ;
+: render-edit ( component -- )
+ dup id>> value validation-error?
+ [ render-edit-error ] [ render-edit-value ] if ;
-M: hidden render-view*
- 2drop ;
+: validate ( value component -- result )
+ '[
+ ,
+ over empty? [
+ [ default>> [ v-default ] when* ]
+ [ required>> [ v-required ] when ]
+ bi
+ ] [ validate* ] if
+ ] with-validator ;
-M: hidden render-edit*
- >r dup number? [ number>string ] when r>
- "hidden" render-input ;
+: new-component ( id class renderer -- component )
- swap construct-empty
++ swap new
+ swap >>renderer
+ swap >>id
+ init ; inline
! String input fields
-TUPLE: string min-length max-length ;
-
-: <string> ( id -- component ) string <component> ;
+TUPLE: string < component one-line min-length max-length ;
-M: string validate*
- [ v-one-line ] [
- [ min-length>> [ v-min-length ] when* ]
- [ max-length>> [ v-max-length ] when* ]
- bi
- ] bi* ;
+: new-string ( id class -- component )
+ "text" <field> new-component
+ t >>one-line ; inline
-M: string render-view*
- drop write ;
+: <string> ( id -- component )
+ string new-string ;
-M: string render-edit*
- "text" render-input ;
+M: string validate*
+ [ one-line>> [ v-one-line ] when ]
+ [ min-length>> [ v-min-length ] when* ]
+ [ max-length>> [ v-max-length ] when* ]
+ tri ;
-M: string render-error*
- "text" render-input render-error ;
+M: string component-string
+ drop ;
! Username fields
-TUPLE: username ;
+TUPLE: username < string ;
+
+M: username init
+ 2 >>min-length
+ 20 >>max-length ;
: <username> ( id -- component )
- <string> username construct-delegate
- 2 >>min-length
- 20 >>max-length ;
+ username new-string ;
M: username validate*
- delegate validate* v-one-word ;
+ call-next-method v-one-word ;
! E-mail fields
-TUPLE: email ;
+TUPLE: email < string ;
: <email> ( id -- component )
- <string> email construct-delegate
+ email new-string
5 >>min-length
60 >>max-length ;