Module: serializer

 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 software is in Public Domain.
 IT IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND.

 Please send bug reports and comments to:
   lizorkin@ispras.ru    Dmitry Lizorkin


f: srl:newline
f: srl:map-append
f: srl:assoc-cdr-string=
f: srl:member-ci
f: srl:mem-pred
Borrowed from "sxpathlib.scm"
f: srl:nodeset?
f: srl:map-union
f: srl:select-kids
Borrowed from "modif.scm"
f: srl:separate-list
Borrowed from "fragments.scm"
f: srl:clean-fragments
f: srl:display-fragments-2nesting

Helper SXML utilities
f: srl:split-name
f: srl:atomic->string
f: srl:empty-elem?
Handling SXML namespaces
f: srl:conventional-ns-prefixes
f: srl:namespace-assoc-for-elem
f: srl:ns-assoc-for-top
f: srl:extract-original-prefix-binding
Handling xml:space attribute
f: srl:update-space-specifier

Sequence normalization
f: srl:normalize-sequence

Character escaping during string serialization
CDATA sections
f: srl:xml-char-escaped
f: srl:string->cdata-section
Character data and attribute values
f: srl:escape-alist-char-data
f: srl:escape-alist-att-value
f: srl:escape-alist-html-att
f: srl:string->escaped
f: srl:string->char-data
f: srl:string->att-value
f: srl:string->html-att
Serializing entities produced by HtmlPrag
f: srl:shtml-entity->char-data

Serialization for markup
f: srl:qname->string
Different types of nodes
f: srl:attribute->str-lst
f: srl:namespace-decl->str-lst
f: srl:comment->str-lst
f: srl:processing-instruction->str-lst
SXML element
f: srl:name->qname-components
f: srl:construct-start-end-tags

Recursively walking the tree of SXML elements
f: srl:node->nested-str-lst-recursive
f: srl:display-node-out-recursive
Serializing the document node - start of recursion
f: srl:make-xml-decl
f: srl:top->nested-str-lst
f: srl:display-top-out

Interface
Calling the serializer with all the serialization parameters supported
f: srl:sxml->string
f: srl:display-sxml
Generalized serialization procedure, parameterizable with all the
f: srl:parameterizable
High-level functions for popular serialization use-cases
f: srl:sxml->xml
f: srl:sxml->xml-noindent
f: srl:sxml->html
f: srl:sxml->html-noindent

srl:newline

(define srl:newline
... Full Code ... )


srl:map-append

(define (srl:map-append func lst)
... Full Code ... )
 `map' and `append' in a single pass:
 (srl:map-append func lst) = (apply append (map func lst))
 A simplified analogue of `map-union' from "sxpathlib.scm"


srl:assoc-cdr-string=

(define (srl:assoc-cdr-string= item alist)
... Full Code ... )
 Analogue of `assoc'
 However, search is performed by `cdr' of each alist member and `string=?' is
 used for comparison


srl:member-ci

(define (srl:member-ci str lst)
... Full Code ... )
 Analogue of `member' for strings that uses case insensitive comparison


srl:mem-pred

(define (srl:mem-pred pred? lst)
... Full Code ... )
 Analogue of `member'
 The end of the `lst' is returned, from the first member that satisfies
 the `pred?'



Borrowed from "sxpathlib.scm"


srl:nodeset?

(define (srl:nodeset? x)
... Full Code ... )
 Returns #t if given object is a nodelist


srl:map-union

(define (srl:map-union proc lst)
... Full Code ... )
 Apply proc to each element of lst and return the list of results.
 if proc returns a nodelist, splice it into the result


srl:select-kids

(define (srl:select-kids test-pred?)
... Full Code ... )
 A simplified implementation of `select-kids' is sufficienf for the serializer



Borrowed from "modif.scm"


srl:separate-list

(define (srl:separate-list pred? lst)
... Full Code ... )
  Separates the list into two lists with respect to the predicate
  Returns:  (values  res-lst1  res-lst2)
 res-lst1 - contains all members from the input lst that satisfy the pred?
 res-lst2 - contains the remaining members of the input lst



Borrowed from "fragments.scm"


srl:clean-fragments

(define (srl:clean-fragments fragments)
... Full Code ... )
 A simplified implementation of `sxml:clean-fragments'


srl:display-fragments-2nesting

(define (srl:display-fragments-2nesting fragments-level2 port)
... Full Code ... )
 A very much simplified analogue of `sxml:display-fragments' for fragments
 that have no more than two levels of nesting
 fragments-level2 ::= (listof fragments-level1)
 fragments-level1 ::= string | (listof string)



Helper SXML utilities


srl:split-name

(define (srl:split-name name)
... Full Code ... )
 Splits an SXML `name' into namespace id/uri and local part
 Returns: (cons  namespace-id  local-part)
 local-part - string
 namespace-id - string or #f if the `name' does not have a prefix


srl:atomic->string

(define (srl:atomic->string obj)
... Full Code ... )
 Converts SXML atomic object to a string. Keeps non-atomic object unchanged.
 A simplified analogue of applying the XPath `string(.)' function to atomic
 object.


srl:empty-elem?

(define (srl:empty-elem? elem)
... Full Code ... )
 Whether an SXML element is empty



Handling SXML namespaces

 <namespace-assoc> is defined in the SXML specification as
 <namespace-assoc> ::=  ( <namespace-id> "URI" original-prefix? ) 

srl:conventional-ns-prefixes

(define srl:conventional-ns-prefixes
... Full Code ... )
 Conventional namespace prefix referred to in XML-related specifications
 These prefixes are used for serializing the corresponding namespace URIs by
 default, unless a different prefix is supplied


srl:namespace-assoc-for-elem

(define (srl:namespace-assoc-for-elem elem)
... Full Code ... )
 Returns (listof <namespace-assoc>) for the given SXML element


srl:ns-assoc-for-top

(define (srl:ns-assoc-for-top doc)
... Full Code ... )
 Returns (listof <namespace-assoc>) for the SXML document node


srl:extract-original-prefix-binding

(define (srl:extract-original-prefix-binding namespace-assoc-lst)
... Full Code ... )
 Extract original prefix-binding from `namespace-assoc-lst'
 namespace-assoc-lst ::= (listof <namespace-assoc>)
 <namespace-assoc> ::=  ( <namespace-id> "URI" original-prefix? )
 Returns:  (listof (cons original-prefix "URI"))



Handling xml:space attribute


srl:update-space-specifier

(define (srl:update-space-specifier elem space-preserve?)
... Full Code ... )
 Returns the new value of `space-preserve?' in accordance with the value of
 xml:space attribute probably presented for the given SXML element `elem'
 space-preserve? ::= #t | #f  - whether the SXML subtree inherits the
  xml:space attribute with the value "preserve"



Sequence normalization

 Sect. 2 in [1]

srl:normalize-sequence

(define (srl:normalize-sequence node-or-sequence)
... Full Code ... )
 Performs sequence normalization in accordance with [1]
 Returns the SXML document node



Character escaping during string serialization

 Escaping in accordance with [1] and [2]:

 [2] Extensible Markup Language (XML) 1.0 (Third Edition)
 W3C Recommendation 04 February 2004
 http://www.w3.org/TR/2004/REC-xml-20040204

CDATA sections


srl:xml-char-escaped

(define (srl:xml-char-escaped ch)
... Full Code ... )
 Returns #f if a given character `ch' is in XML character range [2]
 Otherwise, returns a string representing the character reference for that
 character


srl:string->cdata-section

(define (srl:string->cdata-section str)
... Full Code ... )
 Represents a given string `str' as a CDATA section



Character data and attribute values


srl:escape-alist-char-data

(define srl:escape-alist-char-data
... Full Code ... )
 Associative lists of characters to be escaped in XML character data and
 attribute values respectively [2]


srl:escape-alist-att-value

(define srl:escape-alist-att-value
... Full Code ... )


srl:escape-alist-html-att

(define srl:escape-alist-html-att
... Full Code ... )


srl:string->escaped

(define (srl:string->escaped str escape-alist html-method?)
... Full Code ... )
 Escape a string with the `srl:xml-char-escaped' and with the `escape-alist'
 supplied
 escape-alist ::= (listof (cons char string))
 html-method? ::= #t | #f
 Returns the escaped string


srl:string->char-data

(define (srl:string->char-data str)
... Full Code ... )


srl:string->att-value

(define (srl:string->att-value str)
... Full Code ... )


srl:string->html-att

(define (srl:string->html-att str)
... Full Code ... )



Serializing entities produced by HtmlPrag

 [3] Neil W. Van Dyke.
 HtmlPrag: Pragmatic Parsing and Emitting of HTML using SXML and SHTML
 Version 0.16, 2005-12-18, http://www.neilvandyke.org/htmlprag/

srl:shtml-entity->char-data

(define (srl:shtml-entity->char-data entity)
... Full Code ... )
 "..SHTML adds a special & syntax for non-ASCII (or non-Extended-ASCII)
 characters. The syntax is (& val), where val is a symbol or string naming
 with the symbolic name of the character, or an integer with the numeric
 value of the character." [3]
  entity ::= `(& ,val)
  val ::= symbol | string | number
 Returns the string representation for the entity



Serialization for markup

 declared-ns-prefixes ::= (listof (cons prefix-string namespace-uri))
 prefix-string, namespace-uri - strings

srl:qname->string

(define (srl:qname->string prefix-string local-part)
... Full Code ... )
 Returns the string representation for a QName
 prefix-string ::= string or #f if the name contains no prefix
 TODO: should check names for proper characters



Different types of nodes


srl:attribute->str-lst

(define (srl:attribute->str-lst prefix-string local-part att-value method)
... Full Code ... )
 Returns the list of strings that constitute the serialized representation
 for the attribute. Inserts a whitespace symbol in the beginning
 method ::= 'xml | 'html


srl:namespace-decl->str-lst

(define (srl:namespace-decl->str-lst prefix-string namespace-uri)
... Full Code ... )
 Returns the list of strings that constitute the serialized representation
 for the namespace declaration. Inserts a whitespace symbol in the beginning
 ATTENTION: character escaping for namespace URI may be improper, study this
  issue


srl:comment->str-lst

(define (srl:comment->str-lst comment-node)
... Full Code ... )
 According to SXML specification,
  <comment> ::=  ( *COMMENT* "comment string" )
 ATTENTION: in the case of ill-formed comment, should probably report an error
 instead of recovering


srl:processing-instruction->str-lst

(define (srl:processing-instruction->str-lst pi-node method)
... Full Code ... )
 According to SXML specification,
 <PI> ::=  ( *PI* pi-target
                   <annotations>? "processing instruction content string" ) 
 method ::= 'xml | 'html
 Subsect 7.3 in [1]: "The HTML output method MUST terminate processing
 instructions with > rather than ?>." 
 ATTENTION: in the case of ill-formed PI content string, should probably
 report an error instead of recovering



SXML element


srl:name->qname-components

(define (srl:name->qname-components name ns-prefix-assig namespace-assoc declared-ns-prefixes)
... Full Code ... )
 Returns: (values
            prefix-string namespace-uri local-part declaration-required?)
 prefix-string - namespace prefix to be given to the serialized name: a string
  or #f if no prefix is required
 namespace-uri - the namespace URI for the given `name', #f if the name has no
  namespace URI
 local-part - local part of the name
 declaration-required ::= #t | #f  - whether `prefix' has to be declared


srl:construct-start-end-tags

(define (srl:construct-start-end-tags elem method ns-prefix-assig namespace-assoc declared-ns-prefixes)
... Full Code ... )
 Constructs start and end tags for an SXML element `elem'
 method ::= 'xml | 'html
 Returns: (values start-tag end-tag
                  ns-prefix-assig namespace-assoc declared-ns-prefixes)
 start-tag ::= (listof string)
 end-tag ::= (listof string) or #f for empty element
 TODO: escape URI attributes for HTML
 TODO: indentation probably should be made between attribute declarations



Recursively walking the tree of SXML elements


srl:node->nested-str-lst-recursive

(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)
... Full Code ... )
 indentation ::= (listof string) or #f  - a list of whitespace strings
  depending on the node nesting or #f if no indent is required
 space-preserve? ::= #t | #f  - whether the subtree inherits the xml:space
  attribute with the value "preserve"
 cdata-section-elements ::= (listof symbol)  - list of element names whose
  child nodes are to be output with CDATA section
 text-node-handler :: string -> string  - a function that performs a proper
  character escaping for the given node if it is a text node
 TODO: do not insert whitespaces adjacent to HTML %inline elements in HTML
 output method


srl:display-node-out-recursive

(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)
... Full Code ... )



Serializing the document node - start of recursion


srl:make-xml-decl

(define (srl:make-xml-decl version standalone)
... Full Code ... )
 Creates the serialized representation for the XML declaration
 Returns: (listof string)
 version ::= string | number
 standalone ::= 'yes | 'no | 'omit


srl:top->nested-str-lst

(define (srl:top->nested-str-lst doc cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone version)
... Full Code ... )
 omit-xml-declaration? ::= #t | #f
 standalone ::= 'yes | 'no | 'omit
 version ::= string | number


srl:display-top-out

(define (srl:display-top-out doc port cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone version)
... Full Code ... )



Interface



Calling the serializer with all the serialization parameters supported

 and with no overhead of parameters parsing.
 ATTENTION: As future versions of this library may provide support for
 additional serialization parameters, the functions `srl:sxml->string' and
 `srl:display-sxml' specified in this subsections may have a different number
 of their arguments in the future versions of the library.

srl:sxml->string

(define (srl:sxml->string sxml-obj cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone version)
... Full Code ... )
 Returns a string that contains the serialized representation for `sxml-obj'.
 cdata-section-elements ::= (listof sxml-name)
 indent ::= #t | #f | whitespace-string
 method = 'xml | 'html
 ns-prefix-assign ::= (listof (cons prefix-symbol namespace-uri-string))
 omit-xml-declaration? ::= #t | #f
 standalone ::= 'yes | 'no | 'omit
 version ::= number | string


srl:display-sxml

(define (srl:display-sxml sxml-obj port-or-filename cdata-section-elements indent method ns-prefix-assig omit-xml-declaration? standalone version)
... Full Code ... )
 Writes the serialized representation of the `sxml-obj' to an output port
 `port'. The result returned by the function is unspecified.



Generalized serialization procedure, parameterizable with all the

 serialization params supported by this implementation

srl:parameterizable

(define (srl:parameterizable sxml-obj . port-or-filename+params)
... Full Code ... )
 procedure srl:parameterizable :: SXML-OBJ [PORT] {PARAM}* ->
                                    -> STRING|unspecified
 sxml-obj - an SXML object to serialize
 param ::= (cons param-name param-value)
 param-name ::= symbol
 
 1. cdata-section-elements
 value ::= (listof sxml-elem-name)
 sxml-elem-name ::= symbol

 2. indent
 value ::= 'yes | #t | 'no | #f | whitespace-string

 3. method
 value ::= 'xml | 'html

 4. ns-prefix-assig
 value ::= (listof (cons prefix namespace-uri))
 prefix ::= symbol
 namespace-uri ::= string

 5. omit-xml-declaration?
 value ::= 'yes | #t | 'no | #f

 6. standalone
 value ::= 'yes | #t | 'no | #f | 'omit

 7. version
 value ::= string | number

 ATTENTION: If a parameter name is unexpected or a parameter value is
 ill-formed, the parameter is silently ignored. Probably, a warning message
 in such a case would be more appropriate.

 Example:
 (srl:parameterizable 
   '(tag (@ (attr "value")) (nested "text node") (empty))
   (current-output-port)
   '(method . xml)  ; XML output method is used by default
   '(indent . "\t")  ; use a single tabulation to indent nested elements
   '(omit-xml-declaration . #f)  ; add XML declaration
   '(standalone . yes)  ; denote a standalone XML document
   '(version . "1.0"))  ; XML version



High-level functions for popular serialization use-cases

 These functions use only a subset of serializer functionality, however, this
 subset seems sufficient for most practical purposes.

srl:sxml->xml

(define (srl:sxml->xml sxml-obj . port-or-filename)
... Full Code ... )
 procedure srl:sxml->xml :: SXML-OBJ [PORT-OR-FILENAME] -> STRING|unspecified

 Serializes the `sxml-obj' into XML, with indentation to facilitate
 readability by a human.

 sxml-obj - an SXML object (a node or a nodeset) to be serialized
 port-or-filename - an output port or an output file name, an optional
  argument
 If `port-or-filename' is not supplied, the functions return a string that
 contains the serialized representation of the `sxml-obj'.
 If `port-or-filename' is supplied and is a port, the functions write the
 serialized representation of `sxml-obj' to this port and return an
 unspecified result.
 If `port-or-filename' is supplied and is a string, this string is treated as
 an output filename, the serialized representation of `sxml-obj' is written to
 that filename and an unspecified result is returned. If a file with the given
 name already exists, the effect is unspecified.


srl:sxml->xml-noindent

(define (srl:sxml->xml-noindent sxml-obj . port-or-filename)
... Full Code ... )
 procedure srl:sxml->xml-noindent :: SXML-OBJ [PORT-OR-FILENAME] ->
                                      -> STRING|unspecified

 Serializes the `sxml-obj' into XML, without indentation.


srl:sxml->html

(define (srl:sxml->html sxml-obj . port-or-filename)
... Full Code ... )
 procedure srl:sxml->html :: SXML-OBJ [PORT-OR-FILENAME] -> STRING|unspecified

 Serializes the `sxml-obj' into HTML, with indentation to facilitate
 readability by a human.

 sxml-obj - an SXML object (a node or a nodeset) to be serialized
 port-or-filename - an output port or an output file name, an optional
  argument
 If `port-or-filename' is not supplied, the functions return a string that
 contains the serialized representation of the `sxml-obj'.
 If `port-or-filename' is supplied and is a port, the functions write the
 serialized representation of `sxml-obj' to this port and return an
 unspecified result.
 If `port-or-filename' is supplied and is a string, this string is treated as
 an output filename, the serialized representation of `sxml-obj' is written to
 that filename and an unspecified result is returned. If a file with the given
 name already exists, the effect is unspecified.


srl:sxml->html-noindent

(define (srl:sxml->html-noindent sxml-obj . port-or-filename)
... Full Code ... )
 procedure srl:sxml->html-noindent :: SXML-OBJ [PORT-OR-FILENAME] ->
                                       -> STRING|unspecified

 Serializes the `sxml-obj' into HTML, without indentation.


Code

srl:newline

Index
(define srl:newline (string (integer->char 10)))

srl:map-append

Index
 `map' and `append' in a single pass:
 (srl:map-append func lst) = (apply append (map func lst))
 A simplified analogue of `map-union' from "sxpathlib.scm"
(define (srl:map-append func lst)
  (if (null? lst)
      lst
      (append (func (car lst))
              (srl:map-append func (cdr lst)))))
cond-expand
Index
 procedure srl:apply-string-append :: STR-LST -> STRING
 str-lst ::= (listof string)
 Concatenates `str-lst' members into a single string
 (srl:apply-string-append str-lst) = (apply string-append str-lst)
(cond-expand
 (chicken
  ; In Chicken, procedures are generally limited to 126 arguments
  ; http://www.call-with-current-continuation.org/
  ; Due to this Chicken limitation, we cannot apply `string-append' directly
  ; for a potentially long `str-lst'
  
  ; Similar to R5RS 'list-tail' but returns the new list consisting of the
  ; first 'k' members of 'lst'
  (define (srl:list-head lst k)
    (if (or (null? lst) (zero? k))
        '()
        (cons (car lst) (srl:list-head (cdr lst) (- k 1)))))

  ; Because of Chicken 126-argument limitation, I do not care of intermediate
  ; garbage produced in the following solution:
  (define (srl:apply-string-append str-lst)
    (cond
      ((null? str-lst) "")
      ((null? (cdr str-lst)) (car str-lst))
      (else  ; at least two members
       (let ((middle (inexact->exact (round (/ (length str-lst) 2)))))
         (string-append
          (srl:apply-string-append (srl:list-head str-lst middle))
          (srl:apply-string-append (list-tail str-lst middle)))))))
  )
 (else
  (define (srl:apply-string-append str-lst)
    (apply string-append str-lst))
  ))

srl:assoc-cdr-string=

Index
 Analogue of `assoc'
 However, search is performed by `cdr' of each alist member and `string=?' is
 used for comparison
(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)))))

srl:member-ci

Index
 Analogue of `member' for strings that uses case insensitive comparison
(define (srl:member-ci str lst)
  (cond
    ((null? lst) #f)
    ((string-ci=? str (car lst)) lst)
    (else (srl:member-ci str (cdr lst)))))

srl:mem-pred

Index
 Analogue of `member'
 The end of the `lst' is returned, from the first member that satisfies
 the `pred?'
(define (srl:mem-pred pred? lst)
  (cond
    ((null? lst) #f)
    ((pred? (car lst)) lst)
    (else (srl:mem-pred pred? (cdr lst)))))

srl:nodeset?

Index
 Returns #t if given object is a nodelist
(define (srl:nodeset? x)
  (or (and (pair? x) (not (symbol? (car x)))) (null? x)))

srl:map-union

Index
 Apply proc to each element of lst and return the list of results.
 if proc returns a nodelist, splice it into the result
(define (srl:map-union proc lst)
  (if (null? lst) lst
      (let ((proc-res (proc (car lst))))
	((if (srl:nodeset? proc-res) append cons)
	 proc-res (srl:map-union proc (cdr lst))))))

srl:select-kids

Index
 A simplified implementation of `select-kids' is sufficienf for the serializer
(define (srl:select-kids test-pred?)
  (lambda (node)		; node or node-set
    (cond 
     ((null? node) node)
     ((not (pair? node)) '())   ; No children
     ((symbol? (car node))
      (filter test-pred? (cdr node)))
     (else (srl:map-union (srl:select-kids test-pred?) node)))))

srl:separate-list

Index
  Separates the list into two lists with respect to the predicate
  Returns:  (values  res-lst1  res-lst2)
 res-lst1 - contains all members from the input lst that satisfy the pred?
 res-lst2 - contains the remaining members of the input lst
(define (srl:separate-list pred? lst)
  (let loop ((lst lst)
             (satisfy '())
             (rest '()))
    (cond
      ((null? lst)
       (values (reverse satisfy) (reverse rest)))
      ((pred? (car lst))   ; the first member satisfies the predicate
       (loop (cdr lst)
             (cons (car lst) satisfy) rest))
      (else
       (loop (cdr lst)
             satisfy (cons (car lst) rest))))))

srl:clean-fragments

Index
 A simplified implementation of `sxml:clean-fragments'
(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)))))))

srl:display-fragments-2nesting

Index
 A very much simplified analogue of `sxml:display-fragments' for fragments
 that have no more than two levels of nesting
 fragments-level2 ::= (listof fragments-level1)
 fragments-level1 ::= string | (listof string)
(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))

srl:split-name

Index
 Splits an SXML `name' into namespace id/uri and local part
 Returns: (cons  namespace-id  local-part)
 local-part - string
 namespace-id - string or #f if the `name' does not have a prefix
(define (srl:split-name name)
  (let* ((name-str (symbol->string name))
         (lng (string-length name-str)))
  (let iter ((i (- lng 1)))
    (cond
      ((< i 0)  ; name scanned, #\: not found
       (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)))))))

srl:atomic->string

Index
 Converts SXML atomic object to a string. Keeps non-atomic object unchanged.
 A simplified analogue of applying the XPath `string(.)' function to atomic
 object.
(define (srl:atomic->string obj)
  (cond
    ((or (pair? obj)  ; non-atomic type
         (string? obj)) obj)
    ((number? obj)
     (number->string obj))
    ((boolean? obj)
     (if obj "true" "false"))
    (else  ; unexpected type
     ; ATTENTION: should probably raise an error here
     obj)))

srl:empty-elem?

Index
 Whether an SXML element is empty
(define (srl:empty-elem? elem)
  (or (null? (cdr elem))  ; just the name      
      (and (null? (cddr elem))  ; just the name and attributes
           (pair? (cadr elem)) (eq? (caadr elem) '@))
      (and (not (null? (cddr elem)))  ; name, attributes, and SXML 2.X aux-list
           (null? (cdddr elem))
           (pair? (caddr elem)) (eq? (caaddr elem) '@@))))

srl:normalize-sequence

Index
 Performs sequence normalization in accordance with [1]
 Returns the SXML document node
(define (srl:normalize-sequence node-or-sequence)
  (letrec
      ((normaliz-step-1
        ; "If the sequence that is input to serialization is empty, create a
        ; sequence S1 that consists of a zero-length string. Otherwise, copy
        ; each item in the sequence that is input to serialization to create
        ; the new sequence S1." [1]
        (lambda (node-or-seq)
          (cond
            ((null? node-or-seq)  ; empty sequence
             '(""))
            ; Effect of `as-nodeset' from "sxpathlib.scm"
            ((or (not (pair? node-or-seq))  ; single item
                 (symbol? (car node-or-seq)))  ; single node
             (list node-or-seq))
            (else
             node-or-seq))))
       (normaliz-step-2
        ; "For each item in S1, if the item is atomic, obtain the lexical
        ; representation of the item by casting it to an xs:string and copy
        ; the string representation to the new sequence; otherwise, copy the
        ; item, which will be a node, to the new sequence. The new sequence is
        ; S2." [1]
        (lambda (seq)
          (map
           (lambda (item) (srl:atomic->string item))
           seq)))
       (normaliz-step-3
        ; "For each subsequence of adjacent strings in S2, copy a single
        ; string to the new sequence equal to the values of the strings in the
        ; subsequence concatenated in order, each separated by a single space.
        ; Copy all other items to the new sequence. The new sequence is S3."
        (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)  ; source sequence is over
                    (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)))))))
       ; Step 4 from [1] is redundant for SXML, since SXML text nodes are not
       ; distinquished from strings
       (normaliz-step-5
        ; "For each item in S4, if the item is a document node, copy its
        ; children to the new sequence; otherwise, copy the item to the new
        ; sequence. The new sequence is S5." [1]
        (lambda (seq)
          (cond            
            ((null? seq)
             seq)
            ((and (pair? (car seq)) (eq? (caar seq) '*TOP*))
             ; Document node
             (append (cdar seq) (normaliz-step-5 (cdr seq))))
            (else
             (cons (car seq) (normaliz-step-5 (cdr seq)))))))
       (normaliz-step-6
        ; "For each subsequence of adjacent text nodes in S5, copy a single
        ; text node to the new sequence equal to the values of the text nodes
        ; in the subsequence concatenated in order. Any text nodes with values
        ; of zero length are dropped. Copy all other items to the new sequence.
        ; The new sequence is S6." [1]
        ; Much like Step 3; however, a space between adjacent strings is not
        ; inserted and the zero-length strings are removed
        (lambda (seq)
          (let loop ((src (reverse seq))
                     (res '()))
            (cond
              ((null? src)
               res)
              ((string? (car src))
               (if
                (string=? (car src) "")  ; empty string
                (loop (cdr src) res)
                (let adjacent ((src (cdr src))
                               (adj-strs (list (car src))))
                  (cond
                    ((null? src)  ; source sequence is over
                     (cons (srl:apply-string-append adj-strs) res))
                    ((string? (car src))
                     ; If it is an empty string, the effect of its presense
                     ; will be removed by string concatenation
                     (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
        ; "It is a serialization error [err:SENR0001] if an item in S6 is an
        ; attribute node or a namespace node. Otherwise, construct a new
        ; sequence, S7, that consists of a single document node and copy all
        ; the items in the sequence, which are all nodes, as children of that
        ; document node." [1]
        ; On this step, we should take care of SXML aux-lists
        ; ATTENTION: should generally raise an error in the presense of
        ;  attribute nodes in a sequence. By nature of SXML 3.0, however,
        ;  attribute nodes on the top level are treated as aux-nodes
        (lambda (seq)
          (call-with-values
           (lambda ()
             (srl:separate-list
              (lambda (item)
                (and (pair? item)
                     (or (eq? (car item) '@@)  ; aux-list in SXML 2.X
                         (eq? (car item) '@)  ; aux-list in SXML 3.0
                         )))
              seq))
           (lambda (aux-lists body)
             (if
              (null? aux-lists)
              `(*TOP* ,@body)
              `(*TOP*
                (@ ,@(srl:map-append cdr aux-lists))
                ,@body)))))))
    ; TODO: According to [1], if the normalized sequence does not have exactly
    ; one element node node child or has text node children, then the
    ; serialized output should be an XML external general parsed entity.
    ; However, external parsed entities are not currently handled by SSAX
    ; parser. Should think of a compromise between conformance and practical
    ; usability.
    (normaliz-step-7
     (normaliz-step-6
      (normaliz-step-5
       (normaliz-step-3
        (normaliz-step-2
         (normaliz-step-1 node-or-sequence))))))))

srl:qname->string

Index
 Returns the string representation for a QName
 prefix-string ::= string or #f if the name contains no prefix
 TODO: should check names for proper characters
(define (srl:qname->string prefix-string local-part)
  (if prefix-string
      (string-append prefix-string ":" local-part)
      local-part))

srl:node->nested-str-lst-recursive

Index
 indentation ::= (listof string) or #f  - a list of whitespace strings
  depending on the node nesting or #f if no indent is required
 space-preserve? ::= #t | #f  - whether the subtree inherits the xml:space
  attribute with the value "preserve"
 cdata-section-elements ::= (listof symbol)  - list of element names whose
  child nodes are to be output with CDATA section
 text-node-handler :: string -> string  - a function that performs a proper
  character escaping for the given node if it is a text node
 TODO: do not insert whitespaces adjacent to HTML %inline elements in HTML
 output method
(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
   (text-node-handler (srl:atomic->string node))
   (case (car node)  ; node name
     ((*COMMENT*)
      (srl:comment->str-lst node))     
     ((*PI*)
      (srl:processing-instruction->str-lst node method))
     ((&)
      (srl:shtml-entity->char-data node))
     ((*DECL*)  ; recovering for non-SXML nodes
      '())
     (else  ; otherwise - an element node
      (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)  ; empty element => recursion stops
          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")))
                    ; No escaping for strings inside these HTML elements
                    (lambda (str) str))
                   (else
                    srl:string->char-data)))
                (content ((srl:select-kids
                           (lambda (node)  ; TODO: support SXML entities
                             (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"))))
                  ; No indent - on this level and subsequent levels
                  (values #f #f))
                 ((or space-preserve?
                      (srl:mem-pred  ; at least a single text node
                       (lambda (node) (not (pair? node)))
                       content))
                  ; No indent on this level, possible indent on nested levels
                  (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))))))))))))

srl:display-node-out-recursive

Index
(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))  ; text node
   (display (text-node-handler (srl:atomic->string node)) port)
   (case (car node)  ; node name
     ((*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*)  ; recovering for non-SXML nodes
      #f)
     (else  ; otherwise - an element node
      (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  ; there exists content
            (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")))
                      ; No escaping for strings inside these HTML elements
                      (lambda (str) str))
                     (else
                      srl:string->char-data)))
                  (content ((srl:select-kids
                             (lambda (node)  ; TODO: support SXML entities
                               (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"))))
                    ; No indent - on this level and subsequent levels
                    (values #f #f))
                   ((or space-preserve?
                        (srl:mem-pred  ; at least a single text node
                         (lambda (node) (not (pair? node)))
                         content))
                    ; No indent on this level, possible indent on nested levels
                    (values #f indentation))
                   (else
                    (values (cons srl:newline indentation)
                            (cons (car indentation) indentation)))))
               (lambda (indent-here indent4recursive)
                 (begin
                   (for-each  ; display content
                    (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)))))))))))))

srl:conventional-ns-prefixes

Index
 Conventional namespace prefix referred to in XML-related specifications
 These prefixes are used for serializing the corresponding namespace URIs by
 default, unless a different prefix is supplied
(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")))

srl:namespace-assoc-for-elem

Index
 Returns (listof <namespace-assoc>) for the given SXML element
(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  ; compatibility with SXML 3.0
       (lambda (node) (and (pair? node) (eq? (car node) '@))))
      ((srl:select-kids
        (lambda (node) (and (pair? node) (eq? (car node) '@))))
       elem))
     ((srl:select-kids  ; compatibility with SXML 2.X
       (lambda (node) (and (pair? node) (eq? (car node) '@@))))
      elem)))))

srl:ns-assoc-for-top

Index
 Returns (listof <namespace-assoc>) for the SXML document node
(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)
        ; After sequence normalization [1], the SXML 3.0 aux-list is used
        ; at the top-level
        (and (pair? node) (eq? (car node) '@))))
     doc))))

srl:extract-original-prefix-binding

Index
 Extract original prefix-binding from `namespace-assoc-lst'
 namespace-assoc-lst ::= (listof <namespace-assoc>)
 <namespace-assoc> ::=  ( <namespace-id> "URI" original-prefix? )
 Returns:  (listof (cons original-prefix "URI"))
(define (srl:extract-original-prefix-binding namespace-assoc-lst)
  (map
   (lambda (triple) (cons (caddr triple) (cadr triple)))
   (filter  ; specifies original prefix
    (lambda (memb) (= (length memb) 3))
    namespace-assoc-lst)))

srl:update-space-specifier

Index
 Returns the new value of `space-preserve?' in accordance with the value of
 xml:space attribute probably presented for the given SXML element `elem'
 space-preserve? ::= #t | #f  - whether the SXML subtree inherits the
  xml:space attribute with the value "preserve"
(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)  ; no xml:space attribute
       space-preserve?)
      ((string=? (car xml-space-val) "preserve")
       #t)
      ((string=? (car xml-space-val) "default")
       #f)
      (else space-preserve?))))

srl:xml-char-escaped

Index
 Returns #f if a given character `ch' is in XML character range [2]
 Otherwise, returns a string representing the character reference for that
 character
(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) ";"
                       ))))

srl:string->cdata-section

Index
 Represents a given string `str' as a CDATA section
(define (srl:string->cdata-section str)
  (let ((flush-buffer
         ; If a `buffer' is non-empty, converts it to a CDATA string and
         ; cons'es this string to `res'. Returns a new res
         (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  ; any other character
       (loop (cdr src)
             (cons (car src) buffer)
             res))))))

srl:escape-alist-char-data

Index
 Associative lists of characters to be escaped in XML character data and
 attribute values respectively [2]
(define srl:escape-alist-char-data
  '((#\& . "&amp;") (#\< . "&lt;") (#\> . "&gt;")))

srl:escape-alist-att-value

Index
(define srl:escape-alist-att-value
  (append `((#\' . "&apos;") (#\" . "&quot;")
            ; Escaping the newline character in attribute value
            (,(integer->char 10) . "&#10;"))
          srl:escape-alist-char-data))

srl:escape-alist-html-att

Index
(define srl:escape-alist-html-att
  '((#\& . "&amp;") (#\> . "&gt;") (#\' . "&apos;") (#\" . "&quot;")))

srl:string->escaped

Index
 Escape a string with the `srl:xml-char-escaped' and with the `escape-alist'
 supplied
 escape-alist ::= (listof (cons char string))
 html-method? ::= #t | #f
 Returns the escaped string
(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)  ; current character matches the alist
       => (lambda (pair)
            (if
             ; Subsect. 7.2 in [1]:
             ; "The HTML output method MUST NOT escape a & character occurring
             ; in an attribute value immediately followed by a { character"
             (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)))))

srl:string->char-data

Index
(define (srl:string->char-data str)
  (srl:string->escaped str srl:escape-alist-char-data #f))

srl:string->att-value

Index
(define (srl:string->att-value str)
  (srl:string->escaped str srl:escape-alist-att-value #f))

srl:string->html-att

Index
(define (srl:string->html-att str)
  (srl:string->escaped str srl:escape-alist-html-att #t))

srl:shtml-entity->char-data

Index
 "..SHTML adds a special & syntax for non-ASCII (or non-Extended-ASCII)
 characters. The syntax is (& val), where val is a symbol or string naming
 with the symbolic name of the character, or an integer with the numeric
 value of the character." [3]
  entity ::= `(& ,val)
  val ::= symbol | string | number
 Returns the string representation for the entity
(define (srl:shtml-entity->char-data entity)
  ; TODO: think of an appropriate error message for an ill-formed 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))
        ; to guarantee well-formedness of the result produced
        (string-append "&#" (number->string val) ";")
        )
       (else  ; should signal of an error
        "")))
   ""))

srl:attribute->str-lst

Index
 Returns the list of strings that constitute the serialized representation
 for the attribute. Inserts a whitespace symbol in the beginning
 method ::= 'xml | 'html
(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)
       (if (string=? local-part attval)  ; boolean attribute
           (list " " local-part)
           (list " " local-part "=\"" (srl:string->html-att attval) "\"")))
      (else  ; unprefixed attribute, XML output method
       (list " " local-part "=\"" (srl:string->att-value attval) "\"")))))

srl:namespace-decl->str-lst

Index
 Returns the list of strings that constitute the serialized representation
 for the namespace declaration. Inserts a whitespace symbol in the beginning
 ATTENTION: character escaping for namespace URI may be improper, study this
  issue
(define (srl:namespace-decl->str-lst prefix-string namespace-uri)
  (list " xmlns:" prefix-string "=\""
        (srl:string->att-value namespace-uri) "\""))

srl:comment->str-lst

Index
 According to SXML specification,
  <comment> ::=  ( *COMMENT* "comment string" )
 ATTENTION: in the case of ill-formed comment, should probably report an error
 instead of recovering
(define (srl:comment->str-lst comment-node)
  (let ((proper-string-in-comment?
         ; Whether a proper string occurs in the comment node. Thus,
         ; "For compatibility, the string '--' (double-hyphen) MUST NOT occur
         ; within comments. ... Note that the grammar does not allow a comment
         ; ending in --->." [2]
         (lambda (str)
           (let ((lng (string-length str)))
             (or
              (zero? lng)  ; empty string allowed in comment [2]
              (and
               (not (char=? (string-ref str 0) #\-))
               (let iter ((i 1)
                          (prev-hyphen? #f))
                 (cond
                   ((>= i lng)
                    (not prev-hyphen?)  ; string must not end with 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 "<!--" "-->")  ; should probably report of an error
        )))

srl:processing-instruction->str-lst

Index
 According to SXML specification,
 <PI> ::=  ( *PI* pi-target
                   <annotations>? "processing instruction content string" ) 
 method ::= 'xml | 'html
 Subsect 7.3 in [1]: "The HTML output method MUST terminate processing
 instructions with > rather than ?>." 
 ATTENTION: in the case of ill-formed PI content string, should probably
 report an error instead of recovering
(define (srl:processing-instruction->str-lst pi-node method)
  (let ((string-not-contain-charlist?
         ; Whether `str' does not contain a sequence of characters from
         ; `char-lst' as its substring
         (lambda (str char-lst)
           (let ((lng (string-length str)))
             (or
              (zero? lng)  ; empty string doesn't contain
              (let iter ((i 0)
                         (pattern char-lst))
                (cond                  
                  ((>= i lng) #t)
                  ((char=? (string-ref str i) (car pattern))
                   (if (null? (cdr pattern))  ; it is the last member
                       #f  ; contains
                       (iter (+ i 1) (cdr pattern))))
                  (else
                   (iter (+ i 1) char-lst)))))))))
    (if
     (or (null? (cdr pi-node))
         (not (symbol? (cadr pi-node))))  ; no target => ill-formed PI
     '()  ; should probably raise an error
     (let ((content (filter string? (cddr pi-node))))
       (cond
         ((null? content)  ; PI with no content - correct situation
          (list "<?" (symbol->string (cadr pi-node))
                (if (eq? method 'html) ">" "?>")))
         ; Subsect. 7.3 in [1]: "It is a serialization error to use the HTML
         ; output method when > appears within a processing instruction in
         ; the data model instance being serialized."
         ((and (null? (cdr content))  ; only a single member
               (string-not-contain-charlist?
                (car content)
                (if (eq? method 'html) '(#\>) '(#\? #\>))))
          (list "<?" (symbol->string (cadr pi-node)) " " (car content)
                (if (eq? method 'html) ">" "?>")))
         (else  ; should probably signal of an error
          '()))))))

srl:name->qname-components

Index
 Returns: (values
            prefix-string namespace-uri local-part declaration-required?)
 prefix-string - namespace prefix to be given to the serialized name: a string
  or #f if no prefix is required
 namespace-uri - the namespace URI for the given `name', #f if the name has no
  namespace URI
 local-part - local part of the name
 declaration-required ::= #t | #f  - whether `prefix' has to be declared
(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  ; try to use namespace-id as a prefix
                 (not (assq (string->symbol ns-id) ns-prefix-assig))
                 (not (assoc ns-id declared-ns-prefixes)))
            ns-id
            ; Otherwise - generate unique prefix
            ; Returns a prefix-string not presented in ns-prefix-assig and
            ; declared-ns-prefixes
            (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))  ; no namespace-id => no namespace
       (values #f #f (cdr n-parts)  ; name as a string
               #f))
      ((string-ci=? (car n-parts) "xml")  ; reserved XML namespace
       (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))  ; suppose a namespace-id
                   namespace-assoc)
             => (lambda (lst)
                  (values (cadr lst) (car n-parts))))
            (else  ; first part of a name is a namespace URI
             (values (car n-parts) #f))))
        (lambda (namespace-uri ns-id)
          (cond
            ((srl:assoc-cdr-string= namespace-uri declared-ns-prefixes)
             => (lambda (pair)
                  ; Prefix for that namespace URI already declared
                  (values (car pair) namespace-uri (cdr n-parts) #f)))
            (else  ; namespace undeclared
             (values
              (cond
                ((srl:assoc-cdr-string= namespace-uri ns-prefix-assig)
                 => (lambda (pair)
                      ; A candidate namespace prefix is supplied from the user
                      (let ((candidate (symbol->string (car pair))))
                        (if
                         (assoc candidate declared-ns-prefixes)
                         ; The prefix already bound to a different namespace
                         ; Avoid XML prefix re-declaration
                         (use-ns-id-or-generate-prefix ns-id)
                         candidate))))
                (else
                 (use-ns-id-or-generate-prefix ns-id)))
              namespace-uri
              (cdr n-parts)
              #t  ; in any case, prefix declaration is required
              )))))))))

srl:construct-start-end-tags

Index
 Constructs start and end tags for an SXML element `elem'
 method ::= 'xml | 'html
 Returns: (values start-tag end-tag
                  ns-prefix-assig namespace-assoc declared-ns-prefixes)
 start-tag ::= (listof string)
 end-tag ::= (listof string) or #f for empty element
 TODO: escape URI attributes for HTML
 TODO: indentation probably should be made between attribute declarations
(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  ; element name
          (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)  ; not SXML 3.0 aux-list
                          (and (pair? node) (not (eq? (car node) '@)))))
                       ((srl:select-kids
                         (lambda (node)
                           (and (pair? node) (eq? (car node) '@))))
                        elem))))
                    (start-tag
                     (if
                      (or (not empty?)
                          (and (eq? method 'html)
                               (not elem-prefix)
                               (srl:member-ci
                                elem-local
                                ; ATTENTION: should probably move this list
                                ; to a global const
                                '("area" "base" "basefont" "br" "col"
                                  "frame" "hr" "img" "input" "isindex"
                                  "link" "meta" "param"))))
                      '(">") '("/>")))
                    (ns-prefix-assig ns-prefix-assig)
                    (namespace-assoc namespace-assoc)
                    (declared-ns-prefixes
                     ; As if element namespace already declared
                     (if elem-decl-required?
                         (cons (cons elem-prefix elem-uri)
                               declared-ns-prefixes)
                         declared-ns-prefixes)))
           (if
            (null? attrs)  ; attributes scanned
            (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)  ; attribute name
                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
                        ; TODO: optimize for HTML output method
                        (if (null? (cdar attrs))  ; no attribute value
                            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))))))))))))

srl:make-xml-decl

Index
 Creates the serialized representation for the XML declaration
 Returns: (listof string)
 version ::= string | number
 standalone ::= 'yes | 'no | 'omit
(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) "'?>"))))

srl:top->nested-str-lst

Index
 omit-xml-declaration? ::= #t | #f
 standalone ::= 'yes | 'no | 'omit
 version ::= string | number
(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  ; => output each member from the newline
            (let ((indentation (list indent)))  ; for nested elements
              (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  ; document node content
             (lambda (node)  ; TODO: support SXML entities
               (not (and
                     (pair? node) (memq (car node) '(@ @@ *ENTITY*))))))
            doc))))
    (if (or (eq? method 'html) omit-xml-declaration?)
        (if (and indent (not (null? serialized-content)))
            ; Remove the starting newline
            ; ATTENTION: beware of `Gambit cadar bug':
            ; http://mailman.iro.umontreal.ca/pipermail/gambit-list/
            ;   2005-July/000315.html
            (cons (cadar serialized-content) (cdr serialized-content))
            serialized-content)
        (list (srl:make-xml-decl version standalone) serialized-content))))

srl:display-top-out

Index
(define (srl:display-top-out doc port
                             cdata-section-elements indent
                             method ns-prefix-assig
                             omit-xml-declaration? standalone version)  
  (let ((no-xml-decl?  ; no XML declaration was displayed?
         (if (not (or (eq? method 'html) omit-xml-declaration?))
             (begin
               (for-each  ; display xml declaration
                (lambda (x) (display x port))
                (srl:make-xml-decl version standalone))
               #f)
             #t))
        (content  ; document node content
         ((srl:select-kids
           (lambda (node)  ; TODO: support SXML entities
             (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)  ; generally a rare practical situation
         #t)  ; nothing more to do
        ((and indent no-xml-decl?)
         ; We'll not display newline before (car content)
         (let ((indentation (list indent)))  ; for nested elements
           (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
            ; After sequence normalization, content does not contain #f
            (cons #f (cdr content)))))
        (else
         (for-each
          (if
           indent  ; => output each member from the newline
           (let ((indentation (list indent)))  ; for nested elements
             (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))))))

srl:sxml->string

Index
 Returns a string that contains the serialized representation for `sxml-obj'.
 cdata-section-elements ::= (listof sxml-name)
 indent ::= #t | #f | whitespace-string
 method = 'xml | 'html
 ns-prefix-assign ::= (listof (cons prefix-symbol namespace-uri-string))
 omit-xml-declaration? ::= #t | #f
 standalone ::= 'yes | 'no | 'omit
 version ::= number | string
(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))))

srl:display-sxml

Index
 Writes the serialized representation of the `sxml-obj' to an output port
 `port'. The result returned by the function is unspecified.
(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)  ; a 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)  ; newline at the end of file
       (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)))

srl:parameterizable

Index
 procedure srl:parameterizable :: SXML-OBJ [PORT] {PARAM}* ->
                                    -> STRING|unspecified
 sxml-obj - an SXML object to serialize
 param ::= (cons param-name param-value)
 param-name ::= symbol
 
 1. cdata-section-elements
 value ::= (listof sxml-elem-name)
 sxml-elem-name ::= symbol

 2. indent
 value ::= 'yes | #t | 'no | #f | whitespace-string

 3. method
 value ::= 'xml | 'html

 4. ns-prefix-assig
 value ::= (listof (cons prefix namespace-uri))
 prefix ::= symbol
 namespace-uri ::= string

 5. omit-xml-declaration?
 value ::= 'yes | #t | 'no | #f

 6. standalone
 value ::= 'yes | #t | 'no | #f | 'omit

 7. version
 value ::= string | number

 ATTENTION: If a parameter name is unexpected or a parameter value is
 ill-formed, the parameter is silently ignored. Probably, a warning message
 in such a case would be more appropriate.

 Example:
 (srl:parameterizable 
   '(tag (@ (attr "value")) (nested "text node") (empty))
   (current-output-port)
   '(method . xml)  ; XML output method is used by default
   '(indent . "\t")  ; use a single tabulation to indent nested elements
   '(omit-xml-declaration . #f)  ; add XML declaration
   '(standalone . yes)  ; denote a standalone XML document
   '(version . "1.0"))  ; XML version
(define (srl:parameterizable sxml-obj . port-or-filename+params)
  (call-with-values
   (lambda ()
     (if (and (not (null? port-or-filename+params))
              (or (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)  ; all parameters parsed
          (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)))  ; not a pair or has no param value
              (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  ; no non-pair members
                                    (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))))))))))

srl:sxml->xml

Index
 procedure srl:sxml->xml :: SXML-OBJ [PORT-OR-FILENAME] -> STRING|unspecified

 Serializes the `sxml-obj' into XML, with indentation to facilitate
 readability by a human.

 sxml-obj - an SXML object (a node or a nodeset) to be serialized
 port-or-filename - an output port or an output file name, an optional
  argument
 If `port-or-filename' is not supplied, the functions return a string that
 contains the serialized representation of the `sxml-obj'.
 If `port-or-filename' is supplied and is a port, the functions write the
 serialized representation of `sxml-obj' to this port and return an
 unspecified result.
 If `port-or-filename' is supplied and is a string, this string is treated as
 an output filename, the serialized representation of `sxml-obj' is written to
 that filename and an unspecified result is returned. If a file with the given
 name already exists, the effect is unspecified.
(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")))

srl:sxml->xml-noindent

Index
 procedure srl:sxml->xml-noindent :: SXML-OBJ [PORT-OR-FILENAME] ->
                                      -> STRING|unspecified

 Serializes the `sxml-obj' into XML, without indentation.
(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")))

srl:sxml->html

Index
 procedure srl:sxml->html :: SXML-OBJ [PORT-OR-FILENAME] -> STRING|unspecified

 Serializes the `sxml-obj' into HTML, with indentation to facilitate
 readability by a human.

 sxml-obj - an SXML object (a node or a nodeset) to be serialized
 port-or-filename - an output port or an output file name, an optional
  argument
 If `port-or-filename' is not supplied, the functions return a string that
 contains the serialized representation of the `sxml-obj'.
 If `port-or-filename' is supplied and is a port, the functions write the
 serialized representation of `sxml-obj' to this port and return an
 unspecified result.
 If `port-or-filename' is supplied and is a string, this string is treated as
 an output filename, the serialized representation of `sxml-obj' is written to
 that filename and an unspecified result is returned. If a file with the given
 name already exists, the effect is unspecified.
(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")))

srl:sxml->html-noindent

Index
 procedure srl:sxml->html-noindent :: SXML-OBJ [PORT-OR-FILENAME] ->
                                       -> STRING|unspecified

 Serializes the `sxml-obj' into HTML, without indentation.
(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")))