;;; SXML serializer into XML and HTML.
;;;
;;; Partial conformance with
;;; [1] XSLT 2.0 and XQuery 1.0 Serialization
;;; W3C Candidate Recommendation 3 November 2005
;;; http://www.w3.org/TR/2005/CR-xslt-xquery-serialization-20051103/
;;;
;;; This file is mechanically translated for Gauche from Dmitry
;;; Lizorkin's serializer.scm from the sxml-tools project.
;;;
;;; Prefix for global identifiers in this module is `srl:'
;;; short for "serialization"
;;;
;;;   This software is in Public Domain.
;;;   IT IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND.

(define-module sxml.serializer
  (use srfi-1)
  (export srl:sxml->string srl:display-sxml srl:parameterizable
          srl:sxml->xml srl:sxml->xml-noindent srl:sxml->html
          srl:sxml->html-noindent ))

(select-module sxml.serializer)

;;; Generated from "serializer.scm"
(define (srl:map-append func lst) (if (null? lst) lst (append (func (car lst)) (srl:map-append func (cdr lst)))))
(define (srl:apply-string-append str-lst) (apply string-append str-lst))
(define (srl:assoc-cdr-string= item alist) (cond ((null? alist) #f) ((string=? (cdar alist) item) (car alist)) (else (srl:assoc-cdr-string= item (cdr alist)))))
(define (srl:member-ci str lst) (cond ((null? lst) #f) ((string-ci=? str (car lst)) lst) (else (srl:member-ci str (cdr lst)))))
(define (srl:mem-pred pred? lst) (cond ((null? lst) #f) ((pred? (car lst)) lst) (else (srl:mem-pred pred? (cdr lst)))))
(cond-expand ((or scheme48 scsh) (define srl:char-nl (ascii->char 10))) (else (define srl:char-nl (integer->char 10))))
(define srl:newline (string srl:char-nl))
(define (srl:select-kids test-pred?) (lambda (node) (cond ((null? node) node) ((not (pair? node)) '()) ((symbol? (car node)) (filter test-pred? (cdr node))) (else (srl:map-append (srl:select-kids test-pred?) node)))))
(define (srl:separate-list pred? lst) (let loop ((lst lst) (satisfy '()) (rest '())) (cond ((null? lst) (values (reverse satisfy) (reverse rest))) ((pred? (car lst)) (loop (cdr lst) (cons (car lst) satisfy) rest)) (else (loop (cdr lst) satisfy (cons (car lst) rest))))))
(define (srl:clean-fragments fragments) (reverse (let loop ((fragments fragments) (result '())) (cond ((null? fragments) result) ((null? (car fragments)) (loop (cdr fragments) result)) ((pair? (car fragments)) (loop (cdr fragments) (loop (car fragments) result))) (else (loop (cdr fragments) (cons (car fragments) result)))))))
(define (srl:display-fragments-2nesting fragments-level2 port) (for-each (lambda (level1) (if (pair? level1) (for-each (lambda (x) (display x port)) level1) (display level1 port))) fragments-level2))
(define (srl:split-name name) (let* ((name-str (symbol->string name)) (lng (string-length name-str))) (let iter ((i (- lng 1))) (cond ((< i 0) (cons #f name-str)) ((char=? (string-ref name-str i) #\:) (cons (substring name-str 0 i) (substring name-str (+ i 1) lng))) (else (iter (- i 1)))))))
(define (srl:atomic->string obj) (cond ((or (pair? obj) (string? obj)) obj) ((number? obj) (number->string obj)) ((boolean? obj) (if obj "true" "false")) (else obj)))
(define (srl:empty-elem? elem) (or (null? (cdr elem)) (and (null? (cddr elem)) (pair? (cadr elem)) (eq? (caadr elem) '|@|)) (and (not (null? (cddr elem))) (null? (cdddr elem)) (pair? (caddr elem)) (eq? (caaddr elem) '|@@|))))
(define srl:conventional-ns-prefixes '((dc . "http://purl.org/dc/elements/1.1/") (fo . "http://www.w3.org/1999/XSL/Format") (rdf . "http://www.w3.org/1999/02/22-rdf-syntax-ns#") (rng . "http://relaxng.org/ns/structure/1.0") (xlink . "http://www.w3.org/1999/xlink") (xqx . "http://www.w3.org/2005/XQueryX") (xsd . "http://www.w3.org/2001/XMLSchema") (xsi . "http://www.w3.org/2001/XMLSchema-instance") (xsl . "http://www.w3.org/1999/XSL/Transform")))
(define (srl:namespace-assoc-for-elem elem) ((srl:select-kids (lambda (node) (pair? node))) ((srl:select-kids (lambda (node) (and (pair? node) (eq? (car node) '*NAMESPACES*)))) (append ((srl:select-kids (lambda (node) (and (pair? node) (eq? (car node) '|@|)))) ((srl:select-kids (lambda (node) (and (pair? node) (eq? (car node) '|@|)))) elem)) ((srl:select-kids (lambda (node) (and (pair? node) (eq? (car node) '|@@|)))) elem)))))
(define (srl:ns-assoc-for-top doc) ((srl:select-kids (lambda (node) (pair? node))) ((srl:select-kids (lambda (node) (and (pair? node) (eq? (car node) '*NAMESPACES*)))) ((srl:select-kids (lambda (node) (and (pair? node) (eq? (car node) '|@|)))) doc))))
(define (srl:extract-original-prefix-binding namespace-assoc-lst) (map (lambda (triple) (cons (caddr triple) (cadr triple))) (filter (lambda (memb) (= (length memb) 3)) namespace-assoc-lst)))
(define (srl:update-space-specifier elem space-preserve?) (let ((xml-space-val ((srl:select-kids string?) ((srl:select-kids (lambda (node) (and (pair? node) (eq? (car node) 'xml:space)))) ((srl:select-kids (lambda (node) (and (pair? node) (eq? (car node) '|@|)))) elem))))) (cond ((null? xml-space-val) space-preserve?) ((string=? (car xml-space-val) "preserve") #t) ((string=? (car xml-space-val) "default") #f) (else space-preserve?))))
(define (srl:normalize-sequence node-or-sequence) (letrec ((normaliz-step-1 (lambda (node-or-seq) (cond ((null? node-or-seq) '("")) ((or (not (pair? node-or-seq)) (symbol? (car node-or-seq))) (list node-or-seq)) (else node-or-seq)))) (normaliz-step-2 (lambda (seq) (map (lambda (item) (srl:atomic->string item)) seq))) (normaliz-step-3 (lambda (seq) (let loop ((src (reverse seq)) (res '())) (cond ((null? src) res) ((string? (car src)) (let adjacent ((src (cdr src)) (adj-strs (list (car src)))) (cond ((null? src) (cons (srl:apply-string-append adj-strs) res)) ((string? (car src)) (adjacent (cdr src) (cons (car src) (cons " " adj-strs)))) (else (loop (cdr src) (cons (car src) (cons (srl:apply-string-append adj-strs) res))))))) (else (loop (cdr src) (cons (car src) res))))))) (normaliz-step-5 (lambda (seq) (cond ((null? seq) seq) ((and (pair? (car seq)) (eq? (caar seq) '*TOP*)) (append (cdar seq) (normaliz-step-5 (cdr seq)))) (else (cons (car seq) (normaliz-step-5 (cdr seq))))))) (normaliz-step-6 (lambda (seq) (let loop ((src (reverse seq)) (res '())) (cond ((null? src) res) ((string? (car src)) (if (string=? (car src) "") (loop (cdr src) res) (let adjacent ((src (cdr src)) (adj-strs (list (car src)))) (cond ((null? src) (cons (srl:apply-string-append adj-strs) res)) ((string? (car src)) (adjacent (cdr src) (cons (car src) adj-strs))) (else (loop (cdr src) (cons (car src) (cons (srl:apply-string-append adj-strs) res)))))))) (else (loop (cdr src) (cons (car src) res))))))) (normaliz-step-7 (lambda (seq) (call-with-values (lambda () (srl:separate-list (lambda (item) (and (pair? item) (or (eq? (car item) '|@@|) (eq? (car item) '|@|)))) seq)) (lambda (aux-lists body) (if (null? aux-lists) `(*TOP* ,@body) `(*TOP* (|@| ,@(srl:map-append cdr aux-lists)) ,@body))))))) (normaliz-step-7 (normaliz-step-6 (normaliz-step-5 (normaliz-step-3 (normaliz-step-2 (normaliz-step-1 node-or-sequence))))))))
(define (srl:xml-char-escaped ch) (let ((code (char->integer ch))) (if (or (= code 9) (= code 10) (= code 13) (and (>= code 32) (<= code 55295)) (and (>= code 57344) (<= code 65533)) (>= code 65536)) #f (string-append "&#" (number->string code) ";"))))
(define (srl:string->cdata-section str) (let ((flush-buffer (lambda (buffer res) (if (null? buffer) res (cons (string-append "<![CDATA[" (list->string (reverse buffer)) "]]>") res))))) (let loop ((src (string->list str)) (buffer '()) (res '(""))) (cond ((null? src) (srl:apply-string-append (reverse (flush-buffer buffer res)))) ((srl:xml-char-escaped (car src)) => (lambda (charref) (loop (cdr src) '() (cons charref (flush-buffer buffer res))))) ((and (char=? (car src) #\]) (not (null? buffer)) (char=? (car buffer) #\])) (loop (cdr src) '() (cons (string (car buffer) (car src)) (flush-buffer (cdr buffer) res)))) (else (loop (cdr src) (cons (car src) buffer) res))))))
(define srl:escape-alist-char-data '((#\& . "&amp;") (#\< . "&lt;") (#\> . "&gt;")))
(define srl:escape-alist-att-value (append `((#\' . "&apos;") (#\" . "&quot;") (,srl:char-nl . "&#10;")) srl:escape-alist-char-data))
(define srl:escape-alist-html-att '((#\& . "&amp;") (#\> . "&gt;") (#\' . "&apos;") (#\" . "&quot;")))
(define (srl:string->escaped str escape-alist html-method?) (let loop ((src (string->list str)) (adj-chars '()) (res '())) (cond ((null? src) (srl:apply-string-append (reverse (cons (list->string (reverse adj-chars)) res)))) ((assv (car src) escape-alist) => (lambda (pair) (if (and (char=? (car src) #\&) html-method? (not (null? (cdr src))) (char=? (cadr src) #\{)) (loop (cdr src) (cons (car src) adj-chars) res) (loop (cdr src) '() (cons (cdr pair) (cons (list->string (reverse adj-chars)) res)))))) ((srl:xml-char-escaped (car src)) => (lambda (esc) (loop (cdr src) '() (cons esc (cons (list->string (reverse adj-chars)) res))))) (else (loop (cdr src) (cons (car src) adj-chars) res)))))
(define (srl:string->char-data str) (srl:string->escaped str srl:escape-alist-char-data #f))
(define (srl:string->att-value str) (srl:string->escaped str srl:escape-alist-att-value #f))
(define (srl:string->html-att str) (srl:string->escaped str srl:escape-alist-html-att #t))
(define (srl:shtml-entity->char-data entity) (if (= (length entity) 2) (let ((val (cadr entity))) (cond ((symbol? val) (string-append "&" (symbol->string val) ";")) ((string? val) (string-append "&" val ";")) ((and (number? val) (integer? val) (> val 0)) (string-append "&#" (number->string val) ";")) (else ""))) ""))
(define (srl:qname->string prefix-string local-part) (if prefix-string (string-append prefix-string ":" local-part) local-part))
(define (srl:attribute->str-lst prefix-string local-part att-value method) (let ((attval (srl:atomic->string att-value))) (cond (prefix-string (list " " prefix-string ":" local-part "=\"" ((if (eq? method 'html) srl:string->html-att srl:string->att-value) attval) "\"")) ((eq? method 'html) (list " " local-part "=\"" (srl:string->html-att attval) "\"")) (else (list " " local-part "=\"" (srl:string->att-value attval) "\"")))))
(define (srl:namespace-decl->str-lst prefix-string namespace-uri) (list " xmlns:" prefix-string "=\"" (srl:string->att-value namespace-uri) "\""))
(define (srl:comment->str-lst comment-node) (let ((proper-string-in-comment? (lambda (str) (let ((lng (string-length str))) (or (zero? lng) (and (not (char=? (string-ref str 0) #\-)) (let iter ((i 1) (prev-hyphen? #f)) (cond ((>= i lng) (not prev-hyphen?)) ((char=? (string-ref str i) #\-) (if prev-hyphen? #f (iter (+ i 1) #t))) (else (iter (+ i 1) #f)))))))))) (if (and (= (length comment-node) 2) (string? (cadr comment-node)) (proper-string-in-comment? (cadr comment-node))) (list "<!--" (cadr comment-node) "-->") (list "<!--" "-->"))))
(define (srl:processing-instruction->str-lst pi-node method) (let ((string-not-contain-charlist? (lambda (str char-lst) (let ((lng (string-length str))) (or (zero? lng) (let iter ((i 0) (pattern char-lst)) (cond ((>= i lng) #t) ((char=? (string-ref str i) (car pattern)) (if (null? (cdr pattern)) #f (iter (+ i 1) (cdr pattern)))) (else (iter (+ i 1) char-lst))))))))) (if (or (null? (cdr pi-node)) (not (symbol? (cadr pi-node)))) '() (let ((content (filter string? (cddr pi-node)))) (cond ((null? content) (list "<?" (symbol->string (cadr pi-node)) (if (eq? method 'html) ">" "?>"))) ((and (null? (cdr content)) (string-not-contain-charlist? (car content) (if (eq? method 'html) '(#\>) '(#\? #\>)))) (list "<?" (symbol->string (cadr pi-node)) " " (car content) (if (eq? method 'html) ">" "?>"))) (else '()))))))
(define (srl:name->qname-components name ns-prefix-assig namespace-assoc declared-ns-prefixes) (let ((use-ns-id-or-generate-prefix (lambda (ns-id) (if (and ns-id (not (assq (string->symbol ns-id) ns-prefix-assig)) (not (assoc ns-id declared-ns-prefixes))) ns-id (let loop ((i 1)) (let ((candidate (string-append "prfx" (number->string i)))) (if (or (assoc candidate declared-ns-prefixes) (assq (string->symbol candidate) ns-prefix-assig)) (loop (+ i 1)) candidate)))))) (n-parts (srl:split-name name))) (cond ((not (car n-parts)) (values #f #f (cdr n-parts) #f)) ((string-ci=? (car n-parts) "xml") (values (car n-parts) "http://www.w3.org/XML/1998/namespace" (cdr n-parts) #f)) (else (call-with-values (lambda () (cond ((assq (string->symbol (car n-parts)) namespace-assoc) => (lambda (lst) (values (cadr lst) (car n-parts)))) (else (values (car n-parts) #f)))) (lambda (namespace-uri ns-id) (cond ((srl:assoc-cdr-string= namespace-uri declared-ns-prefixes) => (lambda (pair) (values (car pair) namespace-uri (cdr n-parts) #f))) (else (values (cond ((srl:assoc-cdr-string= namespace-uri ns-prefix-assig) => (lambda (pair) (let ((candidate (symbol->string (car pair)))) (if (assoc candidate declared-ns-prefixes) (use-ns-id-or-generate-prefix ns-id) candidate)))) (else (use-ns-id-or-generate-prefix ns-id))) namespace-uri (cdr n-parts) #t)))))))))
(define srl:void-elements '("area" "base" "basefont" "br" "col" "embed" "frame" "hr" "img" "input" "isindex" "keygen" "link" "meta" "param" "source" "track" "wbr"))
(define (srl:construct-start-end-tags elem method ns-prefix-assig namespace-assoc declared-ns-prefixes) (let ((ns-assoc-here (srl:namespace-assoc-for-elem elem)) (empty? (srl:empty-elem? elem))) (let ((ns-prefix-assig (append (srl:extract-original-prefix-binding ns-assoc-here) ns-prefix-assig)) (namespace-assoc (append ns-assoc-here namespace-assoc))) (call-with-values (lambda () (srl:name->qname-components (car elem) ns-prefix-assig namespace-assoc declared-ns-prefixes)) (lambda (elem-prefix elem-uri elem-local elem-decl-required?) (let loop ((attrs (reverse ((srl:select-kids (lambda (node) (and (pair? node) (not (eq? (car node) '|@|))))) ((srl:select-kids (lambda (node) (and (pair? node) (eq? (car node) '|@|)))) elem)))) (start-tag (if (eq? method 'xml) (if empty? '("/>") '(">")) (if (or (not empty?) (and (not elem-prefix) (srl:member-ci elem-local srl:void-elements))) '(">") (list "></" (srl:qname->string elem-prefix elem-local) ">")))) (ns-prefix-assig ns-prefix-assig) (namespace-assoc namespace-assoc) (declared-ns-prefixes (if elem-decl-required? (cons (cons elem-prefix elem-uri) declared-ns-prefixes) declared-ns-prefixes))) (if (null? attrs) (let ((elem-name (srl:qname->string elem-prefix elem-local))) (values (cons "<" (cons elem-name (if elem-decl-required? (cons (srl:namespace-decl->str-lst elem-prefix elem-uri) start-tag) start-tag))) (if empty? #f (list "</" elem-name ">")) ns-prefix-assig namespace-assoc declared-ns-prefixes)) (call-with-values (lambda () (srl:name->qname-components (caar attrs) ns-prefix-assig namespace-assoc declared-ns-prefixes)) (lambda (attr-prefix attr-uri attr-local attr-decl-required?) (let ((start-tag (cons (srl:attribute->str-lst attr-prefix attr-local (if (null? (cdar attrs)) attr-local (cadar attrs)) method) start-tag))) (loop (cdr attrs) (if attr-decl-required? (cons (srl:namespace-decl->str-lst attr-prefix attr-uri) start-tag) start-tag) ns-prefix-assig namespace-assoc (if attr-decl-required? (cons (cons attr-prefix attr-uri) declared-ns-prefixes) declared-ns-prefixes))))))))))))
(define (srl:node->nested-str-lst-recursive node method ns-prefix-assig namespace-assoc declared-ns-prefixes indentation space-preserve? cdata-section-elements text-node-handler) (if (not (pair? node)) (text-node-handler (srl:atomic->string node)) (case (car node) ((*COMMENT*) (srl:comment->str-lst node)) ((*PI*) (srl:processing-instruction->str-lst node method)) ((&) (srl:shtml-entity->char-data node)) ((*DECL*) '()) (else (call-with-values (lambda () (srl:construct-start-end-tags node method ns-prefix-assig namespace-assoc declared-ns-prefixes)) (lambda (start-tag end-tag ns-prefix-assig namespace-assoc declared-ns-prefixes) (if (not end-tag) start-tag (let ((space-preserve? (srl:update-space-specifier node space-preserve?)) (text-node-handler (cond ((memq (car node) cdata-section-elements) srl:string->cdata-section) ((and (eq? method 'html) (srl:member-ci (symbol->string (car node)) '("script" "style"))) (lambda (str) str)) (else srl:string->char-data))) (content ((srl:select-kids (lambda (node) (not (and (pair? node) (memq (car node) '(|@| |@@| *ENTITY*)))))) node))) (call-with-values (lambda () (cond ((or (not indentation) (and (eq? method 'html) (srl:member-ci (symbol->string (car node)) '("pre" "script" "style" "textarea")))) (values #f #f)) ((or space-preserve? (srl:mem-pred (lambda (node) (not (pair? node))) content)) (values #f indentation)) (else (values (cons srl:newline indentation) (cons (car indentation) indentation))))) (lambda (indent-here indent4recursive) (if indent-here (append start-tag (map (lambda (kid) (list indent-here (srl:node->nested-str-lst-recursive kid method ns-prefix-assig namespace-assoc declared-ns-prefixes indent4recursive space-preserve? cdata-section-elements text-node-handler))) content) (cons srl:newline (cons (cdr indentation) end-tag))) (append start-tag (map (lambda (kid) (srl:node->nested-str-lst-recursive kid method ns-prefix-assig namespace-assoc declared-ns-prefixes indent4recursive space-preserve? cdata-section-elements text-node-handler)) content) end-tag))))))))))))
(define (srl:display-node-out-recursive node port method ns-prefix-assig namespace-assoc declared-ns-prefixes indentation space-preserve? cdata-section-elements text-node-handler) (if (not (pair? node)) (display (text-node-handler (srl:atomic->string node)) port) (case (car node) ((*COMMENT*) (for-each (lambda (x) (display x port)) (srl:comment->str-lst node))) ((*PI*) (for-each (lambda (x) (display x port)) (srl:processing-instruction->str-lst node method))) ((&) (display (srl:shtml-entity->char-data node) port)) ((*DECL*) #f) (else (call-with-values (lambda () (srl:construct-start-end-tags node method ns-prefix-assig namespace-assoc declared-ns-prefixes)) (lambda (start-tag end-tag ns-prefix-assig namespace-assoc declared-ns-prefixes) (begin (srl:display-fragments-2nesting start-tag port) (if end-tag (let ((space-preserve? (srl:update-space-specifier node space-preserve?)) (text-node-handler (cond ((memq (car node) cdata-section-elements) srl:string->cdata-section) ((and (eq? method 'html) (srl:member-ci (symbol->string (car node)) '("script" "style"))) (lambda (str) str)) (else srl:string->char-data))) (content ((srl:select-kids (lambda (node) (not (and (pair? node) (memq (car node) '(|@| |@@| *ENTITY*)))))) node))) (call-with-values (lambda () (cond ((or (not indentation) (and (eq? method 'html) (srl:member-ci (symbol->string (car node)) '("pre" "script" "style" "textarea")))) (values #f #f)) ((or space-preserve? (srl:mem-pred (lambda (node) (not (pair? node))) content)) (values #f indentation)) (else (values (cons srl:newline indentation) (cons (car indentation) indentation))))) (lambda (indent-here indent4recursive) (begin (for-each (if indent-here (lambda (kid) (begin (for-each (lambda (x) (display x port)) indent-here) (srl:display-node-out-recursive kid port method ns-prefix-assig namespace-assoc declared-ns-prefixes indent4recursive space-preserve? cdata-section-elements text-node-handler))) (lambda (kid) (srl:display-node-out-recursive kid port method ns-prefix-assig namespace-assoc declared-ns-prefixes indent4recursive space-preserve? cdata-section-elements text-node-handler))) content) (if indent-here (begin (display srl:newline port) (for-each (lambda (x) (display x port)) (cdr indentation)))) (for-each (lambda (x) (display x port)) end-tag)))))))))))))
(define (srl:make-xml-decl version standalone) (let ((version (if (number? version) (number->string version) version))) (if (eq? standalone 'omit) (list "<?xml version='" version "'?>") (list "<?xml version='" version "' standalone='" (symbol->string standalone) "'?>"))))
(define (srl:top->nested-str-lst doc cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone version) (let* ((namespace-assoc (srl:ns-assoc-for-top doc)) (ns-prefix-assig (append (srl:extract-original-prefix-binding namespace-assoc) ns-prefix-assig)) (serialized-content (map (if indent (let ((indentation (list indent))) (lambda (kid) (list srl:newline (srl:node->nested-str-lst-recursive kid method ns-prefix-assig namespace-assoc '() indentation #f cdata-section-elements srl:string->char-data)))) (lambda (kid) (srl:node->nested-str-lst-recursive kid method ns-prefix-assig namespace-assoc '() indent #f cdata-section-elements srl:string->char-data))) ((srl:select-kids (lambda (node) (not (and (pair? node) (memq (car node) '(|@| |@@| *ENTITY*)))))) doc)))) (if (or (eq? method 'html) omit-xml-declaration?) (if (and indent (not (null? serialized-content))) (cons (cadar serialized-content) (cdr serialized-content)) serialized-content) (list (srl:make-xml-decl version standalone) serialized-content))))
(define (srl:display-top-out doc port cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone version) (let ((no-xml-decl? (if (not (or (eq? method 'html) omit-xml-declaration?)) (begin (for-each (lambda (x) (display x port)) (srl:make-xml-decl version standalone)) #f) #t)) (content ((srl:select-kids (lambda (node) (not (and (pair? node) (memq (car node) '(|@| |@@| *ENTITY*)))))) doc)) (namespace-assoc (srl:ns-assoc-for-top doc))) (let ((ns-prefix-assig (append (srl:extract-original-prefix-binding namespace-assoc) ns-prefix-assig))) (cond ((null? content) #t) ((and indent no-xml-decl?) (let ((indentation (list indent))) (for-each (lambda (kid put-newline?) (begin (if put-newline? (display srl:newline port)) (srl:display-node-out-recursive kid port method ns-prefix-assig namespace-assoc '() indentation #f cdata-section-elements srl:string->char-data))) content (cons #f (cdr content))))) (else (for-each (if indent (let ((indentation (list indent))) (lambda (kid) (begin (display srl:newline port) (srl:display-node-out-recursive kid port method ns-prefix-assig namespace-assoc '() indentation #f cdata-section-elements srl:string->char-data)))) (lambda (kid) (srl:display-node-out-recursive kid port method ns-prefix-assig namespace-assoc '() indent #f cdata-section-elements srl:string->char-data))) content))))))
(define (srl:sxml->string sxml-obj cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone version) (srl:apply-string-append (srl:clean-fragments (srl:top->nested-str-lst (srl:normalize-sequence sxml-obj) cdata-section-elements (if (and indent (not (string? indent))) "  " indent) method ns-prefix-assig omit-xml-declaration? standalone version))))
(define (srl:display-sxml sxml-obj port-or-filename cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone version) (if (string? port-or-filename) (let ((out (open-output-file port-or-filename))) (begin (srl:display-top-out (srl:normalize-sequence sxml-obj) out cdata-section-elements (if (and indent (not (string? indent))) "  " indent) method ns-prefix-assig omit-xml-declaration? standalone version) (display srl:newline out) (close-output-port out))) (srl:display-top-out (srl:normalize-sequence sxml-obj) port-or-filename cdata-section-elements (if (and indent (not (string? indent))) "  " indent) method ns-prefix-assig omit-xml-declaration? standalone version)))
(define (srl:parameterizable sxml-obj . port-or-filename+params) (call-with-values (lambda () (if (and (not (null? port-or-filename+params)) (or (output-port? (car port-or-filename+params)) (string? (car port-or-filename+params)))) (values (car port-or-filename+params) (cdr port-or-filename+params)) (values #f port-or-filename+params))) (lambda (port-or-filename params) (let loop ((params params) (cdata-section-elements '()) (indent "  ") (method 'xml) (ns-prefix-assig srl:conventional-ns-prefixes) (omit-xml-declaration? #t) (standalone 'omit) (version "1.0")) (cond ((null? params) (if port-or-filename (srl:display-sxml sxml-obj port-or-filename cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone version) (srl:sxml->string sxml-obj cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone version))) ((or (not (pair? (car params))) (null? (cdar params))) (loop (cdr params) cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone version)) (else (let ((prm-value (cdar params))) (case (caar params) ((cdata-section-elements) (loop (cdr params) (if (list? prm-value) prm-value cdata-section-elements) indent method ns-prefix-assig omit-xml-declaration? standalone version)) ((indent) (loop (cdr params) cdata-section-elements (cond ((boolean? prm-value) (if prm-value "  " prm-value)) ((string? prm-value) prm-value) ((eq? prm-value 'yes) "  ") ((eq? prm-value 'no) #f) (else indent)) method ns-prefix-assig omit-xml-declaration? standalone version)) ((method) (loop (cdr params) cdata-section-elements indent (if (or (eq? prm-value 'xml) (eq? prm-value 'html)) prm-value method) ns-prefix-assig omit-xml-declaration? standalone version)) ((ns-prefix-assig) (loop (cdr params) cdata-section-elements indent method (if (and (list? prm-value) (not (srl:mem-pred (lambda (x) (not (pair? x))) prm-value))) (append prm-value ns-prefix-assig) ns-prefix-assig) omit-xml-declaration? standalone version)) ((omit-xml-declaration) (loop (cdr params) cdata-section-elements indent method ns-prefix-assig (cond ((boolean? prm-value) prm-value) ((eq? prm-value 'yes) #t) ((eq? prm-value 'no) #f) (else indent)) standalone version)) ((standalone) (loop (cdr params) cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? (cond ((memv prm-value '(yes no omit)) prm-value) ((boolean? prm-value) (if prm-value 'yes 'no)) (else standalone)) version)) ((version) (loop (cdr params) cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone (if (or (string? prm-value) (number? prm-value)) prm-value version))) (else (loop (cdr params) cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone version))))))))))
(define (srl:sxml->xml sxml-obj . port-or-filename) (if (null? port-or-filename) (srl:sxml->string sxml-obj '() #t 'xml srl:conventional-ns-prefixes #t 'omit "1.0") (srl:display-sxml sxml-obj (car port-or-filename) '() #t 'xml srl:conventional-ns-prefixes #t 'omit "1.0")))
(define (srl:sxml->xml-noindent sxml-obj . port-or-filename) (if (null? port-or-filename) (srl:sxml->string sxml-obj '() #f 'xml srl:conventional-ns-prefixes #t 'omit "1.0") (srl:display-sxml sxml-obj (car port-or-filename) '() #f 'xml srl:conventional-ns-prefixes #t 'omit "1.0")))
(define (srl:sxml->html sxml-obj . port-or-filename) (if (null? port-or-filename) (srl:sxml->string sxml-obj '() #t 'html '() #t 'omit "4.0") (srl:display-sxml sxml-obj (car port-or-filename) '() #t 'html '() #t 'omit "4.0")))
(define (srl:sxml->html-noindent sxml-obj . port-or-filename) (if (null? port-or-filename) (srl:sxml->string sxml-obj '() #f 'html '() #t 'omit "4.0") (srl:display-sxml sxml-obj (car port-or-filename) '() #f 'html '() #t 'omit "4.0")))

;; Local variables:
;; mode: scheme
;; end:
