racket/collects/xml/private/xexpr.rkt

#lang racket/base
(require racket/pretty
         racket/list
         racket/contract
         "xexpr-core.rkt"
         "structures.rkt"
         "reader.rkt"
         "writer.rkt")

;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts.

;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a))
(define (assoc-sort to-sort)
  (sort to-sort (bcompose string<? (compose symbol->string car))))

(define xexpr-drop-empty-attributes (make-parameter #f))

; : (a -> bool) tst -> bool
; To check if l is a (listof p?)
; Don't use (and (list? l) (andmap p? l)) because l may be improper.
(define (listof? p? l)
  (let listof-p? ([l l])
    (or (null? l)
        (and (cons? l) (p? (car l)) (listof-p? (cdr l))))))

; : tst -> bool
(define (xexpr-attribute? b)
  (and (pair? b)
       (symbol? (car b))
       (pair? (cdr b))
       (string? (cadr b))
       (null? (cddr b))))

;; xml->xexpr : Content -> Xexpr
(define (xml->xexpr x)
  (let* ([non-dropping-combine
          (lambda (atts body)
            (cons (assoc-sort (map attribute->srep atts))
                  body))]
         [combine (if (xexpr-drop-empty-attributes)
                      (lambda (atts body)
                        (if (null? atts)
                            body
                            (non-dropping-combine atts body)))
                      non-dropping-combine)])
    (let loop ([x x])
      (cond
        [(element? x)
         (let ([body (map loop (element-content x))]
               [atts (element-attributes x)])
           (cons (element-name x) (combine atts body)))]
        [(pcdata? x) (pcdata-string x)]
        [(entity? x) (entity-text x)]
        [(or (comment? x) (p-i? x) (cdata? x)) x]
        [(document? x) (error 'xml->xexpr "Expected content, given ~e\nUse document-element to extract the content." x)]
        [(permissive-xexprs) x]
        [else (error 'xml->xexpr "Expected content, given ~e" x)]))))

;; attribute->srep : Attribute -> Attribute-srep
(define (attribute->srep a)
  (list (attribute-name a) (attribute-value a)))

;; srep->attribute : Attribute-srep -> Attribute
(define (srep->attribute a)
  (unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a)))
    (error 'srep->attribute "expected (list Symbol String) given ~e" a))
  (make-attribute 'scheme 'scheme (car a) (cadr a)))

;; xexpr->xml : Xexpr -> Content
;; The contract is enforced.
(define (xexpr->xml x)
  (cond
    [(pair? x)
     (let ([f (lambda (atts body)
                (unless (list? body)
                  (error 'xexpr->xml
                         "expected a list of xexprs for the body in ~e"
                         x))
                (make-element 'scheme 'scheme (car x)
                              atts
                              (map xexpr->xml body)))])
       (if (and (pair? (cdr x))
                (or (null? (cadr x))
                    (and (pair? (cadr x)) (pair? (caadr x)))))
           (f (map srep->attribute (cadr x)) (cddr x))
           (f null (cdr x))))]
    [(string? x) (make-pcdata 'scheme 'scheme x)]
    [(or (symbol? x) (exact-nonnegative-integer? x))
     (make-entity 'scheme 'scheme x)]
    [(or (comment? x) (p-i? x) (cdata? x) (pcdata? x)) x]
    [else ;(error 'xexpr->xml "malformed xexpr ~e" x)
     x]))

;; xexpr->string : Xexpression -> String
(define (xexpr->string xexpr)
  (let ([port (open-output-string)])
    (write-xml/content (xexpr->xml xexpr) port)
    (get-output-string port)))

(define (string->xexpr str)
  (xml->xexpr (document-element (read-xml (open-input-string str)))))

;; bcompose : (a a -> c) (b -> a) -> (b b -> c)
(define (bcompose f g)
  (lambda (x y) (f (g x) (g y))))

(provide xexpr? 
         validate-xexpr
         correct-xexpr?
         xexpr/c)

(provide/contract
 [exn:invalid-xexpr? (any/c . -> . boolean?)]
 [exn:invalid-xexpr-code (exn:invalid-xexpr? . -> . any/c)]
 [string->xexpr (string? . -> . xexpr/c)]
 [xexpr->string (xexpr/c . -> . string?)]
 [xml->xexpr (content/c . -> . xexpr/c)]
 [xexpr->xml (xexpr/c . -> . content/c)]
 [xexpr-drop-empty-attributes (parameter/c boolean?)]
 [write-xexpr (->* (xexpr/c) (output-port?) void)] )

(define (write-xexpr x [out (current-output-port)])
  (cond
    ; Element
    [(cons? x)
     (define name (car x))
     (define-values (attrs content)
       (if (and (pair? (cdr x))
                (or (null? (cadr x))
                    (and (pair? (cadr x)) (pair? (caadr x)))))
           (values (cadr x) (cddr x))
           (values null (cdr x))))
     ; Write opening tag
     (display "<" out)
     (display name out)
     ; Write attributes
     (for ([att (in-list attrs)])
       (fprintf out " ~a=\"~a\"" (car att)
                (escape (cadr att) escape-attribute-table)))
     ; Write end of opening tag
     (if (and (null? content)
              (let ([short (empty-tag-shorthand)])
                (case short
                  [(always) #t]
                  [(never) #f]
                  [else (memq (lowercase-symbol name) short)])))
         (display " />" out)
         (begin
           (display ">" out)
           ; Write body
           (for ([xe (in-list content)])
             (write-xexpr xe out))
           ; Write closing tag
           (display "</" out)
           (display name out)
           (display ">" out)))]
    ; PCData
    [(string? x)
     (display (escape x escape-table) out)]
    ; Entities
    [(symbol? x)
     (fprintf out "&~a;" x)]
    [(valid-char? x)
     (fprintf out "&#~a;" x)]
    ; Embedded XML
    [(cdata? x)
     (write-xml-cdata x 0 void out)]
    [(comment? x)
     (write-xml-comment x 0 void out)]
    [(p-i? x)
     (write-xml-p-i x 0 void out)]))