#lang scheme/base
(require xml
         scheme/promise
         scheme/control
         "seq-tools.ss")
(provide (all-defined-out))

;; Misc XML/XHTML/HTML handling routines.


;; Element traversal: map (we don't need fold (yet))

; (display-xml/content (find-element (element-tag? 'body) bts))

(define (element-attribute tag e)
  (prompt
   (for ((a (element-attributes e)))
     (when (equal? tag (attribute-name a))
       (abort (attribute-value a))))
   #f))

;; Depth-first search over elements annotated with paths.  A #f
;; results from handle means to leave the subtree and recurse over its
;; substructure.  Anything else replaces that subtree.

(define (path->type lst) (map element-name lst))
(define path->element car)

;; This maps over a list of paths.  element == (car path)
(define (element-map-path handle top-e)
  (let update ((p (list top-e)))
    (let ((e (car p)))
      (if (not (element? e)) e
          (let ((e+ (handle p))) ;; convert path -> element
            (if e+ e+
                (make-element
                 #f #f
                 (element-name e)
                 (element-attributes e)
                 (map (lambda (e)
                        (update (cons e p)))
                      (element-content e)))))))))

;; Map over elements, in case path info is not needed.
(define (element-map handle top-e)
  (element-map-path (lambda (p) (handle (path->element p))) top-e))

;; Recursive find element/hole
(define (m->match? m)
  (cond
   ((procedure? m) m)
   ((symbol? m) (lambda (e) 
                  (let ((it (element-name e)))
                    ;; (printf "trying ~a\n" it)
                    (equal? m it))))
   (else #f)))
(define (el-match m [rv #f])
  (lambda (e) (and ((m->match? m) e) (or rv e))))
(define (find-element m top-e)
  (find element-map
        (el-match m)
        top-e))
(define (find-hole m top-e)
  (lambda (filler-e)
    (element-map
     (el-match m filler-e)
     top-e)))

(define ((element-tag? tag) e)
  (equal? tag (element-name e)))
(define ((element-div-id? str) e)
  (and ((element-tag? 'div) e)
       (equal? str (element-attribute 'id e))))

;; Get at the text of a text node.
(define (element-string el)
  (pcdata-string (car (element-content el))))

;; Find all elements corresponding to a path type i.e. '(link item channel rss)
(define (select-element-path path-type top-element)
  (for/list ((path (in-map element-map-path top-element))
             #:when (equal? (path->type path) path-type))
            (path->element path)))

;; Find element/attribute
(define (element/attribute-for-each fn top-el)
  (for ((e (in-map element-map top-el)))
    (for ((a (element-attributes e)))
         (fn (element-name e)
             (attribute-name a)
             (attribute-value a)))))