70 lines
2.2 KiB
Scheme
70 lines
2.2 KiB
Scheme
;;; Copyright 2002, 2003 Andreas Bernauer
|
|
|
|
;;; adapted from Oleg's SXML-tree-trans.scm SRV:send-reply
|
|
;;; extended by port argument
|
|
;;; #t: current-output-port
|
|
;;; #f: string
|
|
;;; port: port
|
|
;;; else: error
|
|
;; Displays low-level-sxml on the port. Low-level-sxml contains only
|
|
;; strings, characters and thunks. '() and #f are ignored.
|
|
(define (display-low-level-sxml fragments port)
|
|
(let loop ((fragments fragments) (result #f))
|
|
(cond
|
|
((null? fragments) result)
|
|
((not (car fragments)) (loop (cdr fragments) result))
|
|
((null? (car fragments)) (loop (cdr fragments) result))
|
|
((pair? (car fragments))
|
|
(loop (cdr fragments) (loop (car fragments) result)))
|
|
((procedure? (car fragments))
|
|
((car fragments))
|
|
(loop (cdr fragments) #t))
|
|
(else
|
|
(display (car fragments) port)
|
|
(loop (cdr fragments) #t)))))
|
|
|
|
;; Gives you a string representing the HTML of the already reformatted
|
|
;; SXML-TREE.
|
|
(define (sxml->string sxml-tree rules)
|
|
(call-with-string-output-port
|
|
(lambda (port)
|
|
(display-low-level-sxml
|
|
(pre-post-order sxml-tree rules)
|
|
port))))
|
|
|
|
(define (sxml->string/internal sxml-tree rules)
|
|
(list (sxml->string sxml-tree rules)))
|
|
|
|
;; Predicate for attributes in sxml.
|
|
(define (sxml-attribute? thing)
|
|
(and (pair? thing)
|
|
(eq? '@ (car thing))))
|
|
|
|
|
|
;; Default rule: Creates leading and trailing tag and encloses the
|
|
;; attributes.
|
|
(define default-rule
|
|
`(*default*
|
|
. ,(lambda (tag . elems) (apply (entag tag) elems))))
|
|
|
|
;; Just displays the string, except that some characters are escaped.
|
|
(define text-rule
|
|
`(*text*
|
|
. ,(lambda (trigger str)
|
|
(if (string? str) (string->goodHTML str) str))))
|
|
|
|
;; Rule for attribution: creates an attribute like "selected" or
|
|
;; "color="red""
|
|
(define attribute-rule
|
|
`(@ ; local override for attributes
|
|
((*default*
|
|
. ,(lambda (attr-key . value) (enattr attr-key value))))
|
|
. ,(lambda (trigger . value) (list '@ value))))
|
|
|
|
;; Create attribution-value pair for inside of tags
|
|
;; If the attribute has no value, value must be '()
|
|
(define (enattr attr-key attr-value)
|
|
(if (null? attr-value)
|
|
(list #\space attr-key)
|
|
(list #\space attr-key "=\"" attr-value #\")))
|