#cs(module stx-engine mzscheme
(require (lib "defmacro.ss"))
(require (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 0)))
(require "sxml-tools.ss")
(require "sxpathlib.ss")
(require "sxpath-ext.ss")
(require "txpath.ss")
(require "sxpath.ss")
(require "libmisc.ss")

;; $Id: stx-engine.scm,v 1.9502 2004/01/22 01:11:45 kl Exp kl $

;=============================================================================
; Auxilliary

(define stx:version 
  (string-append " $Revision: 1.9502 $" nl " $Date: 2004/01/22 01:11:45 $"))

(define (stx:error . messages)
  (cerr nl "STX: ")
  (apply cerr messages)
  (cerr nl)
  (exit -1))


;=============================================================================
; Syntactic sugar

; This macro emulates <xsl:apply-template> of XSLT
; "select" must be a node-set
; If omitted, (sxml:content current-node) is used. 
(define-macro (xsl:apply-templates . select)
  (cond  
    ((null? select)
     `(stx:apply-templates (sxml:content current-node) 
			   stx:templates current-root $))
    ((null? (cdr select))
    `(stx:apply-templates ,(car select) stx:templates current-root $))
    (else (error "Invalid parameters for 'xsl:apply-template': " select))))

;------------------------------------------------------------------------------
; These macros provide support for abbreviated stylesheets:
;
;  <Stylesheet> ::= (stx:stylesheet <Template>+)
;  <Template>   ::= (match <SXPath> <Handler>)
;  <SXPath>     ::= SXPath expression
;  <Handler>    ::= (lambda (current-node stx:templates current-root $) ...)
;
; For example:
;  (stx:stylesheet
;    (match "//element[state/@condition='standard']"
;	   (lambda (current-node stx:templates current-root $)
;	     (sxml:text current-node)))
;    (match (table (tr 4))
;	   (lambda (current-node stx:templates current-root $)
;	     `(ol
;		,@(map
;		    (lambda(x) `(li ,x))
;		,((sxpath '(td *text*)) current-node))))))

(define-syntax  sxml:stylesheet
   (syntax-rules  ()
 		 ((stx rule ...)
		  (list 
		    ; default handler
		    (list '*default* 
			  (lambda (node bindings root environment)
			     (stx:apply-templates (sxml:content node) 
						  bindings 
						  root environment)
			     ))
		    ; handler for textual nodes
		    (list '*text* 
			  (lambda(text) text)) 
		    rule ...))))

(define-syntax  match
   (syntax-rules  ()
 		 ((match pattern handler)
		   (list (if (symbol? pattern) pattern (sxpath pattern))
			   handler))
		 ))


;=============================================================================
; Tree transformation

; stx:apply-templates:: <tree> x <templates> x <root> x <environment> -> <new-tree>
; where
; <templates> ::= <default-template> <text-template> <template>*
; <default-template> ::= (*default* . <handler>)
; <text-template> ::= (*text* . <handler>)
; <template>  ::= (<matcher> <handler>) | ( XMLname <handler>)
; <root>     ::= <document-root>
; <environment> ::= <lambda-tuple>
; <matcher>  ::= <node> <root> -> <nodeset>
; <handler> :: <node> <templates> <root> <environment> -> <new-node>
;
; The stx:apply-templates function visits top-level nodes of a given tree and
; process them in accordance with a list of templates given.
; If a node is a textual one then it is processed usind 'text-template',
; which has to be second element in given list of templates.
; If a node is a pair then stx:apply-templates looks up a corresponding template
; among  given <templates> using stx:find-template function.
; If failed, stx:apply-templates tries to locate a *default* template,
; which has to be first element in given list of templates. It's an
; error if this latter attempt fails as well. 
; Having found a template, its handler is applied to the current node.
; The result of the handler application, which should
; also be a <tree>, replaces the current node in output tree.
;
; This function is slightly similar to Oleg Kiselyov's "pre-post-order" function
; with *preorder* bindings.
(define (stx:apply-templates tree templates root environment)
  (cond
    ((nodeset? tree)
     (map (lambda (a-tree) 
	    (stx:apply-templates a-tree templates root environment)) 
	  tree))
    ((pair? tree) 
     (cond
       (;(tee-4 "Template: "
	(stx:find-template tree 
		      (cddr templates) ; *default* and *text* skipped
		      root);)
	=> (lambda (template) 
	     ((cadr template) tree templates root environment)))
       (else 
	 (if (eq? '*default* (caar templates))
	   ((cadar templates) tree templates root environment)
	   (stx:error "stx:apply-templates: There is no template in: " templates
		      nl "for: " tree
		      )) 
	 )))
    ((string? tree) ; for *text* , simple speed-up - just return 'tree'
	 (if (eq? '*text* (caadr templates))
	   ((cadadr templates) tree)
	   (stx:error "stx:apply-templates: There is no *text* templates for: " 
		      templates))) 
    (else (stx:error "Unexpected type of node: " tree))))

;  stx:find-template: <node> x <templates> x <root> -> <template>
;  This function returns first template in <templates> whouse <matcher>
;  matches given <node>
;  <matcher> matches node if:
;    - if it is a symbol and its the same as the name of the node matched
;    - if it is a procedure (sxpath/txpath generated one) then it is
;     applyed (with respect to given <root>) sequentially to the matched node
;     and its parents until the matched node is a member of a resulting nodeset
;     or root node is reached. In the first case the node matches successfuly,
;     in the second case it does not.
(define (stx:find-template node templates root)
  (let ((pattern-matches? 
	  (lambda (node pattern-test) 
	    (let rpt ((context-node node))
	      (cond 
		((null? context-node) #f)
 ;		((memq node (pattern-test context-node root '()))
		((memq node (pattern-test context-node `((*root* . ,root))))
		 #t)
		(else ; try PARENT
		  (rpt ((sxml:node-parent root) context-node))))))))  
    (let rpt ((bnd templates)) 
      (cond ((null? bnd) #f)
	    ((and (symbol? (caar bnd)) (eq? (caar bnd) (car node)))
	     (car bnd))
	    ((and (procedure? (caar bnd)) ; redundant?
		  (pattern-matches? node (caar bnd)))
	     (car bnd))
	    (else (rpt (cdr bnd)))))))



(provide (all-defined)))