(in-package "XML-PARSER")

;;; File: process-xml-lexicon.lisp
;;; John Bateman, Bremen, November/December 2002
;;;
;;; Provides the first XML utilities for KPML linguistic resources,
;;; using lexicons as an example. Only bothers with monolingual or
;;; pure multilingual resources without language conditionalization
;;; within expressions.  Can be extended if there is demand.
;;;
;;; Relies on the cl-xml modules from James Anderson. The CL-XML
;;; package is distributed under the GNU LESSER GENERAL PUBLIC LICENSE
;;; and is included along with the KPML release files. Users are
;;; asked if they wish to use these facilities on start-up. If
;;; one tries to load this file without the CL-XML package available
;;; it will complain loudly. It takes some effort to ensure that
;;; it will not complain, however, if loaded before KPML has been
;;; loaded--this allows modular loading.
;;;
;;; Basic starting point is a root node that should be the doc-node
;;; object returned from parsing an XML-represented lexicon: i.e., by
;;; calling xml-parser:document-parser on the file or string that
;;; contains the lexicon.

  ;; ----------------------------------------------------------------------
  ;; Utilities...

  ;; --------------------------------------------------
  ;; Following function returns the list of nodes that
  ;; that are of the specified type in the children of
  ;; the current DOM node... Note that type should be
  ;; a string to match with symbol-name
  ;;
(defun COLLECT-CHILDREN-WITH-TYPE (dom-node type)
  (let ((children (children dom-node)))
    (loop for n in children
	  when (and (equal (type-of n) 'elem-node)
		    (equal (symbol-name (name n)) type))
	  collect n)))

  ;; --------------------------------------------------
  ;; Following function collects a list from an XML structure
  ;; (represented as a document node) of the form:
  ;;
  ;;   <listtype>
  ;;        <listelement>element 1</listelement>
  ;;        <listelement>element 2</listelement>
  ;;             ...
  ;;        <listelement>element N</listelement>
  ;;   </listtype>
  ;;
  ;; ignoring any other child nodes that occur in the DOM. 
  ;; If package is set, then the elements are interned as
  ;; symbols in that package, otherwise they are left as
  ;; strings. If we have more than one element of type
  ;; listtype, we concatenate results...
  ;;
(defun COLLECT-LIST-FROM-XML (dom-node listtype listelement package)
  (loop for n 
	in (collect-children-with-type dom-node listtype)
	append
	(loop for le 
	      in (collect-children-with-type n listelement)
	      collect
	      (let ((element (first (children le))))
		(if (stringp package)
		    (intern element (find-package package))
		  element)))))


  ;; ----------------------------------------------------------------------
  ;; We take the language values to be a simple XML attribute value
  ;; as a string, such as "English Japanese". The following takes
  ;; such strings and turns them into lists of keywords such as
  ;; (:english :japanese) as required for language conditionalization.
  ;; A bit hacky... probably a neat and tidy way too... Probably does
  ;; horrible things if it gets horrible XML, but that is what 
  ;; XML document checking is for I guess.
  ;;
(defun STRING-LIST-TO-KEYWORD-LIST (a-string)
  (loop with i = 0 
	for string = a-string then (subseq string i)
	as item = (progn
		    (multiple-value-bind (item end)
					 (read-from-string string nil :eof)
					 (setf i end) 
					 item))
	until (equal item :eof)
	collect (intern (string item) (find-package "KEYWORD"))))

  ;; ----------------------------------------------------------------------
  ;; Processes a lexicon that has been read as an XML spec and is
  ;; represented as a DOM.
  ;;
(defun DOM-LEXICON->KPML (root-node)
  (let* ((lexicon-spec 
	  (first (collect-children-with-type root-node "kpmlLexicon")))
	 (lexicon-decl
	  (first (collect-children-with-type lexicon-spec "lexical-decl")))
	 (languages 
	  (string-list-to-keyword-list
	   (first 
	    (xml-query-data-model:children (first (attributes lexicon-decl))))))
	 (lexicon
	  (first (collect-children-with-type lexicon-spec "lexicon"))))
    (when lexicon
      (loop for l in (collect-children-with-type lexicon "lexical-item")
	    do (process-xml-lexical-entry l languages)))))
  

  ;; ----------------------------------------------------------------------
  ;; Processes the single DOM node that corresponds to a lexical entry
  ;; Expects to know which languages the entry is to hold for. This info
  ;; comes from the lexicon declaration.
  ;;
(defun PROCESS-XML-LEXICAL-ENTRY (dom-lex-entry languages)
  (macrolet ((ccwt (root-node type) 
		   `(let ((n (first (collect-children-with-type ,root-node ,type))))
		      (if n 
			  (let ((cn (children n)))
			    (if (= (length cn) 1) (first cn) cn))
			nil))))

   (funcall (intern "LOAD-ML-LEXICON" (find-package "KPML"))
    `(      
      ;; The name may be more complex if it has language modifications, as can everything --
      ;; but for this first pass we will assume monolingual lexicons without internal
      ;; language conditionalization...
      ;;
      :name ,(append languages
		     (list (intern (first (children (first (attributes dom-lex-entry)))) "KPML")))
      
      ;; The following two features have internal XML structure, as they consist
      ;; of lists of features or properties...
      ;;
      :features ,(collect-list-from-xml dom-lex-entry "features" "feature" "KPML")
      :properties ,(collect-list-from-xml dom-lex-entry "properties" "property" "KPML")      

      ;; Remainder are considered simple...
      ;;
      :spelling ,(ccwt dom-lex-entry "spelling")
      :sample-sentence ,(ccwt dom-lex-entry "sample-sentence")
      :stem ,(ccwt dom-lex-entry "stem")
      :gloss ,(ccwt dom-lex-entry "gloss")
      :translit ,(ccwt dom-lex-entry "translit")
      :comments ,(ccwt dom-lex-entry "comments")
      :editor ,(ccwt dom-lex-entry "editor")
      :date ,(ccwt dom-lex-entry "date")
      :semantics ,(list (ccwt dom-lex-entry "semantics"))

      ;; Following is a real hack... may be better to also record that the
      ;; file was really an XML file in some way. Monitor this for future
      ;; sorting out...
      ;;
      :source-file 
      ,(if (uri (entity-info (document dom-lex-entry)))
	   (pathname (subseq (uri-namestring (uri (entity-info (document dom-lex-entry)))) 7))
	 (symbol-value (find-symbol "*CURRENTLY-USED-FILE*" (find-package "KPML"))))
      ))
))

