;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: xml-parser; -*-

#|
<DOCUMENTATION>
 <DESCRIPTION>
  immediate serialization macros.
  <p>
  adapted from html-gen.slik. the resemblance remains, but is remote.</p>
  </DESCRIPTION>
 <COPYRIGHT YEAR='2001' AUTHOR='james adam anderson' MARK='(C)'
            href='file://xml/sysdcl.lisp' />
 <CHRONOLOGY>
  <DELTA DATE='20010621' AUTHOR='JAA'>
   new. adapted html-gen to the encoding serialization functions.</DELTA>
  <DELTA DATE='20011219'>*generated-ns-bindings*as a special binding with
   a single global handler;<br />corrections for name instances.</DELTA>
  <DELTA DATE='20020130'>push (string . namespace) pairs only onto the binding stack</DELTA>
  </CHRONOLOGY>
 </DOCUMENTATION>
|#

(in-package "XML-PARSER")

(defGeneric encode-attribute-name-value (name value)
  (:method ((name t) (value null))
           "skip the attribute if the effective value is null"
           nil)
  (:method ((name t) (value t))
           "encode the name - with namspace processing if needed, followed by the the value."
           (encode-char #\space)
           (encode-node name)
           (encode-char #\=)
           (encode-char #\')
           (encode-node value)
           (encode-char #\'))
  (:method ((name t) (encoder function))
           "encode the name - with namspace processing if needed. call the function to encode the value."
           (encode-char #\space)
           (encode-node name)
           (encode-char #\=)
           (encode-char #\')
           (funcall encoder)
           (encode-char #\')))

(defGeneric encode-attribute (datum)
  (:method ((plist list))
           (do ((name (pop plist) (pop plist))
                (value (pop plist) (pop plist)))
               ((null name))
             (encode-attribute-name-value name value)))
  (:method ((datum elem-property-node-interface))
           (encode-char #\space)
           (encode-node datum))
  (:method ((datum function))
           (funcall datum)))


(defmacro xml (tag &rest content)
  "Write a tag with contents, xs.  form can be:
  tag -> name
  tag -> (name . attribute ...)
  name -> a symbol naming an HTML element, like h1. (nb. unquoted is normal)
  attribute -> a symbol naming an attribute with a declare value, 
               like compact.
  attribute -> (name value)
  value -> will be turned into a string and escaped properly.
  nb. intended to be used within an an <code>WITH-XML-WRITER</code>."
  (let* ((need-namespaces nil)
         (tag-name (etypecase tag
                     (string tag)
                     (symbol (progn (setf need-namespaces t) tag))
                     (abstract-name (progn (setf need-namespaces t) tag))
                     (cons (if (and (= (length tag) 2) (eq (car tag) 'quote))
                             (second tag)
                             (if (consp (first tag))
                               (second (first tag))
                               (first tag))))))
	 (attributes (etypecase tag
                       (string nil)
                       (symbol nil)
                       (abstract-name nil)
                       (cons (if (and (= (length tag) 2) (eq (car tag) 'quote))
                               nil (cdr tag)))))
         (namespace-bindings
          (remove nil
                  (mapcar #'(lambda (attr)
                              (when (consp attr)
                                (destructuring-bind (name value) attr
                                  ;; check if a new namespace binding is implied
                                  (etypecase name
                                    (string nil)
                                    ((or symbol abstract-name)
                                     (when (string= (namespace-name (namespace name))
                                                    *xmlns-prefix-namestring*)
                                       (setf need-namespaces t)
                                       (typecase value
                                         ((or string null)
                                          (unless (find-namespace value :if-does-not-exist nil)
                                            (warn "namespace not defined: '~a'" value)))
                                         (t nil))
                                       `(setf *namespace-bindings* (acons ',(local-part name) (find-namespace ,value)
                                                                          *namespace-bindings*))))))))
                          attributes))))
    (flet ((needs-quoting? (v)
             ;; this test applies only to static strings in element content...
             (not (find-if #'(lambda (c) (find c "<>&")) v))))
      (when (symbolp tag-name) (setf tag-name `(quote ,tag-name)))
      `(let (,@(when need-namespaces
                 `((*namespace-bindings* *namespace-bindings*)
                   (*generated-ns-bindings* nil)))
             (*node-level* (1+ *node-level*)))
         ,@namespace-bindings
         (encode-pretty-eol)
         (encode-char #\<)
         (encode-node ,tag-name)
         ,@(when attributes
             (mapcar #'(lambda (attr)
                         (cond ((consp attr)
                                ;; if the attribute is a cons, the form is (name value)
                                (destructuring-bind (name value) attr
                                  (case name
                                    (function `(encode-attribute ,attr))
                                    (t
                                     `(encode-attribute-name-value ',name ,value)))))
                               (t
                                `(encode-attribute ,attr))))
                     attributes))
         ,@(if need-namespaces
            `((when *generated-ns-bindings*
                (encode-generated-ns-bindings *generated-ns-bindings*))))
         ,(if content '(encode-char #\>) '(encode-string " />"))
         ;; if the form is an expression, then presume it is to be included for the side effect
         ;; a string or a symbol is written directly
         ,@(mapcar #'(lambda (form)
                       (if (consp form)
                         form
                         (if (and (stringp form) (not (needs-quoting? form)))
                           `(encode-string ,form)
                           `(encode-node ,form))))
                   content)
         ,@(when content
             `((encode-pretty-eol)
               (encode-string "</")
               (encode-node ,tag-name)
               (encode-string ">")))))))

#|

(with-xml-writer (*trace-output*)
  (xml tag "test 1 2 3"))

(with-xml-writer (*trace-output*)
  (xml "tag" "test 1 2 3"))

(with-xml-writer (*trace-output*)
  (xml ({xhtml}tag ({xmlns}|| "http://www.w3.org/1999/xhtml")) "test 1 2 3"))

(with-xml-writer (*trace-output*)
  (xml ("tag" ({xmlns}|| "http://www.w3.org/1999/xhtml") ("attr" "v1")) "test 1 2 3"))

(flet ((do-the-element (attribute-1 attribute-2 attribute-3)
                       (xml ("tag"
                             ({xmlns}|| "http://www.w3.org/1999/xhtml")
                             #'(lambda () (encode-attribute-name-value "qwer" "asdf"))
                             attribute-1 attribute-2 attribute-3)
                            "a literal string"))
       (do-an-attribute ()
         (encode-attribute-name-value "one" "two"))
       (do-an-attribute-value ()
         (encode-string "generated the string")))
  (with-xml-writer (*trace-output*)
    (do-the-element (list "literalname" "literal value"
                          "nameForGeneratedString" #'do-an-attribute-value)
                    #'do-an-attribute
                    nil)))

(with-xml-writer (*trace-output*)
  (format *xml-writer-stream* "test ~a" 1))


|#
:EOF