#lang racket/base

;; Small namespace-insensitive helpers for Racket x-expressions.
;; UPnP documents use default namespaces and SOAP commonly uses prefixes, so
;; matching by local element or attribute name keeps parsers independent of
;; namespace prefixes.

(require racket/list
         racket/string)

(provide xexpr-element?
         xexpr-local-name
         xexpr-attributes
         xexpr-attribute
         xexpr-children
         xexpr-child-elements
         xexpr-child-element
         xexpr-text
         xexpr-child-text
         xexpr-find-descendant)

(define (xexpr-element? value)
  (and (pair? value)
       (symbol? (car value))))

(define (xexpr-attribute-list? value)
  (and (list? value)
       (andmap
        (lambda (attribute)
          (and (list? attribute)
               (= (length attribute) 2)
               (symbol? (car attribute))
               (string? (cadr attribute))))
        value)))

(define (xexpr-local-name value)
  (let* ([name (if (symbol? value) (symbol->string value) value)]
         [parts (and (string? name) (string-split name ":"))])
    (and parts
         (string-downcase (last parts)))))

(define (xexpr-attributes value)
  (if (not (xexpr-element? value))
      '()
      (let ([rest (cdr value)])
        (if (and (pair? rest)
                 (xexpr-attribute-list? (car rest)))
            (car rest)
            '()))))

(define (xexpr-attribute value name [default #f])
  (let* ([wanted (xexpr-local-name name)]
         [attribute
          (findf
           (lambda (candidate)
             (string=? (xexpr-local-name (car candidate)) wanted))
           (xexpr-attributes value))])
    (if attribute
        (cadr attribute)
        default)))

(define (xexpr-children value)
  (if (not (xexpr-element? value))
      '()
      (let ([rest (cdr value)])
        (cond
          [(null? rest) '()]
          [(xexpr-attribute-list? (car rest)) (cdr rest)]
          [else rest]))))

(define (xexpr-named-element? value name)
  (and (xexpr-element? value)
       (string=? (xexpr-local-name (car value))
                 (string-downcase name))))

(define (xexpr-child-elements value name)
  (for/list ([child (in-list (xexpr-children value))]
             #:when (xexpr-named-element? child name))
    child))

(define (xexpr-child-element value name [default #f])
  (let ([elements (xexpr-child-elements value name)])
    (if (pair? elements)
        (car elements)
        default)))

(define (xexpr-content-text value)
  (cond
    [(string? value) value]
    [(xexpr-element? value)
     (apply string-append
            (map xexpr-content-text (xexpr-children value)))]
    [else ""]))

(define (xexpr-text value [default #f])
  (let ([text (string-trim (xexpr-content-text value))])
    (if (string=? text "")
        default
        text)))

(define (xexpr-child-text value name [default #f])
  (let ([child (xexpr-child-element value name #f)])
    (if child
        (xexpr-text child default)
        default)))

(define (xexpr-find-descendant value name [default #f])
  (cond
    [(xexpr-named-element? value name) value]
    [(xexpr-element? value)
     (let loop ([children (xexpr-children value)])
       (cond
         [(null? children) default]
         [else
          (let ([result (xexpr-find-descendant (car children) name #f)])
            (if result
                result
                (loop (cdr children))))]))]
    [else default]))