Changeset 20995 in project


Ignore:
Timestamp:
10/24/10 20:56:08 (8 years ago)
Author:
sjamaan
Message:

Fix starred->normal-transformation-rules (and the broken test...) and add tests for shortcut rules, which are now transformed to be starred

Location:
release/4/sxml-fu/trunk
Files:
3 edited

Legend:

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

    r20970 r20995  
    8181(define (starred->normal-transformation-rules rules)
    8282  (traverse-rules/converter rules (lambda (handler)
    83                                     (lambda (element children)
     83                                    (lambda (element . children)
    8484                                      (handler element children)))))
    8585
  • release/4/sxml-fu/trunk/sxml-shortcuts.scm

    r20046 r20995  
    2929
    3030(module sxml-shortcuts
    31   (shortcut-rules)
     31  (shortcut-rules shortcut-rules*)
    3232
    3333(import chicken scheme)
    3434
    35 (require-extension srfi-1 uri-common sxml-transforms)
     35(require-extension srfi-1 uri-common sxml-transforms sxml-fu)
    3636
    37 (define shortcut-rules
    38   `((url *macro* . ,(lambda (tag href . contents)
    39                       (let ((href (if (uri-reference? href)
    40                                       (uri->string href)
    41                                       href)))
     37(define shortcut-rules*
     38  `((url *macro* . ,(lambda (tag contents)
     39                      (let ((href (if (uri-reference? (car contents))
     40                                      (uri->string (car contents))
     41                                      (car contents))))
    4242                       `(a (@ (href ,href))
    43                            ,@(if (not (null? contents))
    44                                  contents
     43                           ,@(if (not (null? (cdr contents)))
     44                                 (cdr contents)
    4545                                 (list href))))))
    46     (pic *macro* . ,(lambda (tag src alt . rest)
    47                       (let ((src (if (uri-reference? src)
    48                                      (uri->string src)
    49                                      src)))
     46    (pic *macro* . ,(lambda (tag contents)
     47                      (let ((src (if (uri-reference? (car contents))
     48                                     (uri->string (car contents))
     49                                     (car contents)))
     50                            (alt (cadr contents))
     51                            (rest (cddr contents)))
    5052                        (let-optionals* rest ((title alt) more)
    5153                                        `(img (@ ,@(append `((src ,src)
     
    5355                                                             (title ,title)
    5456                                                             ,@more))))))))
    55     (movie *macro* . ,(lambda (tag src title . rest)
    56                         (let ((src (if (uri-reference? src)
    57                                       (uri->string src)
    58                                       src)))
     57    ;; Maybe this one should be deprecated in favor of video?
     58    ;; It's too quicktime-specific anyway...
     59    (movie *macro* . ,(lambda (tag contents)
     60                        (let ((src (if (uri-reference? (car contents))
     61                                       (uri->string (car contents))
     62                                       (car contents)))
     63                              (title (cadr contents))
     64                              (rest (cddr contents)))
    5965                         `(object (@ (type "video/quicktime"))
    6066                                  (param (@ (name "src") (value ,src)))
     
    6369                                  ;; Fallback if no viewer
    6470                                  (url ,src ,title)))))
    65     ,@alist-conv-rules))
     71    . ,alist-conv-rules*))
     72
     73(define shortcut-rules (normal->starred-transformation-rules shortcut-rules*))
     74
    6675)
    67 
  • release/4/sxml-fu/trunk/tests/run.scm

    r20980 r20995  
    1 (use test sxml-fu sxml-transforms)
     1(use test sxml-transforms sxml-fu sxml-shortcuts)
    22
    33(define normal-rules
     
    3535(test-begin "sxml-fu")
    3636
    37 (test expected-output (pre-post-order input normal-rules)) ; Sanity check
    38 (test expected-output
    39       (pre-post-order* input
    40                        (normal->starred-transformation-rules normal-rules)))
    41 ;; Converted back
    42 (test expected-output
    43       (pre-post-order* input
    44                        (starred->normal-transformation-rules
    45                         (normal->starred-transformation-rules normal-rules))))
     37(test-group "transformation rules conversion"
     38  (test "sanity check" expected-output (pre-post-order input normal-rules))
     39  (test "normal->starred" expected-output
     40        (pre-post-order* input
     41                         (normal->starred-transformation-rules normal-rules)))
     42  (test "normal->starred->normal" expected-output
     43        (pre-post-order input
     44                        (starred->normal-transformation-rules
     45                         (normal->starred-transformation-rules normal-rules)))))
     46
     47(test-group "shortcuts"
     48  (test "url with link text"
     49        '(a (@ (href "foo")) "bar")
     50        (pre-post-order* '(url "foo" "bar") shortcut-rules*))
     51  (test "url without link text"
     52        '(a (@ (href "foo")) "foo")
     53        (pre-post-order* '(url "foo") shortcut-rules*))
     54  (test "pic without title"
     55        '(img (@ (src "foo") (alt "bar") (title "bar")))
     56        (pre-post-order* '(pic "foo" "bar") shortcut-rules*))
     57  (test "pic with title"
     58        '(img (@ (src "foo") (alt "bar") (title "qux")))
     59        (pre-post-order* '(pic "foo" "bar" "qux") shortcut-rules*))
     60  (test "movie"
     61        '(object (@ (type "video/quicktime"))
     62                 (param (@ (name "src") (value "video-source")))
     63                 (param (@ (name "controller") (value "true")))
     64                 "foo"
     65                 (a (@ (href "video-source")) "my video"))
     66        (pre-post-order* '(movie "video-source" "my video" "foo")
     67                         shortcut-rules*)))
    4668
    4769(test-end "sxml-fu")
Note: See TracChangeset for help on using the changeset viewer.