(in-package "KPML")

;;; File: xmls-2-spl.lisp
;;; John Bateman, Bremen, December 2004
;;;
;;; Takes the output produced by the simple XML for CL parser
;;; written by Miles Egan (http://common-lisp.net/project/xmls/),
;;; and produces an SPL sexp of the usual KPML variety.
;;; SPLs in XML form should conform to the spl_schema
;;; as released in the XSDs directory of KPML. Validation
;;; is not done here.
;;;
;;; Can either be used for interpreting XML input directly or,
;;; probably more usefully, for standing between XML input over
;;; a socket and the standard KPML code in the KPML-XML-server
;;; configuration.
;;;
;;; The XML parser assumed is:
;;;     XMLS, a simple XML parser for Common Lisp
;;;     http://common-lisp.net/project/xmls/
;;;     mailto:miles@caddr.com
;;;     1.2
;;;     Copyright (c) 2003, Miles Egan
;;;
;;; This has the advantage of being extremely lightweight and so
;;; unproblematic for our different Lisp varieties.
;;;
;;; Example taken from the XMLS documentation webpage:
;;;
;;;    <?xml version="1.0"?>
;;;    <!-- test document -->
;;;    <book title='The Cyberiad'>
;;;      <!-- comment in here -->
;;;      <author xmlns='http://authors'>Stanislaw Lem</author>
;;;      <info:subject xmlns:info='http://bookinfo' rank='1'>
;;;             &quot;Cybernetic Fables&quot;</info:subject>
;;;    </book>
;;;    
;;; Would parse as: 
;;;    ("book" (("title" "The Cyberiad"))
;;;     (("author" . "http://authors") NIL "Stanislaw Lem")
;;;     (("subject" . "http://bookinfo") (("rank" "1")) "\"Cybernetic Fables\""))
;;;
;;; Hence the use of many 'third's below!

(defmacro XMLS-NODE-EQUAL (node string)
  ;;
  ;; make sure namespace qualified and unqualified elements 
  ;; get caught equally as it may not be entirely clear what
  ;; XML form comes over...
  ;;
  `(or (equal (first ,node) ,string)
       (and (consp (first ,node)) (equal (caar ,node) ,string))))

(defun XMLS-NODE-ATTRIB (source attrib)
  (loop for ele in source
    when (xmls-node-equal ele attrib)
    return (third ele)))


  ;; ----------------------------------------------------------------------
  ;; This is the main function. It works fine if we do not have
  ;; inquiries with parameters specified. Then it works if you
  ;; take care what comes in. Does not work with the XML produced
  ;; by KPML for SPLs and examples because this is wrong. It
  ;; uses internal SPL ids for the parameters instead of the
  ;; user-visible SPL variables. It would be best to improve
  ;; the XML structuring here, update the SPL schema, and so
  ;; simplify the code.
  ;; ----------------------------------------------------------------------

(defun XMLS-SEXP-to-SPL (xmls-sexp &key (intern-semantics nil)(intern-elements nil))
  (let ((source (third xmls-sexp))
	(kb-package 
	 (if intern-semantics intern-semantics (kb-package)))
	(ele-package 
	 (if intern-elements intern-elements (find-package "KPML"))))

    (cond ((xmls-node-equal source "spl")
	   (if (equal (xmls-node-attrib source "type") "INQUIRY-RESPONSE")
	       ;;
	       ;; In this case we may have to unpack the inquiry parameters
	       ;; separately. These are buried under the symbol slot...
	       ;; Unfortunately, it is the SPL internal identifiers that
	       ;; are buried, not the symbols that should appear, so although
	       ;; the following gets the structure right, it needs to be
	       ;; reworked so that the correct SPL user symbols appear
	       ;; when dealing with inquiry parameters. Shows this code
	       ;; to be a nasty hack anyway: needs to be redesigned.
	       ;; What comes in sometimes is the following:
	       ;;
	       ;; <spl>
               ;;   <identifier>PRECEDE-Q-4666</identifier>
               ;;   <symbol>(ST27-4667 ET28-4668 NOTPRECEDES)</symbol>
	       ;;   <type>INQUIRY-RESPONSE</type>
	       ;; </spl>
	       ;;
	       ;; which is actually just wrong. So we need to adjust
	       ;; the XML printer for SPL so that we do not get the
	       ;; internal SPL ids here and perhaps even a more appropriate
	       ;; XML structure...
	       ;;
	       (let ((params 
		      (read-from-string
		       (xmls-node-attrib source "symbol"))))
		 (list (butlast params 1)
		       (last params)))
	     ;;
	     ;; otherwise normal recursive descent...
	     ;;
	     (loop for ele in source
	       if (xmls-node-equal ele "symbol")
	       collect (intern (third ele) ele-package)
	       else
	       if (and (xmls-node-equal ele "type")
		       (not (string= (third ele) "NIL")))
	       collect '/ and collect (intern (string-upcase (third ele)) kb-package)
	       else
	       if (xmls-node-equal ele "attributeValuePair")
	       collect (intern (string-upcase (third (third ele))) "KEYWORD") ; role
	       and append 
	       (let ((partial-spl
		      (xmls-sexp-to-spl (fourth ele)                     ; value
					:intern-semantics intern-semantics
					:intern-elements intern-elements
					)))
		 (if (consp partial-spl)
		     (if (= (length partial-spl) 1)
			 partial-spl
		       (if (and (= (length partial-spl) 2)
				(consp (second partial-spl))
				(= (length (second partial-spl)) 1))
			   (list (first partial-spl) (car (second partial-spl)))
			 (list partial-spl)))
		   (list partial-spl))))
	     ))
	  ((xmls-node-equal source "literal")
	   (intern (string-upcase (third source)) ele-package))
	  (t
	   (format t "~%XMLS-2-KPML parse error! : ~S" source)))))

