;; 
;; sxml-fu - Cool SXML supermoves :)
;; 
;; Copyright (c) 2009-2010 Peter Bex
;;
;;  Redistribution and use in source and binary forms, with or without
;;  modification, are permitted provided that the following conditions
;;  are met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;  notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above
;;  copyright notice, this list of conditions and the following
;;  disclaimer in the documentation and/or other materials provided
;;  with the distribution.
;; 
;;  - Neither name of the copyright holders nor the names of its
;;  contributors may be used to endorse or promote products derived
;;  from this software without specific prior written permission.
;; 
;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;  POSSIBILITY OF SUCH DAMAGE.

(module sxml-fu
  (output-xml output-xml* sxml-fold-rules sxml-fold-rules*
   normal->starred-transformation-rules starred->normal-transformation-rules)

(import chicken scheme)
(use srfi-1 sxml-transforms matchable)

(define (output-xml tree rulesets)
  (SRV:send-reply (sxml-fold-rules tree rulesets)))

(define (output-xml* tree rulesets)
  (SRV:send-reply (sxml-fold-rules* tree rulesets)))

(define (sxml-fold-rules tree rulesets)
  (fold (lambda (ruleset tree) (pre-post-order tree ruleset))
        tree rulesets))

(define (sxml-fold-rules* tree rulesets)
  (fold (lambda (ruleset tree) (pre-post-order* tree ruleset))
        tree rulesets))

(define (traverse-rules/converter rules convert)
  (let lp ((rules rules)
           (result '()))
    (match rules
      (() (reverse result))
      ;; *text* is handled the same, so don't translate it
      ((('*text* . (? procedure? handler)) . rest)
       (lp rest `((*text* . ,handler) . ,result)))
      (((<trigger-symbol> . (? procedure? handler)) . rest)
       (lp rest `((,<trigger-symbol> . ,(convert handler)) . ,result)))
      (((<trigger-symbol> (? symbol? ruletype) . (? procedure? handler)) . rest)
       (lp rest `((,<trigger-symbol> ,ruletype . ,(convert handler)) . ,result)))
      (((<trigger-symbol> (new-bindings ...) . (? procedure? handler)) . rest)
       (let* ((converted-bindings (lp new-bindings '()))
              (converted-rule `(,<trigger-symbol>
                                ,converted-bindings . ,(convert handler))))
         (lp rest `(,converted-rule . ,result))))
      (else (error "Invalid sxml transformation rule" (car rules))))))

(define (normal->starred-transformation-rules rules)
  (traverse-rules/converter rules (lambda (handler)
                                    (lambda (element children)
                                      (apply handler element children)))))

(define (starred->normal-transformation-rules rules)
  (traverse-rules/converter rules (lambda (handler)
                                    (lambda (element . children)
                                      (handler element children)))))

)