Changeset 20782 in project


Ignore:
Timestamp:
10/11/10 01:30:57 (11 years ago)
Author:
Moritz Heidkamp
Message:

sxml-informal: switch to pre-post-order*

Location:
release/4/sxml-informal/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/sxml-informal/trunk/sxml-informal.scm

    r19590 r20782  
    88         
    99         (element (lambda parts
    10                     (lambda (tag name #!rest args #!key id)
    11                       (let* ((prefixed-name (conc (prefix) name))
     10                    (lambda (tag args)
     11                      (let* ((name (car args))
     12                             (args (cdr args))
     13                             (id (get-keyword id: args))
     14                             (prefixed-name (conc (prefix) name))
    1215                             (id (if id (conc (prefix) id) prefixed-name))
    1316                             (args (cons* prefixed-name id: id args))
     
    5962      (checkbox . ,(element (input "checkbox" checkable) label error))
    6063      (radio    . ,(let ((input (element (input "radio" checkable) label error)))
    61                      (lambda (tag name #!rest args #!key value (suffix (and value (conc "-" value))))
    62                        (apply input (cons* tag name id: (if suffix (conc name suffix) name) args)))))
     64                     (lambda (tag args)
     65                       (let* ((name (car args))
     66                              (args (cdr args))
     67                              (value (get-keyword value: args))
     68                              (suffix (or (get-keyword suffix: args) (and value (conc "-" value)))))
     69                         (input tag (cons* name id: (if suffix (conc name suffix) name) args))))))
    6370
    6471      (hidden   . ,(let ((input (input "hidden")))
    65                      (lambda (tag name value)
    66                        (car (input '() name value: value)))))
     72                     (lambda (tag args)
     73                       (let* ((name (car args))
     74                              (value (cadr args)))
     75                         (car (input '() name value: value))))))
    6776
    6877      (text     . ,(element label
     
    8291
    8392      (submit   . ,(let ((element (element (input "submit"))))
    84                      (lambda (tag label #!key (name "commit"))
    85                        (element tag name value: label))))
     93                     (lambda (tag args)
     94                       (let* ((label (car args))
     95                              (name (or (get-keyword name: (cdr args)) "commit")))
     96                         (element tag `(,name value: ,label))))))
    8697
    87       (fields *macro* . ,(lambda (tag . elements)
     98      (fields *macro* . ,(lambda (tag elements)
    8899                           (receive (options elements)
    89100                             (cond ((string? (car elements))
     
    101112                                                `((legend ,(alist-ref 'legend options)))
    102113                                                '())
    103                                           (ol ,@(pre-post-order elements informal-rules)))))))
     114                                          (ol ,@(pre-post-order* elements informal-rules)))))))
    104115
    105116      (informal *macro* . ,(let ((attrs? (compose (cut eq? '@ <>) car)))
    106                              (lambda (tag attrs . body)
    107                                (parameterize ((prefix (car (or (and (not (attrs? attrs))
    108                                                                     (alist-ref 'prefix attrs)) '("")))))
     117                             (lambda (tag els)
     118                               (let ((attrs (car els))
     119                                     (body (cdr els)))
     120                                 (parameterize ((prefix (car (or (and (not (attrs? attrs))
     121                                                                      (alist-ref 'prefix attrs)) '("")))))
     122                                   (let ((body (pre-post-order* body informal-rules)))
     123                                     `(form ,(if (attrs? attrs) attrs (assq '@ attrs)) ,@body)))))))
    109124
    110                                  (let ((body (pre-post-order body informal-rules)))
    111                                    `(form ,(if (attrs? attrs) attrs (assq '@ attrs)) ,@body))))))
    112 
    113       ,@alist-conv-rules)))
     125      ,@alist-conv-rules*)))
    114126
    115127)
  • release/4/sxml-informal/trunk/tests/run.scm

    r19590 r20782  
    55(define-syntax test-form
    66  (syntax-rules ()
    7     ((_ result form description) (test description result (pre-post-order form informal-rules)))
     7    ((_ result form description) (test description result (pre-post-order* form informal-rules)))
    88    ((_ result form) (test-form result form #f))))
    99
     
    5555(test-field '(li (@ (class "text foo")) (textarea (@ (id "foo") (name "foo")) "bar"))
    5656            '(text "foo" value: "bar"))
     57
     58(test-field '(li (@ (class "text foo"))
     59                 (label (@ (for "foo")) "a text")
     60                 (textarea (@ (id "foo") (name "foo")) #f))
     61            '(text "foo" label: "a text"))
    5762
    5863(test-field '(li (@ (class "select foo"))
Note: See TracChangeset for help on using the changeset viewer.