(lib-load "final-state-automaton.scm")
(define (standard-prolog . optional-parameter-list)
(let* ((language (optional-parameter 1 optional-parameter-list #f))
(doc-type-decl (xml-document-type-declaration-in language))
)
(string-append
(xml-declaration) (as-string #\newline)
doc-type-decl
(if (not (empty-string? doc-type-decl)) (as-string #\newline) "")
(copyright-clause)
(if (not (empty-string? (copyright-clause))) (as-string #\newline) ""))))
(define (xml-declaration)
"<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>")
(define (end-laml)
(check-id-and-idref-attributes!)
(if (memq xml-link-checking (list 'all 'relative-urls))
(if (> (length relative-url-list-for-later-checking) 0)
(begin
(display-message "Checking" (length relative-url-list-for-later-checking) "relative links...")
(check-relative-url-list! relative-url-list-for-later-checking)
(if (= 0 relative-url-problem-count) (display-message "All relative links are OK"))
(set! relative-url-list-for-later-checking '())
(set! relative-url-problem-count 0)
)
(display-message "No relative links to check"))
)
(if (and (memq xml-link-checking (list 'all 'absolute-urls)) (> (length absolute-url-list-for-later-checking) 0))
(begin
(display-message "Checking" (length absolute-url-list-for-later-checking) "absolute links...")
(check-absolute-url-list! absolute-url-list-for-later-checking)
(if (= 0 absolute-url-problem-count) (display-message "All absolute links are OK"))
(set! absolute-url-list-for-later-checking '())
(set! absolute-url-problem-count 0)
)
)
(original-end-laml))
(define laml-internal-representation 'laml)
(define xml-check-attributes? #t)
(define xml-validate-contents? #t)
(define xml-link-checking 'relative-urls)
(define xml-check-language-overlap? #t)
(define (xml-transliterate-character-data-in? language)
(assert-known-xml-language language "xml-transliterate-character-data-in?")
(eval-cur-env (aggregated-variable (as-string language) "xml-transliterate-character-data?")))
(define (set-xml-transliterate-character-data-in language new-value)
(assert-known-xml-language language "set-xml-transliterate-character-data-in")
(eval-cur-env (list 'set! (aggregated-variable (as-string language) "xml-transliterate-character-data?") new-value)))
(define (xml-char-transformation-table-in language)
(assert-known-xml-language language "xml-char-transformation-table-in")
(eval-cur-env (aggregated-variable (as-string language) "xml-char-transformation-table")))
(define (set-xml-char-transformation-table-in language new-value)
(assert-known-xml-language language "set-xml-char-transformation-table-in")
(eval-cur-env (list 'set! (aggregated-variable (as-string language) "xml-char-transformation-table") new-value)))
(define (xml-non-transliteration-elements-in language)
(assert-known-xml-language language "xml-non-transliteration-elements-in")
(eval-cur-env (aggregated-variable (as-string language) "xml-non-transliteration-elements")))
(define (xml-preformatted-text-elements-in language)
(assert-known-xml-language language "xml-preformatted-text-elements-in")
(eval-cur-env (aggregated-variable (as-string language) "xml-preformatted-text-elements")))
(define xml-error-truncation-length 130)
(define (xml-pass-default-dtd-attributes-in? language)
(assert-known-xml-language language "xml-pass-default-dtd-attributes-in?")
(eval-cur-env (aggregated-variable (as-string language) "xml-pass-default-dtd-attributes?")))
(define (xml-accept-only-string-valued-attributes-in? language)
(if language
(begin
(assert-known-xml-language language "xml-accept-only-string-valued-attributes-in?")
(eval-cur-env (aggregated-variable (as-string language) "xml-accept-only-string-valued-attributes?"))
)
#t))
(define (set-xml-accept-only-string-valued-attributes-in language new-value)
(assert-known-xml-language language "set-xml-accept-only-string-valued-attributes-in")
(eval-cur-env (list 'set! (aggregated-variable (as-string language) "xml-accept-only-string-valued-attributes?") new-value)))
(define (xml-accept-extended-contents-in? language)
(if language
(begin
(assert-known-xml-language language "xml-accept-extended-contents-in?")
(eval-cur-env (aggregated-variable (as-string language) "xml-accept-extended-contents?"))
)
#f))
(define (set-xml-accept-extended-contents-in language new-value)
(assert-known-xml-language language "set-xml-accept-extended-contents-in")
(eval-cur-env (list 'set! (aggregated-variable (as-string language) "xml-accept-extended-contents?") new-value)))
(define (xml-document-type-declaration-in language)
(if language
(begin
(assert-known-xml-language language "xml-document-type-declaration-in")
(eval-cur-env (aggregated-variable (as-string language) "xml-document-type-declaration")))
""))
(define (xml-represent-white-space-in? language)
(if language
(begin
(assert-known-xml-language language "xml-represent-white-space-in?")
(eval-cur-env (aggregated-variable (as-string language) "xml-represent-white-space?"))
)
#t))
(define (xml-duplicated-attribute-handling language)
(if language
(begin
(assert-known-xml-language language "xml-duplicated-attribute-handling")
(eval-cur-env (aggregated-variable (as-string language) "xml-duplicated-attribute-handling"))
)
'keep-all))
(define (aggregated-variable language-string variable-string)
(as-symbol (string-append language-string "-" variable-string)))
(define (assert-known-xml-language language . optional-parameter-list)
(let ((context (optional-parameter 1 optional-parameter-list #f)))
(if (not (symbol? language))
(laml-error (if context (string-append (as-string context) ":") "") "The XML-in-LAML language must be given as a symbol:" language))
(if (not (memq language (languages-in-use)))
(laml-error (if context (string-append (as-string context) ":" (as-string #\newline)) "")
"The language" language
"is not among the currently loaded XML-in-LAML languages:"
(list-to-string (map as-string (languages-in-use)) ", ")))))
(define xml-link-checking-map '())
(define (set-xml-link-checking-functions xml-language url-extractor-function base-url-extractor-function)
(set! xml-link-checking-map
(cons (cons xml-language (list url-extractor-function base-url-extractor-function))
xml-link-checking-map)))
(define (url-extractor-of-xml-language xml-language)
(let ((res (assq xml-language xml-link-checking-map)))
(if res
(first (cdr res))
#f)))
(define (base-url-extractor-of-xml-language xml-language)
(let ((res (assq xml-language xml-link-checking-map)))
(if res
(second (cdr res))
#f)))
(define explicit-space #t)
(define explicit-space-suppress #f)
(define _ explicit-space-suppress)
(define preferred-maximum-width 90)
(define indentation-delta 3)
(define xml-always-render-white-space? #f)
(define (laml-make-ast element-name contents attributes kind language . optional-parameter-list)
(let ((internal-attributes (optional-parameter 1 optional-parameter-list '()))
(subtrees (cond ((ast? contents) (list contents))
((cdata? contents) (list contents))
((forced-white-space? contents) (list contents))
((delayed-procedural-contents-element? contents) (list contents))
((char-ref? contents) (list contents))
((xml-comment? contents) (list contents))
((cdata-section? contents) (list contents))
((processing-instruction? contents) (list contents))
((list? contents) contents)
(else (laml-error "make-ast: Contents must be a single content item or a list of these: "
(as-string contents))))))
(list 'ast (as-string element-name) subtrees attributes (as-symbol kind) (as-symbol language) internal-attributes)))
(define laml-ast-element-name (make-selector-function 2 "ast-element-name"))
(define laml-ast-subtrees (make-selector-function 3 "ast-subtrees"))
(define laml-ast-attributes (make-selector-function 4 "ast-attributes"))
(define laml-ast-kind (make-selector-function 5 "ast-kind"))
(define laml-ast-language (make-selector-function 6 "ast-language"))
(define laml-ast-internal-attributes (make-selector-function 7 "ast-internal-attributes"))
(define (sxml-make-ast element-name contents attributes-proplist kind language . optional-parameter-list)
(let ((internal-attributes (optional-parameter 1 optional-parameter-list '()))
(subtrees (cond ((ast? contents) (list contents))
((cdata? contents) (list contents))
((forced-white-space? contents) (list contents))
((delayed-procedural-contents-element? contents) (list contents))
((char-ref? contents) (list contents))
((xml-comment? contents) (list contents))
((cdata-section? contents) (list contents))
((processing-instruction? contents) (list contents))
((list? contents) contents)
(else (laml-error "make-ast: Contents must be ast, cdata, forced white space, or a list of these: "
(as-string contents))))))
(cons (as-symbol element-name)
(cons (sxml-attributes attributes-proplist)
(cons (sxml-aux-list kind language)
subtrees)))))
(define (sxml-attributes attributes-proplist)
(let ((attributes-alist (propertylist-to-alist attributes-proplist)))
(cons '@
(map
(lambda (aname-aval-pair) (list (as-symbol (car aname-aval-pair)) (as-string (cdr aname-aval-pair))))
attributes-alist))))
(define (sxml-aux-list kind language)
(cons '@@
(cons (list '*NAMESPACES*)
(cons (list 'element-kind kind)
(cons (list 'language language) '())))))
(define sxml-ast-element-name (compose as-string car))
(define (sxml-ast-subtrees ast)
(cond ((null? (cdr ast))
'())
((not (sxml-attribute-or-aux-related? (cadr ast)))
(cdr ast))
((null? (cddr ast))
'())
((not (sxml-attribute-or-aux-related? (caddr ast)))
(cddr ast))
(else (cdddr ast))))
(define (sxml-attribute-or-aux-related? x)
(or (sxml-attribute-related? x) (sxml-aux-related? x)))
(define (sxml-attribute-related? x)
(and (pair? x) (eq? (car x) '@)))
(define (sxml-aux-related? x)
(and (pair? x) (eq? (car x) '@@)))
(define (sxml-ast-attributes ast)
(if (null? (cdr ast))
'()
(if (sxml-attribute-related? (cadr ast))
(let ((attribute-pair-list (cdr (cadr ast))))
(flatten attribute-pair-list))
'())))
(define (sxml-ast-kind ast)
(let* ((aux-constituent (sxml-aux-constituent-of-ast ast)))
(if aux-constituent
(let ((candidate (defaulted-get 'element-kind (cdr aux-constituent) #f)))
(if candidate
(car candidate)
(let* ((aux-language (defaulted-get 'language (cdr aux-constituent) #f))
(language (if aux-language aux-language (ast-language ast)))
)
(if language
(let ((content-model (content-model-of (ast-element-name ast) language)))
(if (eq? content-model 'empty) 'single 'double))
'double))))
(let ((language (ast-language ast)))
(if language
(let ((content-model (content-model-of (ast-element-name ast) language)))
(if (eq? content-model 'empty) 'single 'double))
'double)))))
(define (sxml-ast-language ast)
(let* ((default-language (last (languages-in-use)))
(aux-constituent (sxml-aux-constituent-of-ast ast))
)
(if aux-constituent
(let ((candidate (defaulted-get 'language (cdr aux-constituent) #f)))
(if candidate
(car candidate)
default-language
))
default-language)))
(define (sxml-ast-internal-attributes ast)
(laml-error "sxml-ast-internal-attributes: Not yet supported"))
(define (sxml-aux-constituent-of-ast ast)
(cond ((null? (cdr ast))
#f)
((sxml-aux-related? (cadr ast))
(cadr ast))
((null? (cddr ast))
#f)
((sxml-aux-related? (caddr ast))
(caddr ast))
(else #f)))
(define check-ast-constituents? #f)
(define make-ast
(cond ((eq? laml-internal-representation 'laml) laml-make-ast)
((eq? laml-internal-representation 'sxml) sxml-make-ast)
(else (laml-error "make-ast: Unknown value of laml-internal-representation:" laml-internal-representation))))
(define ast-element-name
(cond ((eq? laml-internal-representation 'laml) laml-ast-element-name)
((eq? laml-internal-representation 'sxml) sxml-ast-element-name)
(else (laml-error "ast-element-name: Unknown value of laml-internal-representation:" laml-internal-representation))))
(define ast-subtrees
(cond ((eq? laml-internal-representation 'laml) laml-ast-subtrees )
((eq? laml-internal-representation 'sxml) sxml-ast-subtrees )
(else (laml-error "ast-subtrees : Unknown value of laml-internal-representation:" laml-internal-representation))))
(define ast-attributes
(cond ((eq? laml-internal-representation 'laml) laml-ast-attributes)
((eq? laml-internal-representation 'sxml) sxml-ast-attributes)
(else (laml-error "ast-attributes : Unknown value of laml-internal-representation:" laml-internal-representation))))
(define ast-kind
(cond ((eq? laml-internal-representation 'laml) laml-ast-kind)
((eq? laml-internal-representation 'sxml) sxml-ast-kind)
(else (laml-error "ast-kind : Unknown value of laml-internal-representation:" laml-internal-representation))))
(define ast-language
(cond ((eq? laml-internal-representation 'laml) laml-ast-language)
((eq? laml-internal-representation 'sxml) sxml-ast-language)
(else (laml-error "ast-language : Unknown value of laml-internal-representation:" laml-internal-representation))))
(define ast-internal-attributes
(cond ((eq? laml-internal-representation 'laml) laml-ast-internal-attributes)
((eq? laml-internal-representation 'sxml) sxml-ast-internal-attributes)
(else (laml-error "ast-internal-attributes : Unknown value of laml-internal-representation:" laml-internal-representation))))
(define (ast-subtree ast el-name . optional-parameter-list)
(let ((n (optional-parameter 1 optional-parameter-list 1))
(subtrees (ast-subtrees ast)))
(sub-ast-1 subtrees (as-string el-name) n)))
(define (sub-ast-1 subtree-list el-name n)
(cond ((null? subtree-list) #f)
((and (and (ast? (car subtree-list)) (equal? el-name (ast-element-name (car subtree-list)))) (= n 1))
(car subtree-list))
((and (and (ast? (car subtree-list)) (equal? el-name (ast-element-name (car subtree-list)))) (> n 1))
(sub-ast-1 (cdr subtree-list) el-name (- n 1)))
(else (sub-ast-1 (cdr subtree-list) el-name n))))
(define (ast-attribute ast name . optional-parameter-list)
(let ((default-attribute-value (optional-parameter 1 optional-parameter-list #f)))
(defaulted-get-prop name (ast-attributes ast) default-attribute-value)))
(define (attribute-getter attribute-name . optional-parameter-list)
(let ((default-value (optional-parameter 1 optional-parameter-list #f)))
(if default-value
(lambda (ast)
(let ((attribute-plist (ast-attributes ast)))
(defaulted-get-prop attribute-name attribute-plist default-value)))
(lambda (ast)
(let ((attribute-plist (ast-attributes ast)))
(get-prop attribute-name attribute-plist))))))
(define (aggregated-ast-cdata-contents ast)
(aggregated-ast-cdata-contents-1 (ast-subtrees ast) ""))
(define (aggregated-ast-cdata-contents-1 contents-list res)
(cond ((null? contents-list) res)
((cdata? (car contents-list))
(aggregated-ast-cdata-contents-1 (cdr contents-list) (string-append res (car contents-list))))
((forced-white-space? (car contents-list)) (aggregated-ast-cdata-contents-1 (cdr contents-list) (string-append res " ")))
(else (aggregated-ast-cdata-contents-1 (cdr contents-list) res))))
(define (aggregated-ast-cdata-contents-deep ast)
(aggregated-ast-cdata-contents-deep-1 (ast-subtrees ast) ""))
(define (aggregated-ast-cdata-contents-deep-1 contents-list res)
(cond ((null? contents-list) res)
((cdata? (car contents-list))
(aggregated-ast-cdata-contents-deep-1 (cdr contents-list) (string-append res (car contents-list))))
((forced-white-space? (car contents-list)) (aggregated-ast-cdata-contents-deep-1 (cdr contents-list) (string-append res " ")))
((ast? (car contents-list))
(aggregated-ast-cdata-contents-deep-1 (cdr contents-list) (string-append res (aggregated-ast-cdata-contents-deep (car contents-list)))))
(else (aggregated-ast-cdata-contents-deep-1 (cdr contents-list) res))))
(define ast-text aggregated-ast-cdata-contents)
(define ast-text-deep aggregated-ast-cdata-contents-deep)
(define (ast-internal-attribute ast name . optional-parameter-list)
(let ((default-attribute-value (optional-parameter 1 optional-parameter-list #f)))
(defaulted-get-prop name (ast-internal-attributes ast) default-attribute-value)))
(define (has-internal-ast-attribute? ast name)
(let ((internal-attr-list (ast-internal-attributes ast)))
(turn-into-boolean (find-in-property-list name internal-attr-list))))
(define (set-internal-ast-attributes! ast prop-list)
(set-car! (list-tail ast 6) prop-list))
(define (set-internal-ast-attribute! ast name value)
(let* ((internal-attr-list (ast-internal-attributes ast))
(p-list-section (find-in-property-list name internal-attr-list))
)
(if p-list-section
(set-car! (cdr p-list-section) value)
(set-internal-ast-attributes! ast (cons name (cons value internal-attr-list))))))
(define (remove-internal-ast-attribute! ast name)
(let* ((internal-attr-list (ast-internal-attributes ast)))
(set-internal-ast-attributes! ast
(remove-prop! name internal-attr-list))))
(define (laml-ast? x)
(and (pair? x) (eq? (car x) 'ast)
(list? x) (= 7 (length x))))
(define (sxml-ast? x)
(and (pair? x) (symbol? (car x))))
(define (sxml-ast-strong? x)
(and (list? x) (>= (length x) 3)
(symbol? (first x))
(list? (second x)) (eq? (car (second x)) '@)
(list? (third x)) (eq? (car (third x)) '@@)))
(define ast?
(cond ((eq? laml-internal-representation 'laml) laml-ast?)
((eq? laml-internal-representation 'sxml) sxml-ast?)
(else (laml-error "ast?: Unknown value of laml-internal-representation:" laml-internal-representation))))
(define ast-strong?
(cond ((eq? laml-internal-representation 'laml) laml-ast?)
((eq? laml-internal-representation 'sxml) sxml-ast-strong?)
(else (laml-error "ast-strong?: Unknown value of laml-internal-representation:" laml-internal-representation))))
(define cdata? string?)
(define (contents-data? x . optional-parameter-list)
(let ((language (optional-parameter 1 optional-parameter-list #f)))
(if language
(if (xml-accept-extended-contents-in? language)
(or (cdata? x) (ast? x) (char-ref? x) (cdata-section? x) (extended-contents-data? x))
(or (cdata? x) (ast? x) (char-ref? x) (cdata-section? x)))
(or (cdata? x) (ast? x) (char-ref? x) (cdata-section? x)))))
(define (contents-data-strong? x . optional-parameter-list)
(let ((language (optional-parameter 1 optional-parameter-list #f)))
(if language
(if (xml-accept-extended-contents-in? language)
(or (cdata? x) (ast-strong? x) (char-ref? x) (cdata-section? x) (extended-contents-data? x))
(or (cdata? x) (ast-strong? x) (char-ref? x) (cdata-section? x)))
(or (cdata? x) (ast-strong? x) (char-ref? x) (cdata-section? x)))))
(define (extended-contents-data? x)
(or (number? x) (char? x)))
(define (delayed-procedural-contents-element? x)
(procedure? x))
(define (char-ref? x)
(and (list? x) (>= (length x) 2) (eq? (car x) 'char-ref) (or (number? (cadr x)) (symbol? (cadr x)))))
(define (forced-white-space? x)
(eq? x explicit-space))
(define (white-space-suppress? x)
(eq? x explicit-space-suppress))
(define (white-space-related? x)
(or (eq? x explicit-space) (eq? x explicit-space-suppress)))
(define (terminal-ast-node? x)
(and (ast? x)
(null? (ast-subtrees x))))
(define (xml-comment? x)
(and (list? x) (>= (length x) 1) (eq? (car x) 'xml-comment)))
(define (cdata-section? x)
(and (list? x) (>= (length x) 1) (eq? (car x) 'cdata-section)))
(define (processing-instruction? x)
(and (list? x) (>= (length x) 1) (eq? (car x) 'processing-instruction)))
(define (ast-of-type? type name)
(cond ((eq? type 'element-name)
(lambda (ast)
(and (ast? ast) (equal? (as-string (ast-element-name ast)) (as-string name)))))
((eq? type 'kind)
(lambda (ast)
(and (ast? ast) (equal? (as-string (ast-kind ast)) (as-string name)))))
((eq? type 'language)
(lambda (ast)
(and (ast? ast) (equal? (as-string (ast-language ast)) (as-string name)))))
(else
(laml-error "ast-of-type?: Unknown first parameter (type): " type))))
(define (char-ref x)
(list 'char-ref
(cond ((number? x) x)
((string? x) (as-symbol x))
((symbol? x) x)
(else (laml-error "char-ref: Invalid parameter:" x)))))
(define (char-ref-value char-ref-structure)
(cadr char-ref-structure))
(define (xml-render-char-ref char-ref)
(if (not (char-ref? char-ref)) (laml-error "xml-render-char-ref: XML rendering non char-ref:" char-ref))
(letrec ((char-ref-render
(lambda (x)
(cond ((number? x) (string-append "&#" (as-string x) ";"))
((symbol? x) (string-append "&" (as-string x) ";"))
(else (laml-error "xml-render-char-ref: the parameter must be numeric, a symbol, or a string" x)))))
(three-digit-string
(lambda (n)
(cond ((and (>= n 0) (< n 10)) (string-append "00" (as-string n)))
((and (>= n 10) (< n 100)) (string-append "0" (as-string n)))
((< n 1000) (as-string n))
(else (error "three-digit-string: parameter must be between 0 and 999")))))
)
(char-ref-render (char-ref-value char-ref))))
(define (xml-comment . comment-text-list)
(list 'xml-comment (map as-string comment-text-list)))
(define (xml-comment-contents xml-comment)
(cadr xml-comment))
(define (xml-render-xml-comment xml-comment)
(string-append "<!--" (list-to-string (xml-comment-contents xml-comment) " ") "-->"))
(define (cdata-section . cdata-text-list)
(list 'cdata-section (map as-string cdata-text-list)))
(define (cdata-section-contents cdata-section)
(cadr cdata-section))
(define (xml-render-cdata-section cdata-section)
(string-append "<![CDATA[" (list-to-string (cdata-section-contents cdata-section) " ") "]]>"))
(define (processing-instruction pi-target . text-list)
(list 'processing-instruction (as-string pi-target) (map as-string text-list)))
(define (processing-instruction-target pi)
(cadr pi))
(define (processing-instruction-contents pi)
(caddr pi))
(define (xml-render-processing-instruction pi)
(string-append "<?" (processing-instruction-target pi) " " (list-to-string (processing-instruction-contents pi) " ") "?>"))
(define xml-in-laml-name-clashes '())
(define (register-xml-in-laml-language language language-map)
(set! xml-in-laml-name-clashes (precompute-name-clashes language-map xml-in-laml-name-clashes))
(if (not (memq language (languages-in-use)))
(set! xml-in-laml-languages-in-use (cons (cons language language-map) xml-in-laml-languages-in-use)))
)
(define (precompute-name-clashes new-language-map existing-name-clashes)
(let* ((all-existing-names (flatten (map element-names-of-language (languages-in-use))))
(new-names (map car new-language-map))
(intersection (list-intersection-by-predicate new-names all-existing-names eq?))
)
(remove-duplicates-by-predicate (append existing-name-clashes intersection) eq?)))
(define (language-map-of language)
(defaulted-get language xml-in-laml-languages-in-use #f))
(define (language-in-use? language)
(let ((lg-map (defaulted-get language xml-in-laml-languages-in-use #f)))
(if lg-map #t #f)))
(define (languages-in-use)
(map car xml-in-laml-languages-in-use))
(define (element-names-of-language language)
(let ((lg-map (defaulted-get language xml-in-laml-languages-in-use '())))
(map car lg-map)))
(define (causes-xml-in-laml-name-clash? name)
(memq name xml-in-laml-name-clashes))
(define (activator-via-language-map language)
(lambda (element-name)
(let ((lg-map (language-map-of language)))
(get-mirror-function lg-map element-name))))
(define the-name-binding-stack '())
(define (push-name-bindings name-list)
(let ((name-fu-map (map (lambda (n) (cons n (eval-cur-env n))) name-list)))
(set! the-name-binding-stack (cons name-fu-map the-name-binding-stack))))
(define (pop-and-restore-name-bindings)
(let ((name-fu-map (car the-name-binding-stack)))
(set! the-name-binding-stack (cdr the-name-binding-stack))
(for-each
(lambda (name-fu-pair)
(if (procedure? (cdr name-fu-pair))
(eval-cur-env `(set! ,(car name-fu-pair) ,(cdr name-fu-pair)))
(eval-cur-env `(set! ,(car name-fu-pair) (quote ,(cdr name-fu-pair)))))
)
name-fu-map)))
(define (establish-xml-in-laml-name-bindings xml-element-variable-list xml-language)
(let ((lang-map (language-map-of xml-language)))
(for-each
(lambda (xml-element-name)
(eval-cur-env `(set! ,xml-element-name ,(get-mirror-function lang-map xml-element-name)))
)
xml-element-variable-list)))
(define-syntax with-xml-language
(syntax-rules ()
((with-xml-language xml-language-name form ...)
(let ((name-clashes xml-in-laml-name-clashes))
(push-name-bindings (append (list 'xml-id-attribute-list 'xml-idref-attribute-list) name-clashes))
(establish-xml-in-laml-name-bindings name-clashes xml-language-name)
(set! xml-id-attribute-list '()) (set! xml-idref-attribute-list '())
(let ((result (begin form ...)))
(check-id-and-idref-attributes!)
(pop-and-restore-name-bindings)
result)))))
(define-syntax with-xml-language!
(syntax-rules ()
((with-xml-language! xml-language-name minus-elements form ...)
(let ((name-clashes (list-difference (element-names-of-language xml-language-name) minus-elements)))
(push-name-bindings (append (list 'xml-id-attribute-list 'xml-idref-attribute-list) name-clashes))
(establish-xml-in-laml-name-bindings name-clashes xml-language-name)
(set! xml-id-attribute-list '()) (set! xml-idref-attribute-list '())
(let ((result (begin form ...)))
(check-id-and-idref-attributes!)
(pop-and-restore-name-bindings)
result)))))
(define temp-language-map '())
(define temp-mirror-function #f)
(define (get-mirror-function language-map element-name)
(let ((element-name-symbol (as-symbol element-name)))
(defaulted-get element-name-symbol language-map #f)))
(define (put-mirror-function language-map element-name mirror-function)
(let ((element-name-symbol (as-symbol element-name)))
(if (get-mirror-function language-map element-name-symbol)
(laml-error "put-mirror-function: The name" element-name "is defined twice.")
(cons (cons element-name-symbol mirror-function) language-map))))
(define (register-xml-in-laml-navigator language navigator-structure)
(set! xml-in-laml-navigator-structures (cons (cons language navigator-structure) xml-in-laml-navigator-structures))
)
(define (xml-navigator-of language)
(defaulted-get language xml-in-laml-navigator-structures #f))
(define (xml-navigator? x)
(and (list? x) (= (length x) 2) (eq? (car x) 'xml-navigator)))
(define (xml-navigator-vector xml-navigator)
(cadr xml-navigator))
(define navigator-triple-element-name (make-selector-function 1 "navigator-triple-element-name"))
(define navigator-triple-possible-element-vector (make-selector-function 2 "navigator-triple-possible-element-vector"))
(define navigator-triple-possible-attribute-vector (make-selector-function 3 "navigator-triple-possible-attribute-vector"))
(define (possible-elements-rooted-by-element element-name language)
(let* ((nav-vector (xml-navigator-vector (xml-navigator-of language)))
(relevant-tripple
(binary-search-in-vector nav-vector (as-symbol element-name) navigator-triple-element-name eq? symbol-leq?))
)
(if relevant-tripple
(let ((element-vector (navigator-triple-possible-element-vector relevant-tripple)))
(vector->list element-vector))
(laml-error "possible-elements-rooted-by-element: Cannot locate" element-name "in" language))))
(define (possible-attributes-rooted-by-element element-name language)
(let* ((nav-vector (xml-navigator-vector (xml-navigator-of language)))
(relevant-tripple
(binary-search-in-vector nav-vector (as-symbol element-name) navigator-triple-element-name eq? symbol-leq?))
)
(if relevant-tripple
(let ((attribute-vector (navigator-triple-possible-attribute-vector relevant-tripple)))
(vector->list attribute-vector))
(laml-error "possible-attributes-rooted-by-element: Cannot locate" element-name "in" language))))
(define (can-have-element-constituent? ast el-name)
(can-have-element-constituent-help (ast-element-name ast) el-name (xml-navigator-of (ast-language ast))))
(define (can-have-element-constituent-help in-element-name el-name xml-navigator)
(let* ((nav-vector (xml-navigator-vector xml-navigator))
(relevant-tripple
(binary-search-in-vector nav-vector (as-symbol in-element-name) navigator-triple-element-name eq? symbol-leq?))
)
(if relevant-tripple
(let ((element-vector (navigator-triple-possible-element-vector relevant-tripple)))
(turn-into-boolean (binary-search-in-vector element-vector (as-symbol el-name) id-1 eq? symbol-leq?)))
#f)))
(define (symbol-leq? sym1 sym2)
(string<=? (symbol->string sym1) (symbol->string sym2)))
(define (xml-sort-tag-parameters parameters tag-name . optional-parameter-list)
(let ((language (optional-parameter 1 optional-parameter-list #f)))
(xml-sort-tag-parameters-1 parameters parameters '() '() tag-name language #f)))
(define (xml-sort-tag-parameters-1 original-parameters parameters contents attributes tag-name language superficial?)
(letrec ((strip-initial-explicit-spaces
(lambda (cl) (if (and (pair? cl) (eq? (car cl) explicit-space)) (strip-initial-explicit-spaces (cdr cl)) cl)))
(list-non-ast? (lambda (x) (and (list? x) (not (ast-strong? x)))))
(maybe-string (lambda (x) (if (extended-contents-data? x) (as-string x) x)))
(as-string-attr-val (lambda (x)
(cond ((char-ref? x) (xml-render-char-ref x))
(else (as-string x)))))
)
(let ((white-space? (xml-represent-white-space-in? language)))
(cond
((null? parameters)
(cons
(reverse (strip-initial-explicit-spaces contents))
(xml-modify-attribute-list (reverse attributes) (xml-duplicated-attribute-handling language))
)
)
((and (x-contents-data-strong? (car parameters) language) (not (null? (cdr parameters)))
(white-space-related? (cadr parameters)) (white-space-suppress? (cadr parameters)))
(xml-sort-tag-parameters-1 original-parameters (cddr parameters)
(if white-space?
(if superficial? (cons explicit-space-suppress (cons (maybe-string (car parameters)) contents)) (cons (maybe-string (car parameters)) contents))
(cons (maybe-string (car parameters)) contents))
attributes tag-name language superficial?))
((and (x-contents-data-strong? (car parameters) language) (not (null? (cdr parameters)))
(white-space-related? (cadr parameters)) (forced-white-space? (cadr parameters)))
(xml-sort-tag-parameters-1 original-parameters
(cddr parameters) (if white-space? (cons explicit-space (cons (maybe-string (car parameters)) contents)) (cons (maybe-string (car parameters)) contents))
attributes tag-name language superficial?))
((x-contents-data-strong? (car parameters) language)
(xml-sort-tag-parameters-1 original-parameters
(cdr parameters) (if white-space? (cons explicit-space (cons (maybe-string (car parameters)) contents)) (cons (maybe-string (car parameters)) contents))
attributes tag-name language superficial?))
((and (list-non-ast? (car parameters)) (not (null? (cdr parameters))) (white-space-related? (cadr parameters)) (white-space-suppress? (cadr parameters)))
(let* ((rec-res (xml-sort-tag-parameters-1 original-parameters (car parameters) '() '() tag-name language superficial?))
(rec-contents (car rec-res))
(rec-attributes (cdr rec-res))
)
(xml-sort-tag-parameters-1 original-parameters
(cddr parameters)
(append (if (and white-space? superficial?) (list explicit-space-suppress) '()) (reverse rec-contents) contents)
(append (reverse rec-attributes) attributes) tag-name language superficial?)))
((and (list-non-ast? (car parameters)) (not (null? (cdr parameters))) (white-space-related? (cadr parameters)) (forced-white-space? (cadr parameters)))
(let* ((rec-res (xml-sort-tag-parameters-1 original-parameters (car parameters) '() '() tag-name language superficial?))
(rec-contents (car rec-res))
(rec-attributes (cdr rec-res))
)
(xml-sort-tag-parameters-1 original-parameters
(cddr parameters)
(append (if white-space? (list explicit-space) '()) (reverse rec-contents) contents)
(append (reverse rec-attributes) attributes) tag-name language superficial?)))
((and (list-non-ast? (car parameters)))
(let* ((rec-res (xml-sort-tag-parameters-1 original-parameters (car parameters) '() '() tag-name language superficial?))
(rec-contents (car rec-res))
(rec-attributes (cdr rec-res))
)
(xml-sort-tag-parameters-1 original-parameters
(cdr parameters)
(append (if (and white-space? (not (null? rec-contents))) (list explicit-space) '())
(reverse rec-contents)
contents)
(append (reverse rec-attributes) attributes) tag-name language superficial?)))
((and (symbol? (car parameters)) (not (null? (cdr parameters))) (not (white-space-related? (cadr parameters))))
(let ((attr-name (car parameters))
(attr-val (cadr parameters)))
(if (and (xml-accept-only-string-valued-attributes-in? language) (not (string? attr-val)))
(cond ((ast-strong? attr-val)
(xml-check-error "An element content item of type " (ast-element-name attr-val) " is passed as the value of the attribute" (as-string #\newline)
" " (as-string attr-name) " in an instance of the " tag-name " element. " (as-string #\newline)
" " "The attribute is ignored."))
(else
(let* ((extended-attributes? (not (xml-accept-only-string-valued-attributes-in? language)))
(hint (if (not extended-attributes?)
(string-append (as-string #\newline) " You may consider use of relaxed attributes:" (as-string #\newline)
" " "(set-xml-accept-only-string-valued-attributes-in "
"'" (as-string language) " #f" ")")
""))
)
(xml-check-error "A non-string value " (as-string attr-val) " is passed as the value of the attribute" (as-string #\newline)
" " (as-string attr-name) " in an instance of the " tag-name " element." (as-string #\newline)
" " "The attribute value is converted to a string." hint))))
(cond ((ast-strong? attr-val)
(xml-check-error "An element content item of type " (ast-element-name attr-val) " is passed as the value of the attribute" (as-string #\newline)
" " (as-string attr-name) " in an instance of the " tag-name " element. " (as-string #\newline) " " "The attribute is ignored."))
(else
#f))
)
(xml-sort-tag-parameters-1 original-parameters (cddr parameters) contents
(if (not (ast-strong? attr-val)) (cons (as-string-attr-val attr-val) (cons attr-name attributes)) attributes)
tag-name language superficial?)))
((white-space-related? (car parameters))
(xml-sort-tag-parameters-1 original-parameters (cdr parameters) contents attributes tag-name language superficial?))
((symbol? (car parameters)) (xml-sort-error
(string-append "Fatal error in an XML-in-LAML element: " "Attributes of the " tag-name
" element must be of the form 'symbol \"value\" " (as-string #\newline) " "
"Only the symbol " (as-string (car parameters))
" appears in last encountered attribute." ) (xml-render-error-message original-parameters)))
(else
(let* ((extended-contents (xml-accept-extended-contents-in? language))
(hint (if (not extended-contents)
(string-append (as-string #\newline) "You may consider use of extended contents: (set-xml-accept-extended-contents-in " "'" (as-string language) " #t" ")")
""))
)
(xml-sort-error (string-append "Fatal error in an XML-in-LAML " tag-name " element." hint) (xml-render-error-message original-parameters)))
)
))))
(define (x-contents-data-strong? x . optional-parameter-list)
(let ((language (optional-parameter 1 optional-parameter-list #f)))
(if language
(or (contents-data-strong? x language)
(xml-comment? x)
(processing-instruction? x)
(delayed-procedural-contents-element? x)
)
(or (contents-data-strong? x)
(xml-comment? x)
(processing-instruction? x)
(delayed-procedural-contents-element? x)
))))
(define (xml-modify-attribute-list attribute-prop-list kind)
(cond ((eq? kind 'keep-all) attribute-prop-list)
((eq? kind 'keep-first) (remove-duplicate-properties-keep-first attribute-prop-list))
((eq? kind 'keep-last) (remove-duplicate-properties-keep-last attribute-prop-list))
(else (laml-error "xml-modify-attribute-list: Unknown kind of attribute modification" kind))))
(define (remove-duplicate-properties-keep-first proplist)
(letrec ((remove-duplicate-properties-keep-first-help
(lambda (proplist seen-keys)
(cond ((null? proplist) '())
((memq (car proplist) seen-keys) (remove-duplicate-properties-keep-first-help (cddr proplist) seen-keys))
(else (cons (car proplist) (cons (cadr proplist)
(remove-duplicate-properties-keep-first-help (cddr proplist) (cons (car proplist) seen-keys)))))))))
(remove-duplicate-properties-keep-first-help proplist '())))
(define (remove-duplicate-properties-keep-last proplist)
(letrec ((memq-prop-list
(lambda (prop proplist)
(if (null? proplist)
#f
(or (eq? (car proplist) prop) (memq-prop-list prop (cdr proplist))))))
(remove-duplicate-properties-keep-last-help
(lambda (proplist)
(cond ((null? proplist) '())
((memq-prop-list (car proplist) (cddr proplist))
(remove-duplicate-properties-keep-last-help (cddr proplist)))
(else (cons (car proplist) (cons (cadr proplist)
(remove-duplicate-properties-keep-last-help (cddr proplist))))))))
)
(remove-duplicate-properties-keep-last-help proplist)))
(define (xml-sort-superficially-tag-parameters parameters tag-name . optional-parameter-list)
(let ((language (optional-parameter 1 optional-parameter-list #f)))
(xml-sort-tag-parameters-1 parameters parameters '() '() tag-name language #t)
))
(define (xml-sort-error message parameters)
(let* ((max-str-lgt xml-error-truncation-length)
(parameters-2 (if (> (string-length parameters) max-str-lgt)
(string-append (substring parameters 0 (- max-str-lgt 1)) "...")
parameters)))
(laml-error
"***" message (as-string #\newline)
" The list of parameters: " parameters-2 (as-string #\newline))))
(define (laml-source-prepare laml-lst)
(cond ((null? laml-lst) laml-lst)
((and (white-space-related? (car laml-lst)) (forced-white-space? (car laml-lst)))
(laml-source-prepare (cdr laml-lst)))
((and (not (null? (cdr laml-lst))) (not (white-space-related? (car laml-lst))) (not (white-space-related? (cadr laml-lst))))
(cons (car laml-lst) (cons explicit-space-suppress (laml-source-prepare (cons (cadr laml-lst) (cddr laml-lst))))))
(else (cons (car laml-lst) (laml-source-prepare (cdr laml-lst))))))
(define (generate-xml-mirror-function validation-procedure tag-name default-dtd-attributes single-double-kind language overlap-check? action-procedure)
(cond ((eq? single-double-kind 'double)
(lambda parameters
(let* ((contents-attributes (xml-sort-tag-parameters parameters tag-name language))
(contents (car contents-attributes))
(attributes (if (xml-pass-default-dtd-attributes-in? language)
(append (cdr contents-attributes) default-dtd-attributes)
(cdr contents-attributes)))
(split-attributes (split-xml-and-internal-attributes attributes))
(xml-attributes (car split-attributes))
(internal-attributes (cdr split-attributes))
)
(if (not (has-procedural-content-items? contents)) (validation-procedure tag-name xml-attributes contents overlap-check?))
(if action-procedure
(let ((real-action-procedure (cond ((boolean? action-procedure)
(action-procedure-of-language tag-name language))
((procedure? action-procedure)
action-procedure)
(else (laml-error "generate-xml-mirror-function: Invalid action procedure"))))
(the-ast (make-ast tag-name contents xml-attributes 'double language internal-attributes)))
(real-action-procedure the-ast)
the-ast)
(make-ast tag-name contents xml-attributes 'double language internal-attributes)
))))
((eq? single-double-kind 'single)
(lambda parameters
(let* ((contents-attributes (xml-sort-tag-parameters parameters tag-name language))
(contents (car contents-attributes))
(attributes (if (xml-pass-default-dtd-attributes-in? language)
(append (cdr contents-attributes) default-dtd-attributes)
(cdr contents-attributes)))
(split-attributes (split-xml-and-internal-attributes attributes))
(xml-attributes (car split-attributes))
(internal-attributes (cdr split-attributes))
)
(if (not (has-procedural-content-items? contents)) (validation-procedure tag-name xml-attributes contents overlap-check?))
(if action-procedure
(let ((real-action-procedure (cond ((boolean? action-procedure)
(action-procedure-of-language tag-name language))
((procedure? action-procedure)
action-procedure)
(else (laml-error "generate-xml-mirror-function: Invalid action procedure"))))
(the-ast (make-ast tag-name '() xml-attributes 'single language internal-attributes)))
(real-action-procedure the-ast)
the-ast)
(make-ast tag-name '() xml-attributes 'single language internal-attributes)
)
)
)
)
(else (error (string-append "generate-xml-mirror-function: unknown single-double-kind: " (as-string single-double-kind))))
)
)
(define (split-xml-and-internal-attributes prop-list)
(split-xml-and-internal-attributes-1 prop-list '() '()))
(define (split-xml-and-internal-attributes-1 prop-list prop-list-xml prop-list-internal)
(cond ((null? prop-list) (cons (reverse prop-list-xml) (reverse prop-list-internal)))
((internal-attribute-name? (car prop-list))
(split-xml-and-internal-attributes-1 (cddr prop-list) prop-list-xml (cons (cadr prop-list) (cons (drop-internal-prefix (car prop-list)) prop-list-internal))))
(else (split-xml-and-internal-attributes-1 (cddr prop-list) (cons (cadr prop-list) (cons (car prop-list) prop-list-xml)) prop-list-internal))))
(define (internal-attribute-name? attr-name)
(let ((attr-name-string (as-string attr-name)))
(and (>= (string-length attr-name-string) 9)
(equal? (substring attr-name-string 0 9) "internal:"))))
(define (drop-internal-prefix internal-attr-name)
(let* ((internal-attr-name-string (as-string internal-attr-name))
(str-lgt (string-length internal-attr-name-string)))
(as-symbol (substring internal-attr-name-string 9 str-lgt))))
(define terminator-symbol 'terminator$$)
(define textual-content-symbol 'textual-contents$$)
(define non-textual-content-symbol 'non-textual-contents$$)
(define (validate-contents-by-dfa! contents dfa tag-name)
(if (not (list? contents)) (laml-error "Contents passed to validate-contents-by-dfa! is assumed to be a list"))
(let* ((augmented-contents (xml-prepare-contents-for-validation contents))
(accepted (automaton-accepts? dfa augmented-contents)))
(if (not accepted)
(cond ((not last-automaton-input-symbol)
(xml-check-error "Empty and insufficient input to" (a-or-an tag-name) (as-string-spacy tag-name) "element." (as-string #\newline)
" " (truncate-string (xml-render-error-message contents))))
((eq? last-automaton-input-symbol terminator-symbol)
(xml-check-error "Abrupt termination of" (a-or-an tag-name) (as-string-spacy tag-name) "element:" (as-string #\newline)
" " (truncate-string (xml-render-error-message contents))))
((eq? last-automaton-input-symbol textual-content-symbol)
(let ((the-textual-contents (list-ref (filter (negate white-space-related?) contents) (max 0 (- automaton-input-number 1)))))
(xml-check-error "Textual contents" (xml-render-error-message the-textual-contents) "is illegal in" (a-or-an tag-name)
(as-string-spacy tag-name) "element:" (as-string #\newline)
" " (truncate-string (xml-render-error-message contents)))))
(else
(if (not (extraordinary-allow-element? (as-symbol last-automaton-input-symbol) (as-symbol tag-name)))
(xml-check-error "Encountered a misplaced" (as-string-spacy last-automaton-input-symbol) "element within"
(a-or-an tag-name) (as-string-spacy tag-name) "element:" (as-string #\newline)
" " (truncate-string (xml-render-error-message contents)))))))))
(define (validate-as-pcdata! contents tag-name)
(if (not (list? contents)) (laml-error "Contents passed to validate-as-pcdata! is assumed to be a list"))
(let ((res (do-validate-pcdata-contents contents)))
(cond ((or (symbol? res) (string? res))
(xml-check-error "Encountered a misplaced" (as-string-spacy res) "element in" (a-or-an tag-name)
(as-string-spacy tag-name) "element, where only textual contents is allowed." (as-string #\newline)
" " (truncate-string (xml-render-error-message contents))))
((and (boolean? res) (not res))
(xml-check-error "Unindentified problem in" (a-or-an tag-name) (as-string-spacy tag-name) "element." (as-string #\newline)
" " (truncate-string (xml-render-error-message contents)))))))
(define (do-validate-pcdata-contents contents)
(call-with-current-continuation
(lambda (exit)
(do-validate-pcdata-contents-1 contents exit))))
(define (do-validate-pcdata-contents-1 contents return)
(cond ((null? contents) #t)
(else (let ((content-item (car contents)))
(cond ((ast? content-item) (return (ast-element-name content-item)))
((cdata? content-item) #t)
((char-ref? content-item) #t)
((cdata-section? content-item) #t)
((white-space-related? content-item) #t)
(else (return #f)))
(do-validate-pcdata-contents-1 (cdr contents) return)))))
(define (validate-mixed-contents-by-simple-means! contents symbol-choice-list tag-name)
(if (not (list? contents)) (laml-error "Contents passed to validate-mixed-contents-by-simple-means! is assumed to be a list"))
(let ((res (do-validate-mixed-contents contents symbol-choice-list tag-name)))
(cond ((or (symbol? res) (string? res))
(xml-check-error "Encountered a misplaced" (as-string-spacy res) "in" (a-or-an tag-name) (as-string-spacy tag-name) "element." (as-string #\newline)
" " (truncate-string (xml-render-error-message contents))))
((and (boolean? res) (not res))
(xml-check-error "Unidentified problem in" (a-or-an tag-name) (as-string-spacy tag-name) "element." (as-string #\newline)
" " (truncate-string (xml-render-error-message contents)))))))
(define (do-validate-mixed-contents contents symbol-choice-list element-name)
(call-with-current-continuation
(lambda (exit)
(do-validate-mixed-contents-1 contents symbol-choice-list exit element-name))))
(define (do-validate-mixed-contents-1 contents symbol-choice-list return element-name)
(cond ((null? contents) #t)
(else (let ((content-item (car contents)))
(cond ((ast? content-item) (if (or (memq (as-symbol (ast-element-name content-item)) symbol-choice-list)
(extraordinary-allow-element? (as-symbol (ast-element-name content-item)) (as-symbol element-name)))
#t
(return (ast-element-name content-item))))
((cdata? content-item) #t)
((char-ref? content-item) #t)
((xml-comment? content-item) #t)
((processing-instruction? content-item) #t)
((cdata-section? content-item) #t)
((white-space-related? content-item) #t)
(else (return #f)))
(do-validate-mixed-contents-1 (cdr contents) symbol-choice-list return element-name)))))
(define (extraordinary-allow-element? element-name context-element-name)
#f)
(define (xml-prepare-contents-for-validation contents)
(append
(map (lambda (content-item)
(cond ((ast? content-item) (as-symbol (ast-element-name content-item)))
((cdata? content-item) textual-content-symbol)
((char-ref? content-item) textual-content-symbol)
((cdata-section? content-item) textual-content-symbol)
(else (laml-error "xml-prepare-contents-for-validation: Unknown element content item:" content-item))))
(filter (negate (disjunction processing-instruction? (disjunction white-space-related? xml-comment?))) contents))
(list terminator-symbol)))
(define (xml-check-for-empty-contents! contents tag-name)
(let ((filtered-contents
(filter (negate (disjunction white-space-related? (disjunction processing-instruction? xml-comment?))) contents)))
(if (not (null? filtered-contents))
(xml-check-error
(string-append "The empty element" (as-string-spacy tag-name) "is not supposed to have any content:" (as-string #\newline)
" " (xml-render-error-message filtered-contents) (as-string #\newline) " " "The element content is ignored.")))))
(define (a-or-an following-word)
(let ((following-word-1 (as-string following-word)))
(cond ((blank-string? following-word-1) "a")
((> (string-length following-word-1) 0)
(let ((first-char (string-ref following-word-1 0)))
(if (memv first-char (list #\a #\e #\i #\o #\u #\y ))
"an"
"a")))
(else "a"))))
(define (as-string-spacy x)
(string-append " " (as-string x) " "))
(define (indented-terminal-lines line-list)
(let ((sep (string-append (as-string #\newline) " ")))
(string-append sep (list-to-string line-list sep))))
(define (and-fn x y) (and x y))
(define (or-fn x y) (or x y))
(define xml-in-laml-error-message-style 'laml)
(define (xml-render-error-message contents)
(cond ((eq? xml-in-laml-error-message-style 'laml) (xml-render-as-laml contents))
((eq? xml-in-laml-error-message-style 'xml) (xml-render-as-xml contents))
(else (laml-error "xml-render-error-message" "Problem to render contents of error message"))))
(define (xml-render-as-xml contents)
(cond ((ast? contents) (xml-render contents))
((cdata? contents) contents)
((char-ref? contents) (xml-render-char-ref contents))
((cdata-section? contents) (xml-render-cdata-section contents))
((forced-white-space? contents) "")
((delayed-procedural-contents-element? contents) "#<delayed-procedural-contents-element>")
((list? contents) (list-to-string (map xml-render-as-xml contents) " "))
(else "??")))
(define (truncate-string str)
(if (> (string-length str) xml-error-truncation-length)
(string-append (substring str 0 xml-error-truncation-length) "...")
str))
(define (xml-render-as-laml contents . optional-parameter-list)
(let ((contents-after (optional-parameter 1 optional-parameter-list 'none)))
(string-append
(cond ((ast? contents) (xml-render-ast-as-laml contents))
((char-ref? contents) (xml-render-char-ref-as-laml contents))
((cdata-section? contents) (xml-render-cdata-section-as-laml contents))
((white-space-related? contents) "")
((delayed-procedural-contents-element? contents) "#<delayed-procedural-contents-element>")
((list? contents) (list-to-string (map xml-render-as-laml contents) " "))
(else (as-source-string contents)))
(if (not (white-space-related? contents))
(if (not (eq? contents-after 'none))
(cond ((eq? contents-after explicit-space) "")
(else " _"))
"")
""))))
(define (xml-render-ast-as-laml ast)
(let ((attributes (ast-attributes ast))
(the-subtrees (ast-subtrees ast))
)
(string-append
"(" (ast-element-name ast) (if (not (null? attributes)) " " "")
(xml-render-attribute-list-as-laml attributes) (if (not (null? the-subtrees)) " " "")
(let ((subtrees the-subtrees))
(string-merge (map-contextual xml-render-as-laml subtrees) (make-list (- (length subtrees) 1) " ")))
")")))
(define (map-contextual f lst)
(cond ((null? lst) '())
((null? (cdr lst)) (list (f (car lst))))
(else (cons (f (car lst) (cadr lst)) (map-contextual f (cdr lst))))))
(define (xml-render-attribute-list-as-laml attr-property-list)
(let ((lgt (length attr-property-list)))
(string-merge (map as-source-string attr-property-list) (make-list (- lgt 1) " "))))
(define (xml-render-char-ref-as-laml char-ref)
(string-append
"(" "char-ref" " "
(as-source-string (char-ref-value char-ref))
")"))
(define (xml-render-cdata-section-as-laml cdata-section)
(string-append
"(" "cdata-section" " "
(list-to-string (map as-source-string (cdata-section-contents cdata-section)) " ")
")"))
(define (as-source-string x)
(cond ((number? x) (number->string x))
((symbol? x) (string-append "'" (symbol->string x)))
((string? x) (string-it x))
((boolean? x)
(if x "#t" "#f"))
((char? x) (string-append (as-string (as-char 35)) (as-string (as-char 92)) (char->string x)))
((list? x)
(string-append "("
(string-merge (map as-source-string x) (make-list (- (length x) 1) " "))
")"))
((vector? x)
(let ((lst (vector->list x)))
(string-append "#("
(string-merge (map as-source-string lst) (make-list (- (length lst) 1) " "))
")")))
((pair? x)
(string-append "("
(apply string-append
(map (lambda (y) (string-append (as-source-string y) " ")) (proper-part x))
)
" . " (as-source-string (first-improper-part x))
")"))
((procedure? x)
"<PROCEDURE>")
(else "??")))
(define xml-id-attribute-list '())
(define xml-idref-attribute-list '())
(define att-name (make-selector-function 1))
(define att-type (make-selector-function 2))
(define att-status (make-selector-function 3))
(define (xml-check-attributes! attributes dtd-attribute-definition number-of-req-attributes tag-name)
(if (even? (length attributes))
(let ((required-attribute-names
(map (compose as-symbol att-name) (front-sublist dtd-attribute-definition number-of-req-attributes)))
(dtd-attribute-names (map (compose as-symbol car) dtd-attribute-definition))
(attribute-names (if (null? attributes) '() (every-second-element attributes)))
(attribute-values (if (null? attributes) '() (every-second-element (cdr attributes))))
)
(xml-check-required-attributes! attribute-names required-attribute-names tag-name)
(xml-check-for-attribute-existence! attribute-names dtd-attribute-names tag-name)
(xml-check-for-attribute-types! attribute-names attribute-values dtd-attribute-definition tag-name)
(xml-check-for-attribute-duplicates! attribute-names tag-name)
)))
(define (check-id-and-idref-attributes!)
(let ((id-duplicates (duplicates-by-predicate xml-id-attribute-list equal?)))
(if (not (null? id-duplicates))
(xml-check-error "The following ID attribute values are duplicated:" (list-to-string (map string-it id-duplicates) ",")))
(for-each
(lambda (idref-attr-val)
(if (not (member idref-attr-val xml-id-attribute-list))
(xml-check-error "The IDREF attribute value" (string-it idref-attr-val) "does not refer to an ID attribute."))
)
(reverse xml-idref-attribute-list))
(set! xml-id-attribute-list '())
(set! xml-idref-attribute-list '())
))
(define (xml-check-required-attributes! attribute-names required-attribute-names tag-name)
(if (not (null? required-attribute-names))
(begin
(xml-check-one-required-attribute! attribute-names (car required-attribute-names) tag-name)
(xml-check-required-attributes! attribute-names (cdr required-attribute-names) tag-name))))
(define (xml-check-one-required-attribute! attribute-names required-attribute tag-name)
(if (not (memq required-attribute attribute-names))
(xml-check-error
"The required attribute" (as-string-spacy required-attribute) "is not present in the" (as-string-spacy tag-name) "element.")))
(define (collect-links-for-later-checking-in-ast! xml-ast absolute-target-html-file)
(letrec ((url-not-deal-with?
(lambda (url-string)
(or (looking-at-substring? url-string 0 "mailto:")
(looking-at-substring? url-string 0 "file://")
(looking-at-substring? url-string 0 "ftp://")
(looking-at-substring? url-string 0 "prospero://")
(looking-at-substring? url-string 0 "wais://")
(looking-at-substring? url-string 0 "telnet://")
(looking-at-substring? url-string 0 "gopher://")
(looking-at-substring? url-string 0 "news:")))))
(let* ((xml-language (ast-language xml-ast))
(url-extractor-fn (url-extractor-of-xml-language xml-language))
(base-url-extractor-fn (base-url-extractor-of-xml-language xml-language))
(base-url (if base-url-extractor-fn (base-url-extractor-fn xml-ast) #f))
(absolute-target-html-file-path (file-name-initial-path absolute-target-html-file))
(url-list-1 (if url-extractor-fn (url-extractor-fn xml-ast) '()))
(url-list-2 (if base-url
(map
(lambda (url)
(if (relative-url? url)
(url-relative-to-base-url base-url url)
url))
url-list-1)
url-list-1))
)
(for-each
(lambda (url)
(cond ((and (boolean? url) (not url))
'do-nothing)
((url-not-deal-with? url)
'do-nothing)
((and (absolute-url? url) (memq xml-link-checking (list 'all 'absolute-urls)))
(set! absolute-url-list-for-later-checking (cons url absolute-url-list-for-later-checking)))
((and (relative-url? url) (memq xml-link-checking (list 'all 'relative-urls)))
(set! relative-url-list-for-later-checking
(cons (list url absolute-target-html-file-path) relative-url-list-for-later-checking)))
(else 'do-nothing)))
url-list-2))))
(define (url-relative-to-base-url absolute-base-url relative-url)
(cond ((anchor-part-alone? relative-url) (string-append absolute-base-url relative-url))
(else (string-append (file-name-initial-path absolute-base-url) relative-url))))
(define (anchor-part-alone? url)
(and (string? url) (> (string-length url) 0) (eqv? (string-ref url 0) #\#)))
(define (check-relative-url-list! relative-urls)
(for-each
(lambda (rel-url-entry)
(let* ((rel-url (first rel-url-entry))
(rel-url-without-anchor (eliminate-anchor-part-of-url rel-url))
(rel-url-initial-path (file-name-initial-path rel-url-without-anchor))
(rel-url-file-name-proper (file-name-proper rel-url-without-anchor))
(rel-url-extension (file-name-extension rel-url-without-anchor))
(initial-absolute-file-path (second rel-url-entry))
(normalized-absolute-file-path
(string-append
(normalize-file-path (string-append initial-absolute-file-path rel-url-initial-path))
rel-url-file-name-proper
(if (empty-string? rel-url-extension) "" (string-append "." rel-url-extension))))
)
(if (and rel-url (not (empty-string? rel-url-without-anchor))
(and (not (file-exists? normalized-absolute-file-path))
(not (directory-exists? normalized-absolute-file-path)))
)
(begin
(xml-check-error "LINKING PROBLEM: URL " rel-url " RELATIVE TO " initial-absolute-file-path)
(set! relative-url-problem-count (+ relative-url-problem-count 1))
)
)
))
relative-urls))
(define (eliminate-anchor-part-of-url url)
(let ((hash-pos (find-in-string-from-end url #\#)))
(if hash-pos
(substring url 0 hash-pos)
url)))
(define (check-absolute-url-list! absolute-urls)
(let ((unique-absolute-urls (remove-duplicates absolute-urls)))
(for-each
(lambda (abs-url)
(if (not (url-target-exists? abs-url))
(begin
(xml-check-error "LINKING PROBLEM TO " abs-url)
(set! absolute-url-problem-count (+ absolute-url-problem-count 1)))))
unique-absolute-urls)))
(define (display-xml-warning . messages)
(display (string-append "XML Warning: " (laml-aggregate-messages messages))) (newline))
(define xml-check-error display-xml-warning)
(define (xml-check-for-attribute-existence! attribute-names dtd-attribute-names tag-name)
(if (not (null? attribute-names))
(begin
(xml-check-one-attribute-existence! (car attribute-names) dtd-attribute-names tag-name)
(xml-check-for-attribute-existence! (cdr attribute-names) dtd-attribute-names tag-name))))
(define (xml-check-one-attribute-existence! name dtd-attribute-names tag-name)
(if (and (not (xml-css-key? name)) (not (memq name dtd-attribute-names)))
(xml-check-error "The XML attribute" (as-string-spacy name) "is not valid in the" (as-string-spacy tag-name) "element.")))
(define (xml-check-for-attribute-types! attribute-names attribute-values dtd-attributes tag-name)
(if (not (null? attribute-names))
(begin
(xml-check-one-attribute-type! (car attribute-names) (car attribute-values) dtd-attributes tag-name)
(xml-check-for-attribute-types! (cdr attribute-names) (cdr attribute-values) dtd-attributes tag-name))))
(define (xml-check-one-attribute-type! name value dtd-attributes tag-name)
(let ((attribute-descriptor
(find-in-list (lambda (tripple) (eq? (as-symbol (att-name tripple)) name)) dtd-attributes)))
(if attribute-descriptor
(xml-check-attribute-value! name value (att-type attribute-descriptor) tag-name))))
(define (xml-check-attribute-value! name value attribute-type tag-name)
(cond ((list? attribute-type)
(if (not (member value attribute-type))
(xml-check-error (string-append "The value " (string-it value) " of the XML attribute "
(as-string name) " is not valid in the " tag-name " element."))))
((equal? "CDATA" attribute-type)
#t)
((member attribute-type (list "ID" ))
(let ((legal-name? (is-legal-xml-name? value)))
(set! xml-id-attribute-list (cons value xml-id-attribute-list))
(if (not legal-name?)
(xml-check-error "The ID attribute value" (string-it value) "is illegal according to the XML 1.0 Name production."))))
((member attribute-type (list "IDREF"))
(let ((legal-name? (is-legal-xml-name? value)))
(set! xml-idref-attribute-list (cons value xml-idref-attribute-list))
(if (not legal-name?)
(xml-check-error "The IDREF attribute value" (string-it value) "is illegal according to the XML 1.0-spec Name production."))))
((member attribute-type (list "IDREFS"))
(let ((name-list (extract-name-list-from-names-attribute value)))
(for-each
(lambda (value)
(let ((legal-name? (is-legal-xml-name? value)))
(set! xml-idref-attribute-list (cons value xml-idref-attribute-list))
(if (not legal-name?)
(xml-check-error "The IDREFS attribute value" (string-it value) "is illegal according to the XML 1.0-spec Name production.")))
)
name-list)
))
((member attribute-type (list "ENTITY" "ENTITIES" "NMTOKEN" "NMTOKENS"))
#t)
(else (xml-check-error (string-append "DTD error!!! The type " (string-it attribute-type) " of the XML attribute "
(as-string name) " is not valid in the " tag-name " element.")))
))
(define (extract-name-list-from-names-attribute names)
(split-string-by-predicate names (lambda (ch) (memv ch white-space-char-list))))
(define (is-legal-xml-name? x)
(if (empty-string? x)
#f
(let ((first-char (string-ref x 0))
(suffix-str (substring x 1 (string-length x)))
(digits (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 ))
(letters (list #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
)
(and
(or (memv first-char letters) (eqv? first-char #\_) (eqv? first-char #\:))
(string-of-char-list? suffix-str (append letters digits (list #\. #\- #\_ #\:)))))))
(define (xml-check-for-attribute-duplicates! attribute-names tag-name)
(let ((duplicated-attribute-names (duplicates-by-predicate attribute-names eq?)))
(cond ((and (not (null? duplicated-attribute-names)) (null? (cdr duplicated-attribute-names)))
(xml-check-error
"The attribute" (as-string-spacy (car duplicated-attribute-names))
"is not allowed to appear more than once in" (a-or-an tag-name) (as-string-spacy tag-name) "element."))
((not (null? duplicated-attribute-names))
(xml-check-error
"The attributes" " " (list-to-string (map as-string duplicated-attribute-names) ", ") " "
"are not allowed to appear more than once in" (a-or-an tag-name) (as-string-spacy tag-name) "element."))
(else #t)
)))
(define (check-language-overlap! name)
(if (causes-xml-in-laml-name-clash? name)
(xml-check-error
"The mirror function named" (as-string-spacy name) "is ambiguous. Please use it via an appropriate language map.")))
(set-html-char-transformation-entry! html-char-transformation-table (char->integer #\<) "<")
(set-html-char-transformation-entry! html-char-transformation-table (char->integer #\>) ">")
(set-html-char-transformation-entry! html-char-transformation-table (char->integer #\") """)
(set-html-char-transformation-entry! html-char-transformation-table (char->integer #\') "'")
(set-html-char-transformation-entry! html-char-transformation-table (char->integer #\&) "&")
(define (render-to-output-port xml-clause output-port . optional-parameter-list)
(let* ((prolog (optional-parameter 1 optional-parameter-list #f))
(epilog (optional-parameter 2 optional-parameter-list #f))
(language (if (ast? xml-clause) (ast-language xml-clause) #f))
(prolog-text (cond ((and (symbol? prolog) (eq? prolog 'prolog)) (standard-prolog language))
((string? prolog) prolog)
(else "")))
(epilog-text (cond ((and (symbol? epilog) (eq? epilog 'epilog)) (standard-epilog))
((string? epilog) epilog)
(else "")))
(put-fn (put-in-sink-stream-generator output-port))
)
(put-fn prolog-text)
(render-fast xml-clause put-fn xml-always-render-white-space?)
(put-fn epilog-text)))
(define (pretty-render-to-output-port xml-clause output-port . optional-parameter-list)
(let* ((prolog (optional-parameter 1 optional-parameter-list #f))
(epilog (optional-parameter 2 optional-parameter-list #f))
(language (if (ast? xml-clause) (ast-language xml-clause) #f))
(prolog-text (cond ((and (symbol? prolog) (eq? prolog 'prolog)) (standard-prolog language))
((string? prolog) prolog)
(else "")))
(epilog-text (cond ((and (symbol? epilog) (eq? epilog 'epilog)) (standard-epilog))
((string? epilog) epilog)
(else "")))
(put-fn (put-in-sink-stream-generator output-port))
)
(put-fn prolog-text)
(pp-render-fast xml-clause put-fn xml-always-render-white-space? 0 #f)
(put-fn epilog-text)))
(define (render-start-tag-to-output-port xml-clause output-port)
(let ((put-fn (put-in-sink-stream-generator output-port)))
(render-fast xml-clause put-fn xml-always-render-white-space? 'start-tag)))
(define (render-end-tag-to-output-port xml-clause output-port)
(let ((put-fn (put-in-sink-stream-generator output-port)))
(render-fast xml-clause put-fn xml-always-render-white-space? 'end-tag)))
(define (xml-render xml-clause . optional-parameter-list)
(let* ((prolog (optional-parameter 1 optional-parameter-list #f))
(epilog (optional-parameter 2 optional-parameter-list #f))
(prolog-text (cond ((and (symbol? prolog) (eq? prolog 'prolog)) (standard-prolog))
((string? prolog) prolog)
(else "")))
(epilog-text (cond ((and (symbol? epilog) (eq? epilog 'epilog)) (standard-epilog))
((string? epilog) epilog)
(else "")))
)
(reset-sink-string)
(render-fast xml-clause put-in-sink-text-string xml-always-render-white-space?)
(string-append
prolog-text
(sink-string)
epilog-text)))
(define (pretty-xml-render xml-clause . optional-parameter-list)
(let* ((prolog (optional-parameter 1 optional-parameter-list #f))
(epilog (optional-parameter 2 optional-parameter-list #f))
(prolog-text (cond ((and (symbol? prolog) (eq? prolog 'prolog)) (standard-prolog))
((string? prolog) prolog)
(else "")))
(epilog-text (cond ((and (symbol? epilog) (eq? epilog 'epilog)) (standard-epilog))
((string? epilog) epilog)
(else "")))
)
(reset-sink-string)
(pp-render-fast xml-clause put-in-sink-text-string xml-always-render-white-space? 0 #f)
(string-append
prolog-text
(sink-string)
epilog-text)))
(define (start-tag-of xml-clause)
(reset-sink-string)
(render-fast xml-clause put-in-sink-text-string xml-always-render-white-space? 'start-tag)
(sink-string))
(define (end-tag-of xml-clause)
(reset-sink-string)
(render-fast xml-clause put-in-sink-text-string xml-always-render-white-space? 'end-tag)
(sink-string))
(define sink-string-segment-size 20000)
(define sink-string-segment-limit (- sink-string-segment-size 1))
(define output-sink-segments '())
(define output-sink-string (make-string sink-string-segment-size))
(define next-sink-ptr 0)
(define (put-in-sink-text-string x)
(cond ((char? x)
(begin
(string-set! output-sink-string next-sink-ptr x)
(set! next-sink-ptr (+ 1 next-sink-ptr))
(if (= next-sink-ptr sink-string-segment-size) (prepare-next-sink-segment))))
((string? x)
(do ((lgt (string-length x))
(i 0 (+ i 1))
(j next-sink-ptr (if (< j sink-string-segment-limit) (+ j 1) 0))
)
((= i lgt) (set! next-sink-ptr j))
(string-set! output-sink-string j (string-ref x i))
(if (= j sink-string-segment-limit) (prepare-next-sink-segment))
))
(else "put-in-sink-string: Can only output chars or strings")))
(define (prepare-next-sink-segment)
(set! output-sink-segments (cons (string-copy output-sink-string) output-sink-segments))
(set! next-sink-ptr 0)
)
(define (sink-string)
(string-append
(list-to-string (reverse output-sink-segments) "")
(substring output-sink-string 0 next-sink-ptr)))
(define (reset-sink-string)
(set! output-sink-segments '())
(set! next-sink-ptr 0))
(define (put-in-sink-stream-generator port)
(lambda (x)
(cond ((char? x)
(write-char x port))
((string? x)
(do ((lgt (string-length x))
(i 0 (+ i 1))
)
((= i lgt) 'done)
(write-char (string-ref x i) port)))
(else "put-in-sink-stream: Can only output chars or strings"))))
(define quote-char #\")
(define (render-fast ast put always-render-white-space? . optional-parameter-list)
(let* ((render-what (optional-parameter 1 optional-parameter-list 'all))
(tag-name (ast-element-name ast))
(contents-list (ast-subtrees ast))
(attribute-properlist (ast-attributes ast))
(attribute-alist (propertylist-to-alist attribute-properlist))
(reorganized-attribute-alist (html-css-split attribute-alist '() '()))
(html-attribute-alist (car reorganized-attribute-alist))
(css-attribute-alist (cdr reorganized-attribute-alist))
(kind (ast-kind ast))
(language (ast-language ast))
(xml-transliterate-character-data? (xml-transliterate-character-data-in? language))
(xml-non-transliteration-elements (xml-non-transliteration-elements-in language))
(xml-preformatted-text-elements (xml-preformatted-text-elements-in language))
(xml-char-transformation-table (xml-char-transformation-table-in language))
)
(cond ((eq? kind 'single)
(put #\<)
(put tag-name)
(for-each
(lambda (attr-pair)
(let ((key (car attr-pair))
(val (cdr attr-pair)))
(put #\space)
(put (symbol->string key))
(put #\=) (put quote-char)
(do ((lgt (string-length val))
(i 0 (+ i 1))
)
((= i lgt) 'done)
(let ((ch (string-ref val i)))
(if (eqv? ch #\&) (put ch) (put (html-char-transform ch xml-char-transformation-table))))
)
(put quote-char))
)
html-attribute-alist)
(if (not (null? css-attribute-alist))
(begin
(put #\space)
(put "style=") (put quote-char)
(for-each
(lambda (attr-pair)
(let* ((key (symbol->string (car attr-pair)))
(non-cssed-key (substring key 4 (string-length key)))
(val (cdr attr-pair)))
(put non-cssed-key)
(put #\:)
(do ((lgt (string-length val))
(i 0 (+ i 1))
)
((= i lgt) 'done)
(let ((ch (string-ref val i)))
(if (eqv? ch #\&) (put ch) (put (html-char-transform ch xml-char-transformation-table)))))
(put #\;)))
css-attribute-alist)
(put quote-char)))
(put " />"))
((eq? kind 'double)
(if (or (eq? render-what 'all) (eq? render-what 'start-tag))
(begin
(put #\<)
(put tag-name)
(for-each
(lambda (attr-pair)
(let ((key (car attr-pair))
(val (cdr attr-pair)))
(put #\space)
(put (symbol->string key))
(put #\=) (put quote-char)
(do ((lgt (string-length val))
(i 0 (+ i 1))
)
((= i lgt) 'done)
(let ((ch (string-ref val i)))
(if (eqv? ch #\&) (put ch) (put (html-char-transform ch xml-char-transformation-table)))))
(put quote-char))
)
html-attribute-alist)
(if (not (null? css-attribute-alist))
(begin
(put #\space)
(put "style=") (put quote-char)
(for-each
(lambda (attr-pair)
(let* ((key (symbol->string (car attr-pair)))
(non-cssed-key (substring key 4 (string-length key)))
(val (cdr attr-pair)))
(put non-cssed-key)
(put #\:)
(do ((lgt (string-length val))
(i 0 (+ i 1))
)
((= i lgt) 'done)
(let ((ch (string-ref val i)))
(if (eqv? ch #\&) (put ch) (put (html-char-transform ch xml-char-transformation-table)))))
(put #\;)))
css-attribute-alist)
(put quote-char)))
(put #\>)))
(if (or (eq? render-what 'all) (eq? render-what 'contents))
(linearize-contents-list-fast contents-list put tag-name xml-transliterate-character-data? xml-non-transliteration-elements
xml-char-transformation-table
(or always-render-white-space? (member tag-name xml-preformatted-text-elements))))
(if (or (eq? render-what 'all) (eq? render-what 'end-tag))
(begin (put "</") (put tag-name) (put #\>))))
(error "render-fast: Either a single or double kind of ast expected."))))
(define (linearize-contents-list-fast contents-list put tag-name xml-transliterate-character-data? xml-non-transliteration-elements xml-char-transformation-table always-render-white-space?)
(for-each
(lambda (contents) (linearize-contents-fast contents put tag-name xml-transliterate-character-data? xml-non-transliteration-elements xml-char-transformation-table always-render-white-space?))
contents-list))
(define (linearize-contents-fast contents put tag-name xml-transliterate-character-data? xml-non-transliteration-elements xml-char-transformation-table
always-render-white-space?)
(cond ((char-ref? contents) (put (xml-render-char-ref contents)))
((xml-comment? contents) (put (xml-render-xml-comment contents)))
((processing-instruction? contents) (put (xml-render-processing-instruction contents)))
((cdata-section? contents) (put (xml-render-cdata-section contents)))
((cdata? contents)
(let ((white-space-printed? #f))
(if (and xml-transliterate-character-data? (not (member tag-name xml-non-transliteration-elements)))
(do ((lgt (string-length contents))
(i 0 (+ i 1))
)
((= i lgt) 'done)
(let* ((ch (html-char-transform (string-ref contents i) xml-char-transformation-table))
(ch-white-space? (and (not (empty-string? ch)) (string-of-char-list? ch white-space-char-list)))
)
(if always-render-white-space?
(put ch)
(begin
(if (not (and white-space-printed? ch-white-space?))
(if ch-white-space? (put #\space) (put ch)))
(if ch-white-space? (set! white-space-printed? #t) (set! white-space-printed? #f))
)
)
)
)
(do ((lgt (string-length contents))
(i 0 (+ i 1))
)
((= i lgt) 'done)
(let ((ch (string-ref contents i)))
(if always-render-white-space?
(put ch)
(begin
(if (not (and white-space-printed? (memv ch white-space-char-list)))
(put ch))
(if (memv ch white-space-char-list) (set! white-space-printed? #t) (set! white-space-printed? #f))
)
)
)
)
)
)
)
((forced-white-space? contents) (put #\space))
((ast? contents) (render-fast contents put always-render-white-space?))
((delayed-procedural-contents-element? contents)
(display-warning "Attempting to render delayed procedural content element - ignored"))
(else 'do-nothing)
)
)
(define (xml-css-key? key)
(let* ((key-str (symbol->string key))
(lgt (string-length key-str)))
(if
(and (>= lgt 4)
(or (eqv? (string-ref key-str 0) #\c) (eqv? (string-ref key-str 0) #\C))
(or (eqv? (string-ref key-str 1) #\s) (eqv? (string-ref key-str 1) #\S))
(or (eqv? (string-ref key-str 2) #\s) (eqv? (string-ref key-str 2) #\S))
(eqv? (string-ref key-str 3) #\:))
(substring key-str 4 lgt)
#f)))
(define (html-css-split attribute-alist html-alist css-alist)
(cond ((null? attribute-alist) (cons (reverse html-alist) (reverse css-alist)))
((xml-css-key? (caar attribute-alist))
(html-css-split (cdr attribute-alist) html-alist (cons (car attribute-alist) css-alist)))
(else
(html-css-split (cdr attribute-alist) (cons (car attribute-alist) html-alist) css-alist))))
(define (pp-render-fast ast put always-render-white-space? start-col single-lining?)
(if (single-liner-form? ast start-col preferred-maximum-width)
(render-fast ast put #f)
(let* ((tag-name (ast-element-name ast))
(contents-list (ast-subtrees ast))
(attribute-properlist (ast-attributes ast))
(attribute-alist (propertylist-to-alist attribute-properlist))
(reorganized-attribute-alist (html-css-split attribute-alist '() '()))
(html-attribute-alist (car reorganized-attribute-alist))
(css-attribute-alist (cdr reorganized-attribute-alist))
(kind (ast-kind ast))
(language (ast-language ast))
(xml-transliterate-character-data? (xml-transliterate-character-data-in? language))
(xml-non-transliteration-elements (xml-non-transliteration-elements-in language))
(xml-preformatted-text-elements (xml-preformatted-text-elements-in language))
(xml-char-transformation-table (xml-char-transformation-table-in language))
(attr-width 0)
(attr-cnt 0)
(attr-lgt (length attribute-alist))
)
(cond ((eq? kind 'single)
(put #\<)
(put tag-name)
(for-each
(lambda (attr-pair)
(let ((key (car attr-pair))
(val (cdr attr-pair)))
(put #\space)
(put (symbol->string key))
(put #\=) (put quote-char)
(do ((lgt (string-length val))
(i 0 (+ i 1))
)
((= i lgt) 'done)
(let ((ch (string-ref val i)))
(if (eqv? ch #\&) (put ch) (put (html-char-transform ch xml-char-transformation-table)))))
(put quote-char)
(set! attr-width (+ attr-width (string-length (symbol->string key)) (string-length val) 3))
(set! attr-cnt (+ 1 attr-cnt))
(if (and (> (+ attr-width start-col) preferred-maximum-width) (< attr-cnt attr-lgt))
(begin (put #\newline) (put-indentation put (+ (string-length tag-name) start-col 1)) (set! attr-width 0)))
)
)
html-attribute-alist)
(if (not (null? css-attribute-alist))
(begin
(put #\space)
(put "style=") (put quote-char)
(for-each
(lambda (attr-pair)
(let* ((key (symbol->string (car attr-pair)))
(non-cssed-key (substring key 4 (string-length key)))
(val (cdr attr-pair)))
(put non-cssed-key)
(put #\:)
(do ((lgt (string-length val))
(i 0 (+ i 1))
)
((= i lgt) 'done)
(let ((ch (string-ref val i)))
(if (eqv? ch #\&) (put ch) (put (html-char-transform ch xml-char-transformation-table)))))
(put #\;)))
css-attribute-alist)
(put quote-char)))
(put " />"))
((eq? kind 'double)
(put #\<)
(put tag-name)
(for-each
(lambda (attr-pair)
(let ((key (car attr-pair))
(val (cdr attr-pair)))
(put #\space)
(put (symbol->string key))
(put #\=) (put quote-char)
(do ((lgt (string-length val))
(i 0 (+ i 1))
)
((= i lgt) 'done)
(let ((ch (string-ref val i)))
(if (eqv? ch #\&) (put ch) (put (html-char-transform ch xml-char-transformation-table)))))
(put quote-char)
(set! attr-width (+ attr-width (string-length (symbol->string key)) (string-length val) 3))
(set! attr-cnt (+ 1 attr-cnt))
(if (and (> (+ attr-width start-col) preferred-maximum-width) (< attr-cnt attr-lgt))
(begin (put #\newline) (put-indentation put (+ (string-length tag-name) start-col 1)) (set! attr-width 0)))
)
)
html-attribute-alist)
(if (not (null? css-attribute-alist))
(begin
(put #\space)
(put "style=") (put quote-char)
(for-each
(lambda (attr-pair)
(let* ((key (symbol->string (car attr-pair)))
(non-cssed-key (substring key 4 (string-length key)))
(val (cdr attr-pair)))
(put non-cssed-key)
(put #\:)
(do ((lgt (string-length val))
(i 0 (+ i 1))
)
((= i lgt) 'done)
(let ((ch (string-ref val i)))
(if (eqv? ch #\&) (put ch) (put (html-char-transform ch xml-char-transformation-table)))))
(put #\;)))
css-attribute-alist)
(put quote-char)))
(put #\>)
(put #\newline) (put-indentation put (+ start-col indentation-delta))
(pp-linearize-contents-list-fast
contents-list put tag-name
xml-transliterate-character-data? xml-non-transliteration-elements xml-char-transformation-table
(or always-render-white-space? (member tag-name xml-preformatted-text-elements))
(+ start-col indentation-delta) single-lining?)
(put #\newline) (put-indentation put start-col)
(put "</") (put tag-name) (put #\>))
(error "pp-render-fast: Either a single or double kind of ast expected.")))))
(define (pp-linearize-contents-list-fast contents-list put tag-name xml-transliterate-character-data? xml-non-transliteration-elements xml-char-transformation-table
always-render-white-space? start-col single-lining?)
(for-each
(lambda (contents) (pp-linearize-contents-fast contents put tag-name xml-transliterate-character-data? xml-non-transliteration-elements xml-char-transformation-table
always-render-white-space? start-col single-lining?))
contents-list))
(define (pp-linearize-contents-fast contents put tag-name xml-transliterate-character-data? xml-non-transliteration-elements xml-char-transformation-table
always-render-white-space? start-col single-lining?)
(cond ((char-ref? contents) (put (xml-render-char-ref contents)))
((xml-comment? contents) (put (xml-render-xml-comment contents)))
((processing-instruction? contents) (put (xml-render-processing-instruction contents)))
((cdata-section? contents) (put (xml-render-cdata-section contents)))
((cdata? contents)
(let ((white-space-printed? #f))
(if (and xml-transliterate-character-data? (not (member tag-name xml-non-transliteration-elements)))
(do ((lgt (string-length contents))
(i 0 (+ i 1))
(j 0 (+ j 1))
)
((= i lgt) 'done)
(let* ((ch (html-char-transform (string-ref contents i) xml-char-transformation-table))
(ch-white-space? (and (not (empty-string? ch)) (string-of-char-list? ch white-space-char-list)))
)
(if always-render-white-space?
(put ch)
(begin
(if (not (and white-space-printed? ch-white-space?))
(if ch-white-space?
(if (> (+ j start-col) preferred-maximum-width)
(begin (put #\newline) (put-indentation put start-col) (set! j 0))
(put #\space)
)
(put ch))
)
(if ch-white-space? (set! white-space-printed? #t) (set! white-space-printed? #f))
)
)
)
)
(do ((lgt (string-length contents))
(i 0 (+ i 1))
(j 0 (+ j 1))
)
((= i lgt) 'done)
(let* ((ch (string-ref contents i))
(ch-white-space? (memv ch white-space-char-list))
)
(if always-render-white-space?
(put ch)
(begin
(if (not (and white-space-printed? ch-white-space?))
(if ch-white-space?
(if (> (+ j start-col) preferred-maximum-width)
(begin (put #\newline) (put-indentation put start-col) (set! j 0))
(put #\space)
)
(put ch))
)
(if (memv ch white-space-char-list) (set! white-space-printed? #t) (set! white-space-printed? #f))
)
)
)
)
)
)
)
((forced-white-space? contents)
(put #\newline) (put-indentation put start-col)
)
((ast? contents)
(pp-render-fast contents put always-render-white-space? start-col single-lining?)
)
((delayed-procedural-contents-element? contents)
(display-warning "Attempting to render delayed procedural content element - ignored"))
(else 'do-nothing)
)
)
(define (put-indentation put n)
(do ((i 1 (+ i 1)))
((> i n) 'done)
(put #\space)))
(define (single-liner-form? ast start-col max-width)
(let ((width (measure-xml-in-laml-form ast)))
(<= (+ width start-col) max-width)))
(define (measure-xml-in-laml-form x)
(cond ((string? x) (string-length x))
((forced-white-space? x) 1)
((char-ref? x)
(let ((value (char-ref-value x)))
(cond ((symbol? value) (+ 2 (string-length (symbol->string value))))
((number? value) (+ 3 (string-length (number->string value))))
(else (laml-error "measure-xml-in-laml-form: Error in character reference" x))))
)
((xml-comment? x)
(let* ((comment-contents (xml-comment-contents x))
(contents-sum (sum-list (map string-length comment-contents)))
(comment-count (length comment-contents)))
(+ contents-sum comment-count 6)
)
)
((processing-instruction? x)
(let* ((target (processing-instruction-target x))
(contents (processing-instruction-contents x))
(contents-sum (sum-list (map string-length contents)))
(count (length contents)))
(+ (string-length target) contents-sum count 4)
)
)
((cdata-section? x)
(let* ((cdata-contents (cdata-section-contents x))
(contents-sum (sum-list (map string-length cdata-contents)))
(count (length cdata-contents)))
(+ contents-sum count 10))
)
((ast? x)
(let ((tag-name (ast-element-name x))
(attributes (propertylist-to-alist (ast-attributes x)))
(content-list (ast-subtrees x))
)
(+ (* 2 (string-length tag-name))
5
(measure-attribute-list attributes)
(sum-list
(map measure-xml-in-laml-form content-list))
)
)
)
((delayed-procedural-contents-element? x) 0)
(else (laml-error "measure-xml-in-laml-form: Unknown constituent" x))
)
)
(define (measure-attribute-list attribute-alist)
(sum-list (map measure-attribute attribute-alist)))
(define (measure-attribute key-val)
(let ((key (car key-val))
(val (cdr key-val)))
(+ (string-length (symbol->string key))
(string-length val)
4
)))
(define (xml-linearize-attributes attr-list)
(let ((lgt (length attr-list)))
(if (and (>= lgt 1) (not (symbol? (car attr-list))))
(error (string-append "xml-linearize-attributes: Non-symbol key encountered: " (as-string (car attr-list)) " in attribute list " (as-string attr-list) ". Maybe conversion problem from html-v1.")))
(xml-linearize-attributes-1 (reverse attr-list) "" "" lgt attr-list)))
(define (xml-linearize-attributes-1 attr-list html-attr-string css-attr-string lgt whole-attr-list)
(cond ((= lgt 0 ) (cons (strip-trailing-characters (list #\space) html-attr-string) css-attr-string))
((>= lgt 2) (let* ((val (car attr-list))
(key (cadr attr-list))
(css-key (xml-css-key? key))
)
(cond (css-key
(xml-linearize-attributes-1
(cddr attr-list)
html-attr-string
(string-append (xml-linearize-attribute-pair-css val css-key) ";" css-attr-string)
(- lgt 2)
whole-attr-list))
(else
(xml-linearize-attributes-1
(cddr attr-list)
(string-append (xml-linearize-attribute-pair-html val key) " " html-attr-string)
css-attr-string
(- lgt 2)
whole-attr-list)))))
((< lgt 2) (error (string-append "Xml-Linearize-attributes-1: Called with an odd length attribute list. Not a Lisp property list: " (as-string whole-attr-list))))))
(define (xml-linearize-attribute-pair-html val key)
(string-append (as-string key) " = " (string-it (as-string val))))
(define (xml-linearize-attribute-pair-css val key)
(string-append key ": " (as-string val)))
(define (xml-modify-element element . attributes-and-contents)
(lambda parameters (apply element (append parameters attributes-and-contents))))
(define (xml-modify-element-prepend element . attributes-and-contents)
(lambda parameters (apply element (append attributes-and-contents parameters))))
(define (xml-in-laml-abstraction f . optional-parameter-list)
(let ((parameter-validator! (optional-parameter 1 optional-parameter-list (lambda (co at) #t)))
(f-name (optional-parameter 2 optional-parameter-list "some ad hoc abstraction"))
(language (optional-parameter 3 optional-parameter-list #f))
)
(lambda parameters
(let* ((ordered-parameters (xml-sort-superficially-tag-parameters parameters f-name language))
(content-parameters (car ordered-parameters))
(attribute-prop-list (cdr ordered-parameters))
)
(parameter-validator! content-parameters attribute-prop-list)
(f content-parameters attribute-prop-list)))))
(define (xml-in-laml-positional-abstraction n m f . optional-parameter-list)
(let ((parameter-validator! (optional-parameter 1 optional-parameter-list (lambda (co at) #t)))
(f-name (optional-parameter 2 optional-parameter-list "some ad hoc abstraction"))
(language (optional-parameter 3 optional-parameter-list #f))
)
(lambda parameters
(let ((lgt-parameters (length parameters)))
(if (> (+ n m) lgt-parameters)
(laml-error "Two few parameters passed to" f-name ":" parameters))
(let* ((prefix-parameters (front-sublist parameters n))
(rest-parameters (list-tail parameters n))
(rest-length (- lgt-parameters n))
(xml-in-laml-parameters (front-sublist rest-parameters (- rest-length m)))
(suffix-parameters (rear-sublist parameters m))
(ordered-parameters (xml-sort-superficially-tag-parameters xml-in-laml-parameters f-name language))
(content-parameters (car ordered-parameters))
(attribute-prop-list (cdr ordered-parameters))
)
(parameter-validator! content-parameters attribute-prop-list)
(apply f (append prefix-parameters (list content-parameters attribute-prop-list) suffix-parameters)))))))
(define (xml-in-laml-parametrization f parameter-mediator . optional-parameter-list)
(let ((parameter-validator! (optional-parameter 1 optional-parameter-list (lambda (co at) #t)))
(f-name (optional-parameter 2 optional-parameter-list "some xml-in-laml parametrization"))
(language (optional-parameter 3 optional-parameter-list #f))
)
(lambda parameters
(let* ((ordered-parameters (xml-sort-tag-parameters parameters f-name language))
(content-parameters (car ordered-parameters))
(attribute-prop-list (cdr ordered-parameters))
)
(parameter-validator! content-parameters attribute-prop-list)
(apply f (parameter-mediator content-parameters attribute-prop-list))))))
(define (required-implied-attributes required-attribute-names implied-attribute-names . optional-parameter-list)
(let ((tag-name (optional-parameter 1 optional-parameter-list "??")))
(lambda (contents attributes)
(let ((attribute-names (every-second-element attributes)))
(xml-check-required-attributes! attribute-names required-attribute-names tag-name)
(if (not (equal? implied-attribute-names (list '*)))
(xml-check-for-attribute-existence! attribute-names (append required-attribute-names implied-attribute-names) tag-name))
))))
(define (find-asts ast el-name . optional-parameter-list)
(let ((ast-transformer (optional-parameter 1 optional-parameter-list id-1)))
(cond ((equal? (ast-element-name ast) (as-string el-name)) (list (ast-transformer ast)))
(else
(let* ((sub-asts (filter ast? (ast-subtrees ast)))
(possible-sub-asts
(filter
(lambda (sub-ast)
(can-have-element-constituent? sub-ast el-name))
sub-asts))
)
(flatten (map (lambda (sub-ast) (find-asts sub-ast el-name ast-transformer)) possible-sub-asts)))))))
(define (find-first-ast ast el-name . optional-parameter-list)
(let ((ast-transformer (optional-parameter 1 optional-parameter-list id-1)))
(call-with-current-continuation
(lambda (return)
(find-first-ast-help ast el-name ast-transformer return)))))
(define (find-first-ast-help ast el-name ast-transformer return)
(cond ((equal? (ast-element-name ast) (as-string el-name)) (return (ast-transformer ast)))
(else
(let* ((sub-asts (filter ast? (ast-subtrees ast))))
(for-each
(lambda (sub-ast)
(if (can-have-element-constituent? sub-ast el-name)
(find-first-ast-help sub-ast el-name ast-transformer return)))
sub-asts))))
#f)
(define (unique-ast-attribute ast name . optional-parameter-list)
(call-with-current-continuation
(lambda (return)
(let ((default-attribute-value (optional-parameter 1 optional-parameter-list #f)))
(unique-ast-attribute-help ast (as-symbol name) default-attribute-value return)
(laml-error "unique-ast-attribute: The attribute named" name "is not found in AST, or it is not unique in AST.")))))
(define (unique-ast-attribute-help ast name default-value return)
(let* ((alist (propertylist-to-alist (ast-attributes ast)))
(res (assq name alist))
(can-be-in-ast (can-attribute-be-in-ast ast name))
(candidate-sub-asts (sub-asts-with-possible-attribute ast name))
(candidate-count (length candidate-sub-asts))
)
(cond ((and res can-be-in-ast (= 0 candidate-count)) (return (cdr res)))
((and (not res) can-be-in-ast (= 0 candidate-count)) (return default-value))
((= 1 candidate-count)
(unique-ast-attribute-help (first candidate-sub-asts) name default-value return))
(else 'do-nothing)
)
)
)
(define (sub-asts-with-possible-attribute ast name)
(let ((sub-asts (filter ast? (ast-subtrees ast))))
(filter (lambda (sub-ast) (can-attribute-be-in-ast sub-ast name)) sub-asts)))
(define (can-attribute-be-in-one-of-subtrees? ast name)
(let ((sub-asts (filter ast? (ast-subtrees ast))))
(accumulate-right or-fn #f (map (lambda (ast) (can-attribute-be-in-ast ast name)) sub-asts))))
(define (can-attribute-be-in-ast ast name)
(turn-into-boolean
(memq name (possible-attributes-rooted-by-element (ast-element-name ast) (ast-language ast)))))
(define (traverse-and-collect-all-from-ast ast-tree node-interesting? ast-transformer)
(cond ((and (terminal-ast-node? ast-tree) (node-interesting? ast-tree)) (list (ast-transformer ast-tree)))
((and (terminal-ast-node? ast-tree) (not (node-interesting? ast-tree))) '())
((ast? ast-tree)
(let ((subtree-results
(map
(lambda (subtr) (traverse-and-collect-all-from-ast subtr node-interesting? ast-transformer))
(ast-subtrees ast-tree))))
(if (node-interesting? ast-tree)
(cons
(ast-transformer ast-tree)
(flatten subtree-results))
(flatten subtree-results))))
((list? ast-tree)
(flatten
(map
(lambda (tr) (traverse-and-collect-all-from-ast tr node-interesting? ast-transformer))
(filter ast? ast-tree))))
(else '())))
(define (traverse-and-collect-first-from-ast ast-tree node-interesting? ast-transformer)
(call-with-current-continuation
(lambda (exit)
(traverse-and-collect-first-from-ast-help ast-tree node-interesting? ast-transformer exit)))
)
(define (traverse-and-collect-first-from-ast-help ast-tree node-interesting? ast-transformer exit)
(cond ((and (terminal-ast-node? ast-tree) (node-interesting? ast-tree)) (exit (ast-transformer ast-tree)))
((ast? ast-tree)
(if (node-interesting? ast-tree)
(exit (ast-transformer ast-tree))
(for-each
(lambda (subtr) (traverse-and-collect-first-from-ast-help subtr node-interesting? ast-transformer exit))
(ast-subtrees ast-tree))))
((list? ast-tree)
(for-each
(lambda (tr) (traverse-and-collect-first-from-ast-help tr node-interesting? ast-transformer exit))
(filter ast? ast-tree)))
(else #f))
#f)
(define (transform-ast-list input-list . transform-specs)
(if (null? input-list)
'()
(let* ((ast (car input-list))
(transform-function (lookup-transform-spec ast transform-specs)))
(cons
(if transform-function (transform-function ast) ast)
(apply transform-ast-list (cdr input-list) transform-specs)))))
(define (transform-ast ast . transform-specs)
(let ((transform-function (lookup-transform-spec ast transform-specs)))
(if transform-function
(transform-function ast)
(cond ((ast? ast)
(make-ast
(ast-element-name ast)
(map (lambda (x) (apply transform-ast x transform-specs)) (ast-subtrees ast))
(ast-attributes ast)
(ast-kind ast)
(ast-language ast)))
((cdata? ast) (string-copy ast))
(else ast)))))
(define (lookup-transform-spec ast transform-specs)
(if (null? transform-specs)
#f
(let* ((single-transform-spec (car transform-specs))
(pred (car single-transform-spec))
(transformer (cadr single-transform-spec)))
(if (pred ast) transformer (lookup-transform-spec ast (cdr transform-specs))))))
(define (validation-procedure-map-of language)
(defaulted-get (as-symbol language) xml-in-laml-validator-structures #f))
(define validation-element-name-of-validator-entry (make-selector-function 1 "validation-element-name-of-validator-entry"))
(define validation-procedure-of-validator-entry (make-selector-function 2 "validation-procedure-of-validator-entry"))
(define (validation-procedure-of element-name language)
(let* ((validator-map (validation-procedure-map-of language)))
(if validator-map
(let ((validator-proc
(binary-search-in-vector
validator-map (as-string element-name) validation-element-name-of-validator-entry string=? string<=?)))
(if validator-proc
(validation-procedure-of-validator-entry validator-proc)
#f)
)
#f)))
(define (register-xml-in-laml-validators language validator-structure)
(set! xml-in-laml-validator-structures (cons (cons language validator-structure) xml-in-laml-validator-structures))
)
(define (validate-ast! ast . optional-parameter-list)
(let ((given-language (optional-parameter 1 optional-parameter-list (ast-language ast)))
(overlap-check? (optional-parameter 2 optional-parameter-list #t))
)
(let* ((el-name (ast-element-name ast))
(attr-prop-list (ast-attributes ast))
(element-content-items (ast-subtrees ast))
(val-proc! (validation-procedure-of el-name given-language))
)
(if val-proc!
(val-proc! el-name attr-prop-list element-content-items overlap-check?)
(xml-check-error "Using unknown XML element name: " el-name))
(for-each
(lambda (ast) (validate-ast! ast given-language overlap-check?))
(filter ast? element-content-items)))))
(define (content-model-map-of language)
(defaulted-get (as-symbol language) xml-in-laml-content-model-structures #f))
(define elment-name-of-content-model-structure (make-selector-function 1 "elment-name-of-content-model-structure"))
(define content-model-of-content-model-structure (make-selector-function 2 "content-model-of-content-model-structure"))
(define (content-model-of element-name language)
(let* ((content-model-map (content-model-map-of language)))
(if content-model-map
(let ((content-model
(binary-search-in-vector
content-model-map (as-string element-name) elment-name-of-content-model-structure string=? string<=?)))
(if content-model
(content-model-of-content-model-structure content-model)
#f)
)
#f)))
(define (register-xml-in-laml-content-models language content-model-structure)
(set! xml-in-laml-content-model-structures (cons (cons language content-model-structure) xml-in-laml-content-model-structures))
)
(define (action-procedure-map-of language)
(defaulted-get (as-symbol language) xml-in-laml-action-procedure-structures #f))
(define (action-procedure-of-language element-name language)
(let* ((action-procedure-map (action-procedure-map-of language)))
(if action-procedure-map
(action-procedure-of-map element-name action-procedure-map)
#f)))
(define (action-procedure-of-map element-name action-procedure-map)
(let ((action-proc
(binary-search-in-vector
action-procedure-map (as-string element-name) element-name-of-action-procedure-entry string=? string<=?)))
(if action-proc
(action-procedure-of-action-procedure-entry action-proc)
#f)))
(define (register-xml-in-laml-action-procedures language action-procedure-structure)
(set! xml-in-laml-action-procedure-structures (cons (cons language action-procedure-structure) xml-in-laml-action-procedure-structures))
)
(define element-name-of-action-procedure-entry (make-selector-function 1 "element-name-of-action-procedure-entry"))
(define action-procedure-of-action-procedure-entry (make-selector-function 2 "action-procedure-of-action-procedure-entry"))
(define (process-ast! ast . optional-parameter-list)
(let* ((given-language (optional-parameter 1 optional-parameter-list (ast-language ast)))
(action-map (optional-parameter 2 optional-parameter-list (action-procedure-map-of given-language)))
)
(let* ((el-name (ast-element-name ast))
(element-content-items (ast-subtrees ast))
(action-proc-of-ast! (action-procedure-of-map el-name action-map))
)
(if action-proc-of-ast!
(action-proc-of-ast! ast))
(for-each
(lambda (ast) (process-ast! ast given-language action-map))
(filter ast? element-content-items)))))
(define (expand-procedural-content-items-in-ast ast)
(if (has-procedural-content-items-deep? ast)
(expand-procedural-content-items-in-ast-1 ast ast)
ast))
(define (expand-procedural-content-items-in-ast-1 ast root-ast)
(let ((ast-content-items (ast-subtrees ast)))
(if (null? (filter delayed-procedural-contents-element? ast-content-items))
(make-ast
(ast-element-name ast)
(map (lambda (content-item)
(cond ((ast? content-item)
(expand-procedural-content-items-in-ast-1 content-item root-ast))
(else content-item)))
ast-content-items)
(ast-attributes ast)
(ast-kind ast)
(ast-language ast))
(let* ((inversed-ast-content-items (inverse-laml-content-list-white-spacing ast-content-items))
(expanded-ast-content-items
(map (lambda (content-item)
(cond ((delayed-procedural-contents-element? content-item)
(content-item root-ast ast))
(else content-item)))
inversed-ast-content-items))
(attributes (ast-attributes ast))
(combined-contents-and-attributes (append expanded-ast-content-items attributes))
(sorted-contents-attributes
(xml-sort-tag-parameters-1 combined-contents-and-attributes combined-contents-and-attributes '() '() (ast-element-name ast) (ast-language ast) #f))
(new-contents (car sorted-contents-attributes))
(new-recursively-expanded-content (map (lambda (content-item)
(cond ((ast? content-item)
(expand-procedural-content-items-in-ast-1 content-item root-ast))
(else content-item)))
new-contents))
(new-attributes (cdr sorted-contents-attributes))
)
(let* ((el-name (ast-element-name ast))
(lang (ast-language ast))
(validation-proc (validation-procedure-of el-name lang)))
(validation-proc el-name new-attributes new-recursively-expanded-content xml-check-language-overlap?))
(make-ast
(ast-element-name ast)
new-recursively-expanded-content
new-attributes
(ast-kind ast)
(ast-language ast))))))
(define (has-procedural-content-items-deep? ast)
(call-with-current-continuation
(lambda (return)
(has-procedural-content-items-deep-1? ast return))))
(define (has-procedural-content-items-deep-1? ast return)
(let ((sub-content-items (ast-subtrees ast)))
(if (find-in-list delayed-procedural-contents-element? sub-content-items)
(return #t)
(for-each
(lambda (content-item)
(if (ast? content-item)
(has-procedural-content-items-deep-1? content-item return)))
sub-content-items)))
#f)
(define (has-procedural-content-items? x)
(cond ((ast? x)
(let ((sub-content-items (ast-subtrees x)))
(if (find-in-list delayed-procedural-contents-element? sub-content-items) #t #f)))
((list? x)
(if (find-in-list delayed-procedural-contents-element? x) #t #f))
(else (laml-error "has-procedural-content-items? must be called on an XML-in-LAML AST or a list of content items" x))))
(define (inverse-laml-content-list-white-spacing content-items)
(cond ((null? content-items) '())
(else (iwssm-start content-items '()))
))
(define debug-inverse-space-state-machine? #f)
(define (iwssm-start lst res)
(if debug-inverse-space-state-machine? (display-message "start"))
(if (null? lst)
(reverse res)
(let ((el (first lst)) (rest (cdr lst)))
(cond
((equal? explicit-space el) (iwssm-start rest res))
(else (iwssm-string-seen el rest res))))))
(define (iwssm-string-seen the-string lst res)
(if debug-inverse-space-state-machine? (display-message "string-seen"))
(set! res (cons the-string res))
(if (null? lst)
(reverse res)
(let ((el (first lst)) (rest (cdr lst)))
(cond ((equal? explicit-space el) (iwssm-string-space-seen rest res))
(else (iwssm-string-string-seen el rest res))))))
(define (iwssm-string-space-seen lst res)
(if debug-inverse-space-state-machine? (display-message "string-space-seen"))
(if (null? lst)
(reverse res)
(let ((el (first lst)) (rest (cdr lst)))
(cond ((equal? explicit-space el) (iwssm-string-space-seen rest res))
(else (iwssm-string-seen el rest res))))))
(define (iwssm-string-string-seen the-string lst res)
(if debug-inverse-space-state-machine? (display-message "string-string-seen"))
(set! res (cons the-string (cons explicit-space-suppress res)))
(if (null? lst)
(reverse res)
(let ((el (first lst)) (rest (cdr lst)))
(cond ((equal? explicit-space el) (iwssm-string-space-seen rest res))
(else (iwssm-string-string-seen el rest res))))))
(define (ast-to-parse-tree ast)
(let ((pt (ast-to-parse-tree-1 ast)))
(make-final-parse-tree 'html-tree (list pt))))
(define (ast-to-parse-tree-1 ast)
(letrec
((subtree-transform
(lambda (x)
(cond ((ast? x) (ast-to-parse-tree-1 x))
((cdata? x) x)
((char-ref? x) (xml-render-char-ref x))
((forced-white-space? x) " ")
(else (laml-error "subtree-transform:" "Unknown subtree constituent" (as-string x)))))
)
(explicit-space-splicing
(lambda (parse-tree)
(if (tree-entry? parse-tree)
(let* ((node (root-of-parse-tree parse-tree))
(subtrees (subtrees-of-parse-tree parse-tree))
(new-subtrees (explicit-space-splicing-lst subtrees '()))
)
(make-parse-tree node new-subtrees))
parse-tree)
))
(explicit-space-splicing-lst
(lambda (subtree-list res-lst)
(cond ((null? subtree-list)
(reverse res-lst))
((null? (cdr subtree-list))
(explicit-space-splicing-lst (cdr subtree-list) (cons (car subtree-list) res-lst)))
((and (string? (car subtree-list)) (string? (cadr subtree-list)))
(if (equal? (cadr subtree-list) " ")
(explicit-space-splicing-lst (cddr subtree-list) (cons (string-append (car subtree-list) (cadr subtree-list)) res-lst))
(explicit-space-splicing-lst (cdr subtree-list) (cons (car subtree-list) res-lst))))
(else (explicit-space-splicing-lst (cdr subtree-list) (cons (car subtree-list) res-lst))))))
(split-attribute-list
(lambda (attr-lst) (split-attribute-list-1 attr-lst '() '())))
(split-attribute-list-1
(lambda (attr-lst html-attr-list css-attr-list)
(cond ((null? attr-lst) (cons (reverse html-attr-list) (reverse css-attr-list)))
((xml-css-key? (car attr-lst))
(split-attribute-list-1 (cddr attr-lst) html-attr-list (cons (cadr attr-lst) (cons (car attr-lst) css-attr-list))))
(else
(split-attribute-list-1 (cddr attr-lst) (cons (cadr attr-lst) (cons (car attr-lst) html-attr-list)) css-attr-list)))))
(to-css-string
(lambda (css-attr-list)
(let ((css-attr-alist (propertylist-to-alist css-attr-list)))
(string-append
(list-to-string
(map
(lambda (css-key-val) (xml-linearize-attribute-pair-css (cdr css-key-val) (xml-css-key? (car css-key-val))))
css-attr-alist)
";") ";"))))
)
(let* ((element-name (ast-element-name ast))
(subtrees (ast-subtrees ast))
(attr-lst (ast-attributes ast))
(attr-list-normal-css (split-attribute-list attr-lst))
(html-attr-list (car attr-list-normal-css))
(css-attr-list (cdr attr-list-normal-css))
(attr-lst-result
(if (null? css-attr-list)
html-attr-list
(cons 'style (cons (to-css-string css-attr-list) html-attr-list))))
(kind (ast-kind ast))
)
(cond ((eq? kind 'single)
(make-tag-structure
'start-end
element-name
attr-lst-result))
((eq? kind 'double)
(explicit-space-splicing
(make-parse-tree
(make-tag-structure
'start
element-name
attr-lst-result)
(map subtree-transform subtrees))))
(else (laml-error "ast-to-parse-tree-1:" "Unknown kind of ast" kind))))))