basis/html/forms/forms.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel accessors strings namespaces assocs hashtables io
   4 mirrors math fry sequences words continuations
   5 xml.entities xml.writer xml.syntax ;
   6 IN: html.forms
   7
   8 TUPLE: form errors values validation-failed ;
   9
  10 : <form> ( -- form )
  11     form new
  12         V{ } clone >>errors
  13         H{ } clone >>values ;
  14
  15 M: form clone
  16     call-next-method
  17         [ clone ] change-errors
  18         [ clone ] change-values ;
  19
  20 : check-value-name ( name -- name )
  21     dup string? [ "Value name not a string" throw ] unless ;
  22
  23 : values ( -- assoc )
  24     form get values>> ;
  25
  26 : value ( name -- value )
  27     check-value-name values at ;
  28
  29 : set-value ( value name -- )
  30     check-value-name values set-at ;
  31
  32 : begin-form ( -- ) <form> form set ;
  33
  34 : prepare-value ( name object -- value name object )
  35     [ [ value ] keep ] dip ; inline
  36
  37 : from-object ( object -- )
  38     [ values ] [ make-mirror ] bi* update ;
  39
  40 : to-object ( destination names -- )
  41     [ make-mirror ] [ values extract-keys ] bi* update ;
  42
  43 : with-each-value ( name quot -- )
  44     [ value ] dip '[
  45         [
  46             form [ clone ] change
  47             1 + "index" set-value
  48             "value" set-value
  49             @
  50         ] with-scope
  51     ] each-index ; inline
  52
  53 : with-each-object ( name quot -- )
  54     [ value ] dip '[
  55         [
  56             begin-form
  57             1 + "index" set-value
  58             from-object
  59             @
  60         ] with-scope
  61     ] each-index ; inline
  62
  63 SYMBOL: nested-forms
  64
  65 : with-form ( name quot -- )
  66     '[
  67         _
  68         [ nested-forms [ swap prefix ] change ]
  69         [ value form set ]
  70         bi
  71         @
  72     ] with-scope ; inline
  73
  74 : nest-form ( name quot -- )
  75     swap [
  76         [
  77             <form> form set
  78             call
  79             form get
  80         ] with-scope
  81     ] dip set-value ; inline
  82
  83 TUPLE: validation-error value message ;
  84
  85 C: <validation-error> validation-error
  86
  87 : validation-error ( message -- )
  88     form get
  89     t >>validation-failed
  90     errors>> push ;
  91
  92 : validation-failed? ( -- ? )
  93     form get validation-failed>> ;
  94
  95 : define-validators ( class validators -- )
  96     >hashtable "validators" set-word-prop ;
  97
  98 : validate ( value quot -- result )
  99     '[ _ call( value -- validated ) ] [ <validation-error> ] recover ;
 100
 101 : validate-value ( name value quot -- )
 102     validate
 103     dup validation-error? [ form get t >>validation-failed drop ] when
 104     swap set-value ;
 105
 106 : validate-values ( assoc validators -- )
 107     swap '[ [ dup _ at ] dip validate-value ] assoc-each ;
 108
 109 : render-validation-errors ( -- )
 110     form get errors>>
 111     [
 112         [ [XML <li><-></li> XML] ] map
 113         [XML <ul class="errors"><-></ul> XML] write-xml
 114     ] unless-empty ;