(setq *package* 'kxf)
;;============================================================================
;; KXF - Koala XML Form parser
;;============================================================================
;;AUTOLOAD: kxf:parse
;;AUTODOC: kxf:parse "parse a Koala XML Form (kxf) file into nested lists"
;;kxf:parse
;;---------
;;(kxf:parse buffer [:nil-error t] [:filename name] 
;;                  [:keep-whitespace t]
;;                  [:whitespace-keeping-tags taglist]
;;                  [:keep-comments t] [:keep-PIs t] [:keep-DTD t]
;;)
;;
;; Parses a string buffer (or a stream, which will be completly read) 
;; containing a pseudo XML document, and returns a parsed "xnl" tree in memory 
;; in the same form as the sxp package
;;
;; Pseudo-XML form:                         XML form:
;; «tag»                                   <tag/>
;; «tag foo <> bar»                        <tag>foo &lt; &gt; bar</tag>
;; «tag(x=y z="1 2" t='gp') gee»           <tag x='y' y='1 2' t='gp'>gee</tag>
;; «!-- comments» «? PIs»
;; to quote «, », use «-», «+»
;; to quote ', ", use «!» «#» (mnemonic), or «/» «*» (closer on the keypad)
;; »«/tag» ending forms can be used to check nesting
;;     «foo» a very big contents... »«/foo»
;;     ending contents is ignored and can be used for comments
;;     attributes if present must match the starting tag attributes
;; Whitespace around sub-elements are discarded, but you can keep them 
;; by postfixing element name with = (it sets the xml:space attribute to
;; "preserve"), such as 
;;     «pre=(a=b)  I want    white   space!»
;; or by enclosing them in the pseudo node «= »
;;     «x «=   » «y» «z»» keeps space before y, but not between y and z
;; For comfortable use, it is recommended to assign «» to shift-keypad-minus
;; and shift-keypad-plus respectively
;;
;; This code tries to be compatible with the sxp packages, respecting the 
;; same APIs
;;
;; Encodings are raw: either ISO-Latin-1, or UCS2, which can be autodetected 
;; as fields must begin with «<letter> (ISO-Latin-1), \0« (UCS2), «\0 (MS UCS2)

;;For efficiency, we use the global (local to sxp:parse, actually) vars:
;; buffer	parse buffer (string containing the whole XML document)
;; pos		current offset in parse buffer
;; elt          current element (the current end of the states list)
;; cur-chardata current chardata buffer being parsed for elt

;; redefine this to trap bad element name error
;; must advance pos, return the element (or :error to trigger error)
(defvar kxf:bad-tag-hook ()) 

(defun kxf:parse (buffer &key keep-comments keep-PIs keep-DTD 
    nil-error 
    ((filename sxp:filename) ())
    keep-whitespace
    whitespace-keeping-tags
    forest
    ;; for compatibility with sxp:parse, ignored
    entities ignore-entities external-entities 
    notation-parsers notation-default-parser
    &aux
    (pos 0)
    (sxp:keep-whitespace-tags (vector))
    (elt (xnl:new))
  )
  (setq sxp:encoding "ISO-8859-1")      ;sets global var
  (if (not (typep buffer String))	;gobble up FDs if not strings
    (setq buffer (String buffer))
  )
  (dolist (tag whitespace-keeping-tags)
    (put sxp:keep-whitespace-tags (intern tag) t)
  )
  (if nil-error
    (catch 'sxp:Error (kxf:PS-top))
    (kxf:PS-top)
  )
)

;;AUTOLOAD: kxf:load
;;AUTODOC: kxf:load "loads an XML file in KXF form in memory as nested lists"
;; kxf:load
;;---------
;;(kxf:load filename)
;;
;; will just perform a (kxf:parse (open filename))
(defun kxf:load (filename)
  (kxf:parse (open filename) :filename filename)
)

(dohash (var string [
    kxf:re-name "^(([a-zA-Z_:][-a-zA-Z0-9._:\xb7]*)|(/[a-zA-Z_:][-a-zA-Z0-9._:\xb7]*))(=?)"
    kxf:re-pars "^[(][ \t\n\r]*"
    kxf:re-one-space "^[ \t\n\r]"
    kxf:re-spaces "^[ \t\n\r]*"
    kxf:re-onlyspace "^[ \t\n\r]*$"
    kxf:re-next-elt "^[ \t\n\r]*«"
    kxf:re-chardata "^[^«»]+"
    kxf:re-chardata+quote "^([^«»]*)«([-+!#/*])»"
    kxf:re-start-element "^«"
    kxf:re-end-element "^»"
    kxf:re-quoted "^([-+!#/*])»"
    kxf:re-att-name "^([a-zA-Z_:][-a-zA-Z0-9._:\xb7]*)=[ \t\n\r]*"
    kxf:re-att-valn "^([^'\")][^ \t\n\r)]*)[ \t\n\r]*"
    kxf:re-att-valq "^'([^']*)'[ \t\n\r]*"
    kxf:re-att-valQ "^\"([^\"]*)\"[ \t\n\r]*"
    kxf:re-att-end "^[)]"
    kxf:re-comment "^!([^»]*)»"
    kxf:re-comment-full "^!--"
    kxf:re-comment-full-end "^[^»]*(--)»"
    kxf:re-comment-terminated "--$"
    kxf:re-doctype "^(!DOCTYPE[^»]*)»"
    kxf:re-pi "^([?][^»]*)»"
    kxf:re-pi-terminated "[?]$"
    kxf:re-xmldecl "^[?](xml.*)"
    kxf:re-doctype-contents "^!--(DOCTYPE.*)--$"
    kxf:re-EOF "^[ \t\n\r]*$"
    kxf:re-equals "^="
    ])
  (set var (regcomp string))
)
(setq kxf:table-quoted (Hashtable 
    [#\- "«" #\+ "»" #\! "'" #\# "\"" #\/ "'" #\* "\""]))
(defvar xml_space ())

;;============================================================================
;; Parsing
;;============================================================================

(defun kxf:PS-top (&aux tree xml_space)
  (if forest (kxf:PS-chardata)
    (progn
      (while (not tree)
	(if (kxf:re-next-elt buffer pos)
	(setq pos (1 (getn kxf:re-next-elt 0)))
	)
	(if (not (typep (0 (setq tree (kxf:PS-element))) Atom))
	  (progn
	    (if 
	      (kxf:re-xmldecl (0 tree))
	      (sxp:parse-XML-decl (kxf:re-xmldecl 1))

	      (and keep-DTD (kxf:re-doctype-contents (0 tree)))
	      (setq sxp:DTD (+ "<!" (kxf:re-doctype-contents 1) ">"))
	    )
	    (setq tree ())
	  )
	)
      )
      tree
)))

;; starts after «, returns elt
(defun kxf:PS-element (&aux elt (xml_space xml_space))
  (if 
    (kxf:re-name buffer pos) (progn	;name
      (setq elt (xnl:new (intern (kxf:re-name 1))))
      (if (/= "" (kxf:re-name 4)) (progn
	  (4 elt t)                       ; mark elt as no-indent
	  (xnl:set-attribute elt :xml:space "preserve")
	  (setq xml_space t)
	)
      )
      (setq pos (1 (getn kxf:re-name 0)))
      (if (kxf:re-pars buffer pos) (progn	;attributes
	  (setq pos (1 (getn kxf:re-pars 0)))
	  (put elt xnl:attributes (kxf:PS-attributes))
      ))
      (if (xnl:get-attribute elt :xml:space)
	(if (= "preserve" (xnl:get-attribute elt :xml:space))
	  (setq xml_space "preserve")
	  (= "default" (xnl:get-attribute elt :xml:space))
	  (setq xml_space ())
	  t
	  (error 'sxp:E:BadXmlSpace (xnl:get-attribute elt :xml:space))
      ))
      (if xml_space (4 elt t))

      (if (kxf:re-one-space buffer pos)	;skip first space
	(incf pos)
      )
      (put elt xnl:children (kxf:PS-chardata elt)) ;contents
      elt
    )
    ;; quote-whitespace: «= ....»
    (kxf:re-equals buffer pos) (progn
      (setq elt (xnl:new '=))
      (setq  xml_space t)
      (incf pos)
      (if (kxf:re-one-space buffer pos)	;skip first space
	(incf pos)
      )
      (put elt xnl:children (kxf:PS-chardata))			;contents
      elt
    )
    ;; comments, full form «!-- ... --»
    (and (kxf:re-comment-full buffer pos) 
      (kxf:re-comment-full-end buffer (+ pos 3))
    )
    (with (comment (subseq buffer pos (1 (getn kxf:re-comment-full-end 1))))
      (setq pos (1 (getn kxf:re-comment-full-end 0)))
      (xnl:new comment)
    )
    ;; comments, abbreviated form «! ... »
    (kxf:re-comment buffer pos) (with (comment (kxf:re-comment 1))
      (setq pos (1 (getn kxf:re-comment 0)))
      (xnl:new (+ "!--"
	  (kxf:terminate comment kxf:re-comment-terminated "--")))
    )
    ;; pis
    (kxf:re-pi buffer pos) (progn
      (setq pos (1 (getn kxf:re-pi 0)))
      (xnl:new (kxf:terminate (kxf:re-pi 1) kxf:re-pi-terminated "?"))
    )
    (kxf:re-EOF buffer pos)
    ()
    ;; DTD
    (kxf:re-doctype buffer pos) (with (dtd (kxf:re-doctype 1))
      (setq pos (1 (getn kxf:re-doctype 0)))
      (if keep-DTD 
	(setq sxp:DTD (+ "<" dtd ">"))
      )
      (xnl:new dtd)
    )
    ;; TODO: PI, comments
    ;; not a name? confused
    (with (err ())
      (if (and kxf:bad-tag-hook (/= :error (setq err (kxf:bad-tag-hook))))
	err
	(sxp:fatal-error sxp:E:BadElementName 
	  (sxp:find-potential-name buffer pos))
  )))
)

;; starts in contents, stops after », returns children list
(defun kxf:PS-chardata (&optional elt &aux 
    (start-positions (vector)) ; pos at start of each child
    (children (vector))
    (in-contents? t)
    start-position
    child
  )
  (while in-contents?
    (setq start-position pos)
    (if (kxf:re-chardata+quote buffer pos) (progn
	(setq pos (1 (getn kxf:re-chardata+quote 0)))
	(with (cdata (+ (kxf:re-chardata+quote 1)
	      (kxf:unquote-symbol (kxf:re-chardata+quote 2))
	  ))
	  (while (kxf:re-chardata+quote buffer pos)
	    (nconc cdata (kxf:re-chardata+quote 1) 
	      (kxf:unquote-symbol (kxf:re-chardata+quote 2))
	    )
	    (setq pos (1 (getn kxf:re-chardata+quote 0)))
	  )
	  (if (kxf:re-chardata buffer pos) (progn
	      (nconc cdata (kxf:re-chardata 0))
	      (setq pos (1 (getn kxf:re-chardata 0)))
	  ))
	  (kxf:append-child children cdata)
      ))
      (kxf:re-chardata buffer pos) (progn
	(setq pos (1 (getn kxf:re-chardata 0)))
	(kxf:append-child children (kxf:re-chardata 0))
      )
      (kxf:re-start-element buffer pos) (progn
	(incf pos)
	(kxf:append-child children (kxf:PS-element))
      )
      (kxf:re-end-element buffer pos) (progn
	(incf pos)
	(setq in-contents? ())
      )
      ;; EOF
      (setq in-contents? ())
  ))
  children
)

;; starts after (, returns attlist
(defun kxf:PS-attributes (&aux
    (in-attributes? t)
    (attlist (vector))
    var val
  )
  (while (kxf:re-att-name buffer pos)
    (setq pos (1 (getn kxf:re-att-name 0)))
    (setq val (if
	(kxf:re-att-valn buffer pos) (progn
	  (setq pos (1 (getn kxf:re-att-valn 0)))
	  (kxf:unquote (kxf:re-att-valn 1))
	)
	(kxf:re-att-valq buffer pos) (progn
	  (setq pos (1 (getn kxf:re-att-valq 0)))
	  (kxf:unquote (kxf:re-att-valq 1))
	)
	(kxf:re-att-valQ buffer pos) (progn
	  (setq pos (1 (getn kxf:re-att-valQ 0)))
	  (kxf:unquote (kxf:re-att-valQ 1))
	)
	""
    ))
    (setq var (intern (+ ":" (kxf:re-att-name 1))))
    (put attlist var val)
  )
  ;;must be ), else complain. EOF?
  (if (kxf:re-att-end buffer pos)
    (incf pos)
    (sxp:fatal-error sxp:E:UnterminatedAttribute var)
  )
  attlist
)

;; We concatenate jointive strings
(defun kxf:append-child (children c)
  (if (typep c String)
    ;; we add a string
    ;; ignore whitespace
    (if (and (not xml_space) (kxf:re-onlyspace c)) ()
      (if children
	(if (typep (getn children -1) String)
	  (put children (- (length children) 1) (+ (getn children -1) c))
	  (kxf:append-c)
	)
	(kxf:append-c)
    ))
    ;;we add an element
    (if (= '= (xnl:name c)) (progn ;expand verbatim nodes 
	(if elt (4 elt t))
	(with (xml_space t)
	  (dolist (subchild (xnl:children c))
	    (kxf:append-child children subchild)
      )))
      (= #\/ (0 (xnl:name c))) ; ignore «/tag» closing forms, but check nesting
      (with (previous-child (getn children -1))
	(if (and previous-child (typep previous-child String)
	    (kxf:re-onlyspace previous-child) ; ignore space between » and «
	  )
	  (setq previous-child (getn children (- (length children) 2)))
	)
	(if (not (and 
	      previous-child
	      (typep previous-child Vector)
	      (= (String (xnl:name previous-child)) (subseq (xnl:name c) 1))
	      (kxf:match-attributes 
		(xnl:attributes c) (xnl:attributes previous-child))
	  ))
	  (sxp:fatal-error sxp:E:EndTagDontMatch 
	    (xnl:name previous-child) (subseq (xnl:name c) 1)
	    (sxp:line-of-pos 
	      (kxf:previous-pos children previous-child start-positions))
	    (1 sxp:line-or-col-of-pos-result)
      )))
      (kxf:append-c)
)))

(defun kxf:append-c ()
  (lappend start-positions start-position)
  (lappend children c)
)

(defun kxf:previous-pos (children previous-child start-positions &aux (i 0))
  (catch 'Found
    (dolist (c children)
      (if (eq c previous-child) (throw 'Found (i start-positions)))
      (incf i)
    )
    0
  )
)

(defun kxf:match-attributes (end-atts start-atts &aux (ok t))
  (dohash (attname attval end-atts)
    (if (/= (getn start-atts attname) attval)
      (setq ok ())
  ))
  ok
)

;;============================================================================
;; Utils
;;============================================================================

(defun kxf:terminate (string re addon)
  (if (re string) 
    string
    (+ string addon)
))

;; quoting/unquoting: warning, modifies in place
(setq kxf:unquote-re (regcomp "«(-|[+]|!|#|[/]|[*])»"))
(defun kxf:unquote (s)
  (replace-string s kxf:unquote-re 
    ["«-»" "«" "«+»" "»" "«!»" "'" "«#»" "\"" "«/»" "'" "«*»" "\""]
    :all t :quote t
))
(defun kxf:unquote-symbol (s)
  (get ["-" "«" "+" "»" "!" "'" "#" "\"" "/" "'" "*" "\""] s "")
)
(defun kxf:quote-body (s)
  (replace-string s {regcomp "«|»"} ["«" "«-»" "»" "«+»"] :all t :quote t)
)
(defun kxf:quote-att (s)
  (replace-string s {regcomp "\""} "«*»" :all t :quote t)
)

;;AUTOLOAD: kxf:parse-hook
;;AUTODOC: kxf:parse-hook "parse an XML or a pseudo XML file into nested lists"
;; wraper to do a kxf or sxp parse depending on the first char
(defun kxf:parse-hook (flag)
  (defvar kxf:parse-sxp sxp:parse)
  (if flag
    (setq sxp:parse kxf:parse-or-sxp)
    (setq sxp:parse kxf:parse-sxp)
)) 

(defun kxf:parse-or-sxp (&rest args &aux 
    (buffer (0 args))
  )
  (if (typep (0 args) Stream)
    (0 args (String (0 args)))
  )
  (if (= #\« (0 (0 args)))
    (apply kxf:parse args)
    (apply kxf:parse-sxp args)
  )
)
  
;;============================================================================
;; Printing
;;============================================================================

;;AUTOLOAD: kxf:print
;;AUTODOC: kxf:print "prints an XML file from nested lists"
;;kxf:print
;;---------
;;(kxf:print tree stream [:forest t])
;;
;; The opposite of kxf:parse: from a nested list representation in memory,
;; outputs an XML representation on the stream (default: standard output)
;;
;; (kxf:print #(book (#(title ("SML reference manual"))) (:format "A5")) ())
;; prints on stdout:
;; "«book(format=A5) «title SML reference manual»»"
;;
;; This representation is pretty-printed and indented, each level being 
;; indented by the redefinable string kxf:print-indent-string
;; (2 spaces by default)
;; Setting kxf:print-indent-string to () will disable any indentation
;; Only nodes without any character data (only subnodes) are indented to not 
;; introduce parasitic white space
;;
;; The lines will be wrapped, if possible, to fit in kxf:width (default 78)
;;
;; WARNING: if sxp:DTD is non empty, its contents will be used to print the 
;; DTD (see kxf:parse)
;;
;; Can be given a forest instead of a node with :forest

(defvar kxf:print-indent-string "  ")
(defvar kxf:width 78)

(defun kxf:print (node stream &key forest &aux
    (level 1)
    (kxf:outcol 0)
    (kxf::print-indent (not kxf:print-indent-string))
  )
  (if (not stream) (setq stream *standard-output*))
  (if sxp:DTD (sxp:print-format-stream "«%0»\n" 
      (subseq sxp:DTD 1 (- (length sxp:DTD) 1))
  ))
  (if forest
    (dolist (subnode node)
      (kxf:print-node subnode stream level)
      (kxf:write-chars-stream "\n")
    )
    (progn
      (kxf:print-node node stream level)
      (kxf:write-chars-stream "\n")
    )
  )
)

(setq kxf:print-node:re-normaltag (regcomp "^[a-zA-Z_:]"))
;; uses the encoding global var
(defun kxf:print-node (node stream level &aux canwrap? pad?)
  (if (typep node String)		;chardata node
    (kxf:print-chardata node stream)
    (xnl:name node)			;normal node
    (if (typep (xnl:name node) Atom)
      (progn
	(kxf:print-format-stream "«%0" (sxp:node-get-name node))
	(if (sxp:node-get-attributes node) (progn
	    (kxf:print-format-stream "(")
	    (dohash (key val (sxp:node-get-attributes node))
	      (with (atts (copy "")
		  att (open atts :type :string :direction :io)
		)
		(print-format att "%1%0=" (subseq key 1)
		  (if pad? " " (progn (setq pad? t) ""))
		)
		(kxf:print-attval val att)
		(if (and (> (+ kxf:outcol (length atts)) kxf:width) canwrap?)
		  (progn
		    (setq canwrap? ())
		    (kxf:write-chars-stream "\n")
		    (dotimes (kxf::dummy level)
		      (kxf:write-chars-stream kxf:print-indent-string)
		    )
		    (kxf:write-chars-stream (subseq atts 1))
		  )
		  (progn
		    (setq canwrap? t)
		    (kxf:write-chars-stream atts)
		))
		(setq atts (copy ""))
		(setq att (open atts :type :string :direction :io))
	    ))
	    (kxf:print-format-stream ")")
	))
	(if (sxp:node-get-children node) (progn
	    (kxf:write-chars-stream " ")
	    (if (or kxf::print-indent
		(sxp:node-has-chardata? node) ;dont indent if chardata
		(4 node)		      ;or node is marked as no-indent
	      )
	      (dolist (child (sxp:node-get-children node))
		(kxf:print-node child stream (+ level 1))
	      )
	    ;; only subnodes? indent
	      (progn
		(kxf:write-chars-stream "\n")
		(dolist (child (sxp:node-get-children node))
		  (dotimes (kxf::dummy level)
		    (kxf:write-chars-stream kxf:print-indent-string)
		  )
		  (kxf:print-node child stream (+ level 1))
		  (kxf:write-chars-stream "\n")
		)
		(dotimes (kxf::dummy (- level 1))
		  (kxf:write-chars-stream kxf:print-indent-string)
		)
	      )
	    )
	    (kxf:print-format-stream "»")
	  )
	  (kxf:write-chars-stream "»")
	)
      )
      (progn ; PI, comments... quote « and »
	(kxf:write-chars-stream "«")
	(kxf:print-chardata (xnl:name node) stream)
	(kxf:write-chars-stream "»")
      )
    )
      ;; else "forest" node: a group (list) of nodes
    (dolist (subnode (xnl:children node))
      (kxf:print-node node stream level)
    )
  )
)

(setq kxf:re-print-chars (regcomp "^[^«»]+"))

(defun kxf:print-chardata (s stream &aux (pos 0))
  (catch 'Done (while t
      (if (regexec kxf:re-print-chars s pos)
	(progn
	  (kxf:print-format-stream "%0" (regsub kxf:re-print-chars 0))
	  (setq pos (1 (getn kxf:re-print-chars 0)))
	)

	(not (getn s pos)) (throw 'Done)

	(= #\« (getn s pos)) (progn 
	  (kxf:print-format-stream "«-»") 
	  (incf pos)
	)
	(= #\» (getn s pos)) (progn 
	  (kxf:print-format-stream "«+»") 
	  (incf pos)
)))))

(setq kxf:re-print-attval-chars (regcomp "^[^\"]+"))
(setq kxf:re-print-attval-chars-n (regcomp "^[^ \t\n\r)]+$"))

(defun kxf:print-attval  (s stream &aux (pos 0))
  (if (kxf:re-print-attval-chars-n s)
    (print-format stream "%0" s)
    (catch 'Done 
      (print-format stream "\"")
      (while t
	(if (regexec kxf:re-print-attval-chars s pos)
	  (progn
	    (print-format stream "%0" (regsub kxf:re-print-attval-chars 0))
	    (setq pos (1 (getn kxf:re-print-attval-chars 0)))
	  )
	  
	  (not (getn s pos)) (throw 'Done (print-format stream "\""))
	  
	  (progn 
	    (print-format stream "«*»")
	    (incf pos)
  )))))
)

;; wrapper to set the current column in kxf:outcol
(setq kxf:kxf:print-format-stream:re (regcomp ".*\n"))
(defun kxf:print-format-stream (fs &rest args &aux out)
  (setq out (apply print-format (+ (list String fs) args)))
  (kxf:write-chars-stream out)
)
(defun kxf:write-chars-stream (out)
  (if (kxf:kxf:print-format-stream:re out)
    (setq kxf:outcol (- (length out)
	(1 (getn kxf:kxf:print-format-stream:re 0))))
    (incf kxf:outcol (length out))
  )
  (write-chars out () stream)
)
