;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: GARNET-GADGETS; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Error Gadget and Query Gadget Utility file
;;;   This file contains the functions used by both motif- and regular
;;;   error gadgets
#|
============================================================
Change log:
 08/21/91  Brad Myers - fixed race condition in wait-interaction-complete
 08/21/91  Andrew Mickish - Made string parameter to display-* optional
 08/4/92   Brad Myers - inter:beep is optional, and make window visible before
                        calling sub-menu
 06/5/92   Brad Myers - used :modal-p windows instead of error-priority-level
 05/19/92  Brad Myers - Raise window in internal-display-q-or-e
 04/23/92  Ed Pervin - Added schema-p checks to e-q-gadget-sel-func
 04/8/92   Brad Myers - created from error-gadget
============================================================
|#

(in-package "GARNET-GADGETS" :use '("LISP" "KR"))

(defun internal-display-q-or-e (gadget string wait labels)
  ;; Set the message to be displayed
  (s-value gadget :string string)
  ;; Set the label list
  (when (and labels
	     (not (equal labels (g-value gadget :button-names))))
    (s-value gadget :button-names labels)
    ;; notice-items-changed is fairly expensive
    (opal:notice-items-changed (g-value gadget :button)))
  ;; Set up window
  (let ((window (g-value gadget :window)))
    ;; Set the position and dimensions of the window
    (s-value window :left (g-value gadget :window-left))
    (s-value window :top (g-value gadget :window-top))
    (s-value window :width (g-value gadget :window-width))
    (s-value window :height (g-value gadget :window-height))
    (s-value gadget :waiting wait)
    (s-value window :visible T)
    ;; beep if desired
    (when (g-value gadget :beep-p) (inter:beep))
    ;; wait if desired, updating window
    (if wait
	(inter:wait-interaction-complete window) ;; will raise the window
	;; else raise window here
	(opal:raise-window window))))   ;; calls update


(defun DISPLAY-ERROR (error-gadget &optional
		      (string (g-value error-gadget :string)))
  (internal-display-q-or-e error-gadget string NIL NIL))

(defun DISPLAY-ERROR-AND-WAIT (error-gadget &optional
			       (string (g-value error-gadget :string)))
  (internal-display-q-or-e error-gadget string T NIL))

(defun DISPLAY-QUERY (query-gadget &optional
		      (string (g-value query-gadget :string))
		      label-list)
  (internal-display-q-or-e query-gadget string NIL label-list))

(defun DISPLAY-QUERY-AND-WAIT (query-gadget &optional
			       (string (g-value query-gadget :string))
			       label-list)
  (internal-display-q-or-e query-gadget string T label-list))

(defun E-Q-Gadget-Sel-Func (button value)
  (let* ((window (g-value button :window))
	 (error-gadget (g-value button :parent))
	 (waiting (g-value error-gadget :waiting)))
    ;; make this query window go away first, in case selection
    ;; function brings up another window.
    (when (schema-p window)
      (s-value window :visible NIL)
      (opal:update window))
    (kr-send error-gadget :selection-function
	     error-gadget value)
    ;; use stored value in case selection-function destroys the
    ;; error-gadget, still need to get out of the waiting loop.
    (when waiting
      (inter:interaction-complete value))))

(defun Error-Gadget-Destroy (error-gadget &optional erase)
  ;; first, remove the gadget from its window so when the window is
  ;; destroyed, the gadget will not be.  Then destroy the gadget itself
  ;; using call-prototype-method
  (let ((agg (g-value error-gadget :parent))
	(window (g-value error-gadget :window)))
    (when agg
      (opal:remove-component agg error-gadget))
    ;; make sure window isn't already being destroyed
    (when (and window
	       (schema-p window)
	       (gethash (get-local-value window :drawable)
			opal::*drawable-to-window-mapping*))
      (opal:destroy window))
    (call-prototype-method error-gadget erase)))
