blob: 0990d2487539f23f41dc322af863fd11ab0693e1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
;;; xml.scm -- Generic XML engine.
;;;
;;; Copyright 2003, 2004 Manuel Serrano
;;; Copyright 2007 Ludovic Court�s <ludo@chbouib.org>
;;;
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo engine xml)
:use-module (skribilo ast)
:use-module (skribilo engine)
:use-module (skribilo writer)
:use-module (skribilo utils strings)
:use-module (skribilo utils syntax)
:autoload (skribilo output) (output)
:use-module (srfi srfi-1)
:export (xml-engine))
(skribilo-module-syntax)
;*---------------------------------------------------------------------*/
;* xml-engine ... */
;*---------------------------------------------------------------------*/
(define xml-engine
;; setup the xml engine
(make-engine 'xml
:version 1.0
:format "html"
:delegate (find-engine 'base)
:filter (make-string-replace '((#\< "<")
(#\> ">")
(#\& "&")
(#\" """)
(#\@ "@")))))
;*---------------------------------------------------------------------*/
;* markup ... */
;*---------------------------------------------------------------------*/
(let ((xml-margin 0))
(define (keyword->string kw)
(symbol->string (keyword->symbol kw)))
(define (make-margin)
(make-string xml-margin #\space))
(define (xml-attribute? val)
(cond
((or (string? val) (number? val) (boolean? val))
#t)
((list? val)
(every xml-attribute? val))
(else
#f)))
(define (xml-attribute att val)
(let ((s (keyword->string att)))
(format #t " ~a=\"" s)
(let loop ((val val))
(cond
((or (string? val) (number? val))
(display val))
((boolean? val)
(display (if val "true" "false")))
((pair? val)
(for-each loop val))
(else
#f)))
(display #\")))
(define (xml-option opt val e)
(let ((m (make-margin))
(s (keyword->string opt)))
(format #t "~a<~a>\n" m s)
(output val e)
(format #t "~a</~a>\n" m s)))
(define (xml-options n e)
;; display the true options
(let ((opts (filter (lambda (o)
(and (keyword? (car o))
(not (xml-attribute? (cadr o)))))
(markup-options n))))
(if (pair? opts)
(let ((m (make-margin)))
(display m)
(display "<options>\n")
(set! xml-margin (+ xml-margin 1))
(for-each (lambda (o)
(xml-option (car o) (cadr o) e))
opts)
(set! xml-margin (- xml-margin 1))
(display m)
(display "</options>\n")))))
(markup-writer #t xml-engine
:options 'all
:before (lambda (n e)
(format #t "~a<~a" (make-margin) (markup-markup n))
;; display the xml attributes
(for-each (lambda (o)
(if (and (keyword? (car o))
(xml-attribute? (cadr o)))
(xml-attribute (car o) (cadr o))))
(markup-options n))
(set! xml-margin (+ xml-margin 1))
(display ">\n"))
:action (lambda (n e)
;; options
(xml-options n e)
;; body
(output (markup-body n) e))
:after (lambda (n e)
(format #t "~a</~a>\n" (make-margin) (markup-markup n))
(set! xml-margin (- xml-margin 1)))))
|
