source: project/release/4/sxml-fu/sxml-shortcuts.scm @ 15354

Last change on this file since 15354 was 15354, checked in by sjamaan, 11 years ago

Add convenience procedures for folding many rules into an XML output

File size: 3.3 KB
Line 
1;;; sxml-shortcuts.scm
2;
3; Copyright (c) 2004-2008 Peter Bex (Peter.Bex@xs4all.nl)
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without
7; modification, are permitted provided that the following conditions
8; are met:
9; 1. Redistributions of source code must retain the above copyright
10;    notice, this list of conditions and the following disclaimer.
11; 2. Redistributions in binary form must reproduce the above copyright
12;    notice, this list of conditions and the following disclaimer in the
13;    documentation and/or other materials provided with the distribution.
14; 3. Neither the name of Peter Bex nor the names of any contributors may
15;    be used to endorse or promote products derived from this software
16;    without specific prior written permission.
17;
18; THIS SOFTWARE IS PROVIDED BY PETER BEX AND CONTRIBUTORS ``AS IS'' AND ANY
19; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
21; DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS BE LIABLE
22; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
24; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
25; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
26; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
27; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
28; SUCH DAMAGE.
29
30(module sxml-shortcuts
31  (shortcut-rules)
32
33(import chicken scheme)
34
35(require-extension srfi-1 uri-common)
36
37(define shortcut-rules
38  `((url *macro* . ,(lambda (tag href . contents)
39                      (let ((href (if (uri-reference? href)
40                                      (uri->string href)
41                                      href)))
42                       `(a (@ (href ,href))
43                           ,@(if (not (null? contents))
44                                 contents
45                                 (list href))))))
46    (pic *macro* . ,(lambda (tag src alt . rest)
47                      (let ((src (if (uri-reference? src)
48                                     (uri->string src)
49                                     src)))
50                        (let-optionals* rest ((title alt) more)
51                                        `(img (@ ,@(append `((src ,src)
52                                                             (alt ,alt)
53                                                             (title ,title)
54                                                             ,@more))))))))
55    (movie *macro* . ,(lambda (tag src title . rest)
56                        (let ((src (if (uri-reference? src)
57                                      (uri->string src)
58                                      src)))
59                         `(object (@ (type "video/quicktime"))
60                                  (param (@ (name "src") (value ,src)))
61                                  (param (@ (name "controller") (value "true")))
62                                  ,@rest
63                                  ;; Fallback if no viewer
64                                  (url ,src ,title)))))
65    (*text* . ,(lambda (tag str) str))
66    (*default* . ,(lambda x x)))))
67
Note: See TracBrowser for help on using the repository browser.