(import (chicken blob) (chicken format) (chicken io) expat queues srfi-4 test)

(define (read-all-text file-name)
  (call-with-input-file file-name (cut read-string #f <>)))

(define (read-all-bytes-u8vector file-name)
  (call-with-input-file file-name (cut read-u8vector #f <>)))

(define (read-all-bytes-blob file-name)
  (u8vector->blob (call-with-input-file file-name (cut read-u8vector #f <>))))

(define (handle-test-entity parser)
  (let ((eeparser (expat:make-external-entity-parser parser "testentity")))
    (expat:parse eeparser "<blahblah></blahblah>")
    (expat:destroy-parser eeparser)))

(define (handle-test-param-entity parser)
  (let ((eeparser (expat:make-external-entity-parser parser #f)))
    (expat:parse eeparser "<!ENTITY name \"Fred\">")
    (expat:destroy-parser eeparser)))

(define (sexp-from-file file-name)
  (call-with-input-file file-name read))
(define (handler-setup parser)
  (let ((event-queue (make-queue)))
    (expat:set-start-handler!
     parser (lambda (tag attrs)
	      (queue-add! event-queue `(start ,tag ,attrs))))
    (expat:set-end-handler!
     parser (lambda (tag)
	      (queue-add! event-queue `(end ,tag))))
    (expat:set-character-data-handler!
     parser (lambda (text) (queue-add! event-queue text)))
    (expat:set-comment-handler!
     parser (lambda (text) (queue-add! event-queue `(comment ,text))))
    (expat:set-processing-instruction-handler!
     parser
     (lambda (target text)
       (queue-add! event-queue `(processing-instruction ,target ,text))))
    (expat:set-external-entity-ref-handler!
     parser
     (lambda (parser context base sysid pubid)
       (cond
	((and (string? context) (string=? context "testentity"))
	   (handle-test-entity parser))
	((and (not context) (string? sysid) (string=? sysid "test.ent"))
	   (handle-test-param-entity parser))
	(else
	 (queue-add!
	  event-queue
	  (list 'external-entity-ref context base sysid pubid))))
       0))
    event-queue))

(define (parse-xml-file file-name #!key
			(encoding #f) (reader read-all-text) (namespaces #f)
			(namespace-separator #\:) (external-entities #f))
  (let*
      ((parser (expat:make-parser
		encoding: encoding namespaces: namespaces
		namespace-separator: namespace-separator))
       (queue (handler-setup parser)))
    (expat:parse
     parser (reader file-name) external-entities: external-entities)
    (expat:destroy-parser parser)
    (queue->list queue)))

(test
 "exercise handlers"
 (sexp-from-file "results/sample-rdf.sexp")
 (parse-xml-file "data/sample.rdf"))

(test
 "parsing with namespaces"
 (sexp-from-file "results/sample-rdf-with-namespaces.sexp")
 (parse-xml-file "data/sample.rdf" namespaces: #t))

(test
 "parsing with an encoding"
 (sexp-from-file "results/latin1.sexp")
 (parse-xml-file "data/latin1.xml" encoding: "ISO-8859-1"))

(test
 "UTF-16 as u8vector"
 (sexp-from-file "results/latin1.sexp")
 (parse-xml-file "data/utf16.xml" encoding: "UTF-16" reader: read-all-bytes-u8vector))

(test
 "UTF-16 as blob"
 (sexp-from-file "results/latin1.sexp")
 (parse-xml-file "data/utf16.xml" encoding: "UTF-16" reader: read-all-bytes-blob))

(test
 "entity handling"
 (sexp-from-file "results/entities.sexp")
 (parse-xml-file "data/entities.xml"))

(test
 "default external parameter entity handling"
 (sexp-from-file "results/external-parameter-entities.sexp")
 (parse-xml-file "data/external-parameter-entities.xml"))

(test
 "external parameter entity handling set to 'always"
 (sexp-from-file "results/external-parameter-entities-expanded.sexp")
 (parse-xml-file
  "data/external-parameter-entities.xml"
  external-entities: 'always))

(test-error
 "'unless-standalone for standalone document"
 (parse-xml-file
  "data/external-parameter-entities-standalone.xml"
  external-entities: 'unless-standalone))

(test
 "'unless-standalone when document not standalone"
 (sexp-from-file "results/external-parameter-entities-expanded.sexp")
 (parse-xml-file
  "data/external-parameter-entities.xml"
  external-entities: 'unless-standalone))

(unless (zero? (test-failure-count))
  (print "=====")
  (printf "===== ~a ~a failed!\n"
          (test-failure-count)
          (if (> (test-failure-count) 1) "tests" "test"))
  (print "====="))
(test-exit)