(in-package "KPML")

;; File: write-xml-lexicon.lisp
;; Dec 2002, John Bateman, experimental.

  ;; ----------------------------------------------------------------------
  ;; The version of the following function is essentially the same as
  ;; the version in kpml-resource-maintanance just to get the feel of
  ;; writing the XML files out... Some of the standard output functions
  ;; are extended so that they have an XML mode, which is only used here
  ;; at present.

(defun WRITE-LEXICAL-ITEMS-XML 
	(lg-root-directory lexitem-list
			   &key 
			   (ml nil)
			   (lg-specified nil)
			   (ls curlan))
	
    (let ((lexitem-source-files nil)
	  (path (if (pathnamep lg-root-directory) lg-root-directory
		  (pathname lg-root-directory)))
	  (display-mode (if ml :multilingual :monolingual))
	  (language-set (if ml *languages-in-focus* ls))
	  (unassociateds? nil)
	  (lexitem-file-pairs (make-hash-table :size (length lexitem-list))))
    
    (loop for lexitem in lexitem-list 
          do
	  (if (let ((source (lexical-item-source-file 
			     (gethash lexitem lexicon))))
		(and source
		     (not (and (stringp source)
			       (string= source "")))))
	      (let ((file 
		     (pick-a-source-lexicon-file lexitem ml language-set)))
                ;; 2.1 under LW4.0 the following can somehow be met... not sure how or why...
                (if (string= (file-namestring file) "")
                    (setf unassociateds? T)
                  (progn
		    (setf (gethash lexitem lexitem-file-pairs) file)
		    (pushnew file lexitem-source-files :test #'equal))))
            (setf unassociateds? T)))
    (loop for source-file in lexitem-source-files 
          do
	  (with-open-file (stream (merge-pathnames 
				   (xmlify-namestring source-file)
				   (merge-pathnames 
				    (concatenate 'string 
						 "Lexicons"
						 (string *directory-delimiter*))
				    path))
				  :direction :output :if-exists :new-version)
			  (print-mode-and-copyright stream :mode :xml)
			  (format stream "<kpmlLexicon>")
			  (unless (eq display-mode :multilingual)
			    (if lg-specified
				(format stream 
					"<lexical-decl languages=~S/>" lg-specified)))
			  (systemic-display-items 
			   lexitem-list
			   :test #'(lambda (item)
				     (equal 
				      (gethash item lexitem-file-pairs)
				      source-file))
			   :object-type :lexeme 
			   :stream stream
			   :mode :xml                     ;; 4.0
			   :display-mode display-mode
			   :languages language-set)
			  (format stream "</kpmlLexicon>")))
    (when unassociateds?
	  (with-open-file 
	   (stream (merge-pathnames 
		    "lexicon.xml" 
		    (merge-pathnames 
		     (concatenate 'string "Lexicons" 
				  (string *directory-delimiter*))
		     path))
		   :direction :output :if-exists :append
		   :if-does-not-exist :create)
	   (print-mode-and-copyright stream :mode :xml)
	   (format stream "<kpmlLexicon>")
	   (unless (eq display-mode :multilingual)
	     (when lg-specified
	       (format stream 
		       "<lexical-decl languages=~S/>" lg-specified)))
	   (systemic-display-items 
	    lexitem-list
	    :test #'(lambda (item) 
		      (null (gethash item lexitem-file-pairs)))
	    :object-type :lexeme
	    :mode :xml                                     ;; 4.0
	    :stream stream :display-mode display-mode 
	    :languages language-set)
	   (format stream "</kpmlLexicon>")
    ))))


  ;; ----------------------------------------------------------------------
  ;; And the actual work gets done here... This function takes a 
  ;; list representation of the linguistic object to be printed
  ;; and does so, to standard output... which by this time must
  ;; have been rebound to the destination stream...
  ;;
  ;; The lexical item is represented as a list of keys and values.
  ;; This is because it may have been created dynamically on the
  ;; fly as a consequence of particular language focuses and
  ;; multilinguality. It need not now correspond to any actual
  ;; complete linguistic object as stored internally. We
  ;; avoid recreating an actual linguistic object by transforming
  ;; the list directly into an XML form without bothering to
  ;; do much processing to see what it really is.
  ;;
  ;; Somewhat sneakily, this code is based on that of 
  ;; NONANSI-PPRINT-LINGUISTIC-OBJECT-IN-LIST-FORM in display/nonansi-pretty.lisp
  ;;
(defun PRINT-XML-LINGUISTIC-OBJECT (list language-set multilingual-mode)
  (declare (ignore language-set))
  (let ((object-type (pop list))
	(slot-type nil)
	(slot-value nil)
	(lg-restrictions (extract-lg-restrictions list))
	(name-slot (loop for i on list 
			 when (equal (car i) :name)
			 return (cadr i))))

    (format T "  <~A name=\"~A\">" 
	    object-type (first (last name-slot)))
    
    (loop named L
	  while list
	  do (setf slot-type (pop list))
	     (setf slot-value (pop list))
	     (unless (or (null slot-value)
			 (and (stringp slot-value)(string= slot-value ""))
			 (equal slot-type :source-file)
			 (member slot-type *shadowed-slots*))
	  
	       (format t "~%   <~A>" slot-type)
	       (case slot-type
		     (:name nil)
		     (:features
		      (format t "~{     ~%<feature>~A</feature>~}" slot-value))
		     (:properties
		      (format t "~{     ~%<property>~A</property>~}" slot-value))
		     (otherwise
		      (format T "~A" slot-value)))
	       (format t "   </~A>" slot-type)
	       (format T "~%")))
  
  (format T "</~S>" object-type)
  ))


  ;; ----------------------------------------------------------------------
  ;; A utility to make sure that our new XML files do not destroy our
  ;; old lexicon files...
  ;;
(defun XMLIFY-NAMESTRING (source-file) 
  (concatenate 'string 
	       (subseq n 
		       0 
		       (1+ (position #\. 
				     (file-namestring source-file) 
				     :from-end T)))
	       "xml"))