#!/usr/bin/newlisp

;; @module XML
;; @author Jeff Ober <jeffober@gmail.com>
;; @version 2.0
;; @location http://static.artfulcode.net/newlisp/xml.lsp
;; @description Parsing and serializing of XML data.
;; 
;; <p>Functions to parse XML text (non-validating) and serialize lisp structures to XML.
;; Requires both util.lsp and functional.lsp.</p>
;; 
;; <h4>Version history</h4>
;; <b>2.0</b>
;; &bull; complete rewrite
;; &bull; added XML-compliant entities
;; &bull; automatic serialization of data
;; 
;; <b>1.0</b>
;; &bull; initial release

(context 'Xml)

(setq declaration {<?xml version="1.0" encoding="UTF-8" ?>})

;; @syntax (Xml:entities <str-text> [<int-list-entities>])
;; @param <str-text> text to convert to entities
;; @param <int-list-entities> optional list of code points to convert to entities
;; 
;; <p>Converts any characters in <str-text> whose UTF code point is in <int-list-entities>
;; to ANSI entities.  The default list of chars is '(34 38 39 60 62) (which are quote,
;; ampersand, apostrophe, and left and right carets).  These are the default entities listed
;; in the XML standard.  Any characters that do not match are left untouched.</p>

(define (entities str (entity-set '(34 38 39 60 62)))
  (let ((buff ""))
	(dostring (c str)
	  (if (member c entity-set)
		  (write-buffer buff (format "&#%d;" c))
		  (write-buffer buff (char c))))
	buff))

(define (value val)
  (if val
	  (if (symbol? val)
		  (entities (name val))
		  (entities (string val)))
	  ""))

(define (attribute key val)
  (format "%s=\"%s\""
		  (if (symbol? key) (name key) (string key))
		  (value val)))

(define (attributes pairs)
  (if pairs
	  (join (map (fn (pair) (apply attribute pair)) pairs) " ")
	  ""))

(define (tag-name x)
  (if (symbol? x) (name x) (string x)))

(define (open-tag tag depth attr (prepend-newline true) (empty-tag nil))
  (format "%s%s<%s%s%s>"
		  (if prepend-newline "\n" "")
		  (dup " " depth)
		  (tag-name tag)
		  (if attr (string " " (attributes attr)) "")
		  (if empty-tag " /" "")))

(define (close-tag tag depth (prepend-newline nil))
  (format "%s%s</%s>"
		  (if prepend-newline "\n" "")
		  (dup " " depth)
		  (tag-name tag)))

(define (node (depth 0) data)
  (MAIN:match-with data
	(((tag ? atom?)) (open-tag tag depth nil true true))
	(((tag ? atom?) (attr (@ *)) (val ? atom?))
	 (string (open-tag tag depth attr true nil)
			 (value val)
			 (close-tag tag 0 nil)))
	(((tag ? atom?) (val ? atom?))
	 (string (open-tag tag depth nil true nil)
			 (value val)
			 (close-tag tag 0 nil)))
    (((tag ? atom?) (attr (@ *)) (children *))
	 (string (open-tag tag depth attr true nil)
			 (join (map 'string (map (curry node (+ 1 depth)) children)) "")
			 (close-tag tag depth true)))
	(((tag ? atom?) (children *))
	 (string (open-tag tag depth nil true nil)
			 (join (map 'string (map (curry node (+ 1 depth)) children)) "")
			 (close-tag tag depth true)))))

;; @syntax (Xml:lisp->xml <assoc-data> [<xml-declaration>])
;; @param <assoc-data> nested association list
;; @param <xml-declaration> optional string XML declaration
;; 
;; <p>Attempts to serialize the data in <assoc-data> to a valid XML string.
;; Optional <xml-declaration> is prepended.  The default declaration is
;; <&lt;?xml version="1.0" encoding="UTF-8" ?&gt;>.</p>

(define (Xml:lisp->xml data (decl declaration))
  (format "%s%s" decl (node 0 data)))

;; @syntax (Xml:xml->lisp <str-xml-data>)
;; @param <str-xml-data> XML string
;; 
;; <p>Parses XML string <str-xml-data> and returns a nested association list.</p>

(define (Xml:xml->lisp str)
  (let ((old-xml-type-tags (xml-type-tags)) (res nil))
	(xml-type-tags nil nil nil nil)
	(setq res (first (xml-parse str (+ 1 2 4 16))))
	(apply xml-type-tags old-xml-type-tags)
	res))

(context 'MAIN)