basis/html/forms/forms.factor

   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 words continuations ;
   5 IN: html.forms
   6
   7 TUPLE: form errors values validation-failed ;
   8
   9 : <form> ( -- form )
  10     form new
  11         V{ } clone >>errors
  12         H{ } clone >>values ;
  13
  14 M: form clone
  15     call-next-method
  16         [ clone ] change-errors
  17         [ clone ] change-values ;
  18
  19 : check-value-name ( name -- name )
  20     dup string? [ "Value name not a string" throw ] unless ;
  21
  22 : values ( -- assoc )
  23     form get values>> ;
  24
  25 : value ( name -- value )
  26     check-value-name values at ;
  27
  28 : set-value ( value name -- )
  29     check-value-name values set-at ;
  30
  31 : begin-form ( -- ) <form> form set ;
  32
  33 : prepare-value ( name object -- value name object )
  34     [ [ value ] keep ] dip ; inline
  35
  36 : from-object ( object -- )
  37     [ values ] [ make-mirror ] bi* update ;
  38
  39 : to-object ( destination names -- )
  40     [ make-mirror ] [ values extract-keys ] bi* update ;
  41
  42 : with-each-value ( name quot -- )
  43     [ value ] dip '[
  44         [
  45             form [ clone ] change
  46             1+ "index" set-value
  47             "value" set-value
  48             @
  49         ] with-scope
  50     ] each-index ; inline
  51
  52 : with-each-object ( name quot -- )
  53     [ value ] dip '[
  54         [
  55             begin-form
  56             1+ "index" set-value
  57             from-object
  58             @
  59         ] with-scope
  60     ] each-index ; inline
  61
  62 SYMBOL: nested-forms
  63
  64 : with-form ( name quot -- )
  65     '[
  66         ,
  67         [ nested-forms [ swap prefix ] change ]
  68         [ value form set ]
  69         bi
  70         @
  71     ] with-scope ; inline
  72
  73 : nest-form ( name quot -- )
  74     swap [
  75         [
  76             <form> form set
  77             call
  78             form get
  79         ] with-scope
  80     ] dip set-value ; inline
  81
  82 TUPLE: validation-error value message ;
  83
  84 C: <validation-error> validation-error
  85
  86 : validation-error ( message -- )
  87     form get
  88     t >>validation-failed
  89     errors>> push ;
  90
  91 : validation-failed? ( -- ? )
  92     form get validation-failed>> ;
  93
  94 : define-validators ( class validators -- )
  95     >hashtable "validators" set-word-prop ;
  96
  97 : validate ( value quot -- result )
  98     [ <validation-error> ] recover ; inline
  99
 100 : validate-value ( name value quot -- )
 101     validate
 102     dup validation-error? [ form get t >>validation-failed drop ] when
 103     swap set-value ;
 104
 105 : validate-values ( assoc validators -- assoc' )
 106     swap '[ dup , at _ validate-value ] assoc-each ;