;;; XDA.el --- Xml Diagnosis Assintant

;; Copyright (C) 2003 MIYASHITA Hisashi

;; Keywords: XML, XML-poly, TpoI, workbench

;; XDA is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XDA is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;; Comment:
;;   XDA does not mean X-ray Diffraction Analysis:-).  It is a part of
;;   a diagnosis system for other XML processing systems like XML-poly, TpoI,
;;   and so on.

(require 'TpoI)

(defvar XDA-message-buffer nil)
(make-variable-buffer-local 'XDA-message-buffer)
(put 'XDA-message-buffer 'permanent-local t)

;; [buffer schema last-tick]
(defvar XDA-schema nil)
(make-variable-buffer-local 'XDA-schema)
(put 'XDA-schema 'permanent-local t)

(defvar XDA-message-target-buffer nil)
(make-variable-buffer-local 'XDA-message-target-buffer)
(put 'XDA-message-target-buffer 'permanent-local t)

(defvar XDA-annotation-overlay nil)
(make-variable-buffer-local 'XDA-annotation-overlay)
(put 'XDA-annotation-overlay 'permanent-local t)

;;;
;;; XDA message
;;;

(defcustom XDA-message-window-lines 5
  "*Message window lines for XDA messsage buffer."
  :group 'XDA
  :type 'integer)

(defcustom XDA-schema-window-lines 7
  "*Message window lines for XDA schama buffer."
  :group 'XDA
  :type 'integer)

(defface XDA-message-error-face
  '((((class color)
      (background dark))
     (:bold t :foreground "black" :background "SeaGreen1"))
    (((class color)
      (background light))
     (:bold t :foreground "black" :background "SeaGreen3"))
    (t (:bold t)))
  "*Face used for showing error message."
  :group 'XDA)

(defvar XDA-message-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map " " 'XDA-message-goto-error)
    map))

(defun XDA-message-mode ()
  (kill-all-local-variables)
  (buffer-disable-undo)
  (setq major-mode 'XDA-message-mode)
  (setq mode-name "XDA-message")
  (setq truncate-lines t)
  (use-local-map XDA-message-mode-map))

(defun XDA-get-message-buffer (buf)
  (save-excursion
    (set-buffer buf)
    (if (and (bufferp XDA-message-buffer)
	     (buffer-live-p XDA-message-buffer))
	XDA-message-buffer
      (setq XDA-message-buffer
	    (get-buffer-create (format "*XDA msg.(%s)*" (buffer-name buf))))
      (let ((mbuf XDA-message-buffer))
	(set-buffer XDA-message-buffer)
	(XDA-message-mode)
	(setq XDA-message-target-buffer buf)
	mbuf))))

(defun XDA-message-goto-error ()
  (interactive)
  (let ((range (get-text-property (point) 'XDA-range))
	(srange (get-text-property (point) 'XDA-schema-range))
	buf win)
    (if (and srange XDA-schema)
	(save-current-buffer
	  (setq buf (or (XML-poly-get-range-buf srange) (aref XDA-schema 0)))
	  (setq win (XDA-show-schema-buffer buf))
	  (set-window-point win (XML-poly-get-range-beg srange))))
    (setq buf (or (XML-poly-get-range-buf range)
		  XDA-message-target-buffer))
    (if (and range (bufferp buf) (buffer-live-p buf))
	(progn
	  (switch-to-buffer-other-window buf)
	  (goto-char (XML-poly-get-range-beg range))))))

(defun XDA-create-message-window (lines)
  (let ((w (selected-window))
	tw hw h)
    (setq tw w
	  h (window-height w)
	  w (next-window w))
    ;; search the highest.
    (while (not (eq tw w))
      (if (> (window-height w) h)
	  (setq h (window-height w)
		hw w))
      (setq w (next-window w)))
    (split-window
     hw
     (max (- h lines 1) window-min-height))
    (next-window hw)))

(defun XDA-show-buffer (target-buf lines)
  (if (bufferp target-buf)
      (let ((pop-up-windows nil)
	    (win (get-buffer-window target-buf))
	    (ow (selected-window)))
	(if win
	    win
	  (save-excursion
	    (setq win (XDA-create-message-window lines))
	    (select-window win)
	    (switch-to-buffer target-buf)
	    (select-window ow)
	    win)))))

(defun XDA-show-message-buffer (buf)
  (XDA-show-buffer (XDA-get-message-buffer buf) XDA-message-window-lines))

(defun XDA-message-set (msg &optional props no-newline)
  (let* ((buf (current-buffer))
	 (mbuf (XDA-get-message-buffer buf))
	 pt1)
    (set-buffer mbuf)
    (setq pt1 (point))
    (insert msg)
    (if props
	(set-text-properties
	 pt1 (point) props))
    (if (not no-newline) (insert "\n"))
    (set-buffer buf)))

(defun XDA-message-clear ()
  (let* ((buf (current-buffer))
	 (mbuf (XDA-get-message-buffer buf)))
    (set-buffer mbuf)
    (erase-buffer)
    (set-buffer buf)))

(defun XDA-error-handler (msg beg end)
  (XDA-message-set
   msg
   (list
    'face 'XDA-message-error-face
    'XDA-range (XML-poly-make-range beg end nil))))

;;;
;;; XDA parsing
;;;

(defun XDA-parse-buffer-internal ()
  (let ((XML-poly-error-handler (function XDA-error-handler))
	(XML-poly-set-text-property t)
	(XML-poly-resolve-reference t)
	parsed)
    (XDA-message-set (format "Start parsing %s." (buffer-file-name)))
    (setq parsed (XML-poly-parse-buffer))
    (XDA-message-set "Parse is completed.")
    parsed))

;;;
;;; XDA schema
;;;

(defun XDA-error-schema-handler (msg dint sint)
  (XDA-message-set
   msg
   (list
    'face 'XDA-message-error-face
    'XDA-range dint
    'XDA-schema-range sint)))

(defun XDA-compile-schema (schema)
  (save-excursion
    (set-buffer (aref schema 0))
    (aset schema 1
	  (TpoI-compile-schema
	   (XDA-parse-buffer-internal)))
    (aset schema 2
	  (buffer-modified-tick))
    schema))

(defun XDA-setup-schema-buffer (buf)
  (let ((xs XDA-schema)
	(mbuf (XDA-get-message-buffer (current-buffer))))
    (save-excursion
      (if xs
	  (progn
	    (aset xs 0 buf))
	(setq xs (vector buf nil 0)))
      (setq XDA-schema xs)
      (set-buffer buf)
      (setq XDA-message-buffer mbuf)
      (setq XDA-schema xs)
      (XDA-compile-schema xs)
      (set-buffer mbuf)
      (setq XDA-schema xs)
      (XDA-show-message-buffer buf))))

(defun XDA-get-schema-buffer (buf)
  (save-excursion
    (set-buffer buf)
    (if XDA-schema
	(aref XDA-schema 0))))

(defun XDA-show-schema-buffer (buf)
  (XDA-show-buffer (XDA-get-schema-buffer buf) XDA-schema-window-lines))

(defun XDA-get-schema (buf)
  (save-current-buffer
    (set-buffer buf)
    (if (not (and XDA-schema
		  (buffer-live-p (aref XDA-schema 0))))
	(error "This document has no schema."))
    (if (> (buffer-modified-tick (aref XDA-schema 0))
	   (aref XDA-schema 2))
	(progn
	  (XDA-message-set "The schema has been modified after the last compilation...")
	  (XDA-compile-schema XDA-schema)))
    (aref XDA-schema 1)))

;;;
;;; XDA-command
;;;

(defun XDA-parse-buffer ()
  (interactive)
  (save-excursion
    (XDA-message-clear)
    (XDA-parse-buffer-internal)
    (XDA-show-message-buffer (current-buffer))))

(defun XDA-set-schema (filename)
  (interactive "fFilename:")
  (XDA-setup-schema-buffer
   (find-file-noselect filename)))

(defun XDA-validate (schema e)
  (let (r ers er)
    (setq r (TpoI-validate-for-element
	     schema e)
	  ers (cdr r)
	  r (car r))
    (if (null r)
	(XDA-message-set "Valid document.")
      (XDA-message-set "Invalid document..."))
    (while ers
      (setq er (car ers)
	    ers (cdr ers))
      (XDA-error-schema-handler
       (TpoI-get-error-message er)
       (TpoI-get-error-document-range er)
       (TpoI-get-error-schema-range er)))
    r))

(defun XDA-validate-buffer ()
  (interactive)
  (let ((schema (XDA-get-schema (current-buffer))))
    (if (null schema)
	(error "Fail to find the appropriate schema for this buffer."))
    (XDA-message-clear)
    (XDA-validate
     schema (XML-poly-get-element (XDA-parse-buffer-internal)))
    (XDA-show-message-buffer (current-buffer))))

(provide 'XDA)

;; XDA.el ends here.