#! /bin/sh 
string=? ; exec mzscheme -M errortrace -gr $0 $* 
; $Id: make-fixture.scm,v 1.2 2004/01/27 04:32:09 kl Exp kl $
; This stylesheet generates a regression test for SXPath 
; using the same SXML data as make-examples.scm
; http://pair.com/lisovsky/query/examples/
; 
; May be considered as an example of STX stylesheet applyed for side effects 
;
; Usage: ./make-fixture.scm >xpath-fixture.scm

(require (lib "sxml-tools.ss" "sxml")
	 (lib "sxpath.ss" "sxml")
	 (lib "stx-engine.ss" "sxml")
	 (lib "sxpathlib.ss" "sxml")
	 (lib "parse-error.ss" "ssax")
	 (lib "myenv.ss" "ssax"))

(define (read-eval-file file-name)
  (eval
    (read-syntax
      file-name
      (port-count-lines
	(open-input-file file-name)))))

; Source document
(define doc (read-eval-file "xpaths.sxml"))
 
(define (list-or-node x)
  (if (eq? 'list (car x))
    (cdr x)
    x))

; Transformation stylesheet
(define sst
(sxml:stylesheet
  (match  'case
	 (lambda (current-node stx:templates current-root $)
	   ; Generate test case 
           (cout nl 
		 nl "; Full: " (sxml:attr current-node 'full)
		 nl "; Abbr: " (sxml:attr current-node 'abbreviated))
	     (cout nl     "(let* ((tree '") 
	     (write (list-or-node ((car-sxpath '((* 1))) current-node)))
	     (cout ")" nl "       (expected '")
	     (write
	       (list-or-node ((car-sxpath '((* 2))) current-node)))
	     (cout "))" nl)
	     (for-each
	       (lambda(t)
		 (cout "(run-test " nl)
		 (if (sxml:attr t 'sxpath)
		   (cout "  (sxpath `" (sxml:text t) ")")
		   (cout "  " (sxml:text t)))
		 (cout nl "  tree expected)" nl))
	       ((sxpath '(test)) current-node))
	     (cout ")" nl)
))
  (match 'samples
	 (lambda (current-node stx:templates current-root $)
	   (cout 
; Header PLT Scheme
"#! /bin/sh 
string=? ; exec mzscheme -M errortrace -gr $0 $* 
(require (lib \"defmacro.ss\")
         (lib \"sxpath.ss\" \"sxml\")
         (lib \"myenv.ss\" \"ssax\")
         (lib \"sxpathlib.ss\" \"sxml\"))

(define-macro (run-test selector node expected-result)
  (let ((res (gensym)))
    `(begin
       (cerr \"\\nApplying \" ',selector \"\\nto \" ,node nl)
       (let ((,res (,selector ,node)))
	 (if (equal? ,res ,expected-result)
	     (cerr \"gave the expected result: \"
		   (lambda (port) (write ,res port)) nl)
	     (begin
	        (cerr \"Unexpected result: \" ,res \"\\nexpected: \"
		    ,expected-result nl)
		(exit -1)))))))
"
	   nl)
(xsl:apply-templates)
(cout nl "(cout nl \"All tests passed!\" nl) (exit)" nl)
))
  )
)

; Apply the stylesheet for side-effects, we are _not_ interested in
; result tree
  (stx:apply-templates
  doc
  sst
  doc
  '())