;;; -*- mode: fi:common-lisp; package: :garnet-gadgets -*-

;;; Copyright 1992 Russell G. Almond and Statistical Sciences

;;; This code is in the Public Domain.  Anyone who can get some use
;;; from it is welcome.
;;; This code come with no warentee, although I will be happy to
;;; answer questions via email:  almond@statsci.com or
;;; almond@stat.washington.edu 
;;;
;;; This code is meant as a contribution to the Garnet software
;;; project.  People interested in garnet should send mail to
;;; garnet@cs.cmu.edu to find out more about it.

#||
Change Log:

8/27/93 RGA Wrapped With-hourglass-Cursor around error handler
            gadgets.  

8/18/93  RGA Fixed bugs related to new version of Garnet and added
	     documentation support.

01/25/93  RGA  Created  modifying from old-protected-eval. so that we can
               add handling for USE-VALUE and STORE-VALUE restarts.

||#

;;; This is a first pass at making some nice garnet macros for
;;; handling conditions (errors) using garnet tools rather than the
;;; ordinary way of handling errors.  There are several reasons for
;;; this:  (1) The interface designer might want to protect the user
;;; from needing to learn the ordinary lisp debugging mechanism,  (2)
;;; the lisp listener window might be hidden so the user is unaware of
;;; the error and (3) the error handling mechanism for background
;;; processes (which are implementation dependent) is implementation
;;; dependent. 
;;;
;;; To this end, I provide two different error handlers:
;;; garnet-error-handler and garnet-user-error-handler.  Both of these
;;; error handlers behave in roughly the same way:
;;;   A special protected-eval-error-gadget pops up displaying the
;;;   error and the context, and gives a number of restart options:
;;;     (1) ABORT --- always present
;;;     (2) DEBUG --- (not given for garnet-user-error-handler)
;;;     (3) CONTINUE --- (if there is one)
;;;  The restart options are presented as a series of buttons, which
;;;  the user selects at a special recursive-error-priority-level.
;;;  The appropriate restart or debugger is then invoked.
;;;
;;; Note that the function garnet-user-error-handler differs from
;;; garnet-error-handler in that it does not allow the user to enter
;;; the debugger (it assumes it would be too confusing or a security
;;; hazard). 
;;;
;;; One way to use these functions would be to wrap the appropriate
;;; form in a handler-bind.  Note that garnet-error-handler takes two
;;; arguments, the context and the condition, while the condition
;;; system only uses one.  Therefore your statement would need to look like.
;;;
;;;(handler-bind ((frobbing-error #,(lambda (condition)
;;;				   (garnet-error-handler "Frobnacating"
;;;							 condition))))
;;;  (frob widget))
;;;
;;; Note that you don't need to use "error" as the condition, if it is
;;; more appropriate, you should use some subclass of error.
;;;
;;; Note that abort will usually abort to the lisp-top-level or some
;;; other system depended value unless you set up a specific
;;; restart-case for abort. 
;;;
;;; In order that you need not learn gritty details about the
;;; internals of the Lisp Condition system, I've set up a couple of
;;; functions and macros which should handle the most common cases.
;;;
;;; (with-garnet-error-handling <context> &body <forms>)
;;; and (with-garnet-user-error-handling) are the simplest.  The first
;;; argument should be a literal string which describes the context
;;; and the rest should be a seris of forms.  All of the forms are
;;; evaluated in the context of the garnet-error-handler (allows
;;; debugs) or the garnet-user-error-handler (doesn't allow debugs). 
;;;
;;; (with-abort &body <forms>) establishes a specific abort restart,
;;; which skips over any unevalated forms and returns the values (nil
;;; :abort). 
;;;
;;; (garnet-protected-eval arg) is a function sort of like eval.
;;; It evaluates <arg> in an environment in which all errors are
;;; handled by garnet-error-handler.  Note that because it is a
;;; function, its arg get evaluated once on the call, the second time
;;; in the context of the error handler.
;;; Some optional keyword arguments control its behavior:
;;;
;;; :default-value --- if this keyword is supplied, it sets up a
;;; continue restart which will return the default value from
;;; garnet-protected-eval.  Note this this will be masked by any local
;;; continue restart (say one that was generated by a call to cerror).
;;;
;;; :allow-debug? --- if true (default) this includes the debug button
;;; of the error gadget.
;;;
;;; :local-abort --- if true (default nil) this sets up a local abort
;;; restart which will return from the garnet-protected-eval the values
;;; <abort-value> and t. 
;;; :abort-value --- This is the value returned from the local abort
;;; (if :local-abort is t)
;;;
;;; The second function which is mostly similar to read-from-string is
;;; garnet-protected-read-from-string.  This takes a string argument
;;; (which will usually be a value from a text input gadget) and
;;; number of keywords which control its behavior:
;;;
;;; :start, :end --- Selects appropriate substring
;;;
;;; :read-package --- (default (find-package :user))
;;; If supplied this argument should be a package, it controls the
;;; package in which the reading will be done.  (With background
;;; processes, and complicated package structures, I don't want to
;;; make any assumptions here.)
;;;
;;; :read-bindings --- (default nil) Allows local bindings of
;;; variables during read for special effects, especially *readtable*
;;; and the like.  For example:  
;;; (garnet-protected-eval-from-string (g-value gagdet :value)
;;;    :read-bindings ((*readtable* *special-readtable*)))
;;; would be a way to use *special-readtable* to read from the string.
;;;
;;; :default-value --- (default nil) Same as above, only ALWAYS sets
;;; up continue restart.
;;;
;;; :allow-debug? --- (default nil) Same as above, different default.
;;;
;;; :local-abort, :abort-value --- same as above.
;;;
;;; Hopefully, these functions will save you the pain of establishing
;;; specific error handlers for your program, instead allowing you to
;;; simply call (error) and (cerror) from within the protected forms.
;;; Needless to say, these functions rather rely on your lisp
;;; implementing enough of the Common Lisp error system to make them
;;; work.
;;;
;;; do-abort ---
;;;
;;; When I started writing this I rather assumed that there would
;;; always be a restart named abort which would restart you at the top
;;; level.  Thus calling (abort) would get you back to the top level
;;; if nothing else was done.  This was rather naive on my part.
;;; Therefore I've implemented the function do-abort which works as
;;; follows:  (1) If there is a restart named abort, use it.  (2) If
;;; not, do something system dependent which will return you to the
;;; top level, or the main event loop or whatever.  (3) If you can't
;;; figure out how to do that, call (abort) anyway and generate an
;;; error.  
;;; I've put in a patch which works for Allegro 4.1.  You'll need to
;;; fix this for other versions of lisp.

;;; 

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

(export '(garnet-error-handler garnet-user-error-hander
	  with-garnet-error-handling with-garnet-user-error-handling
	  garnet-protected-eval garnet-protected-read-from-string
	  garnet-protected-read do-prompt error-prompter-gadget
	  with-normal-cursor *normal-cursor-pair*
	  ))



;;; Assumes garnet loader already loaded.

(defvar *normal-cursor-pair* (cons opal:Arrow-Cursor  opal:arrow-Cursor-Mask)
  "Cursor Pair for normal display (active input)")


(defmacro with-normal-cursor (&body forms)
  "Execute body with Garnet cursor set to Arrow."
  `(opal:with-Cursor *normal-cursor-pair* ,@forms))


(defun garnet-error-handler (context condition &key (allow-debugger t))
  (declare (type String context)
	   (type Condition condition))
  "Handles an error by generating a Garnet error widget and prompting
for abort, debug or continue.  Note that this function takes two
arguments, while hanlers are usually meant to take one.  It should be
invoked with (handler-bind ((error #'(lambda (condition)
                                       (garnet-error-handler context-string
                                                             condition))))
               ...)  or the like.

The keyword :allow-debugger controls whether or not the user is given
the option of invoking the debugger.
"
  (let* ((continue-restart (find-restart 'continue))
	 (store-restart (find-restart 'store-value))
	 (use-restart (find-restart 'use-value))
	 (option-list '((:Abort "Stop calculations (return to top level)")))
	 (option nil))
    (when allow-debugger
      (setq option-list (cons '(:Debug "Invoke LISP debugger.") option-list)))
    (when use-restart
      (setq option-list (cons (list :use-value use-restart) option-list)))
    (when store-restart
      (setq option-list (cons (list :store-value store-restart) option-list)))
    (when continue-restart
      (setq option-list (cons (list :continue continue-restart) option-list)))
    (loop
      (setq option
	(with-normal-cursor
	    (display-query-and-wait
	     PROTECTED-EVAL-ERROR-GADGET
	     (format nil "While ~A~& I generated the error~&~A~&~
                            Options for Handling: ~:{~&~S ~A~}~%"
		     context condition option-list)
	     (mapcar #'car option-list))))
      (case option
	(:ABORT (do-abort))
	(:DEBUG (when allow-debugger (invoke-debugger condition)))
	(t (setq option (find option option-list :key #'car))
	   (if option
	       (invoke-restart-interactively (cadr option))))))))



(defun garnet-user-error-handler (context condition)
  (declare (type String context)
	   (type Condition condition))
  "Handles an error by generating a Garnet error widget and prompting
for abort, or continue.  Note that this function takes two
arguments, while hanlers are usually meant to take one.  It should be
invoked with (handler-bind ((error #'(lambda (condition)
                                       (garnet-error-handler context-string
                                                             condition))))
               ...)  or the like.
Note that this is like the garnet-error-handler without the option to
continue. 
"
  (garnet-error-handler context condition :allow-debug nil))





(defmacro with-garnet-error-handling (context &body forms)
  "Executes forms in a protected environment where errors are handled
by garnet-error-handler, which creates a widget with options to abort,
debug and (if applicable) continue.

<context> should be a string describing user meaningful context in
which error occured. "
  `(handler-bind ((error ,#'(lambda (condition)
			      (garnet-error-handler context condition))))
     ,.forms))

(defmacro with-garnet-user-error-handling (context &body forms)
  "Executes forms in a protected environment where errors are handled
by garnet-user-error-handler, which creates a widget with options to
abort and (if applicable) continue (no debug option).  

<context> should be a string describing user meaningful context in
which error occured."
  `(handler-bind ((error ,#'(lambda (condition)
			      (garnet-error-handler context condition
						    :allow-debugger nil))))
     ,.forms))




(defun garnet-protected-eval (form &key (default-value nil dv?)
					(context (format nil
							 "Evaluating ~S"
							 form))
					(allow-debug t)
					(local-abort nil)
					(abort-val nil))
  "This macro executes a form in an environment where errors are
caught and handled by a special garnet-protected-error gadget.  This
gadget prints the error message and allows for three different
restarts:  ABORT, DEBUG and CONTINUE.

<form> is the form to be evaluated.
<default-value> if supplied, produces a continue restart which returns
that value.

If <local-abort> is true (default nil), then a local restart is
established for abort which returns (values <abort-val> :abort)
where <abort-val> is another parameter.

If <allow-debug> is nil (defaul t) then the debug switch is
suppressed.

<context> is a string defining the context of the error.  Default
value is `Evaluating <form>'.
"

  (let* ((handler-function
	  #'(lambda (condition)
	      (garnet-error-handler context condition
				    :allow-debugger allow-debug)))
	 (handled-form `(handler-bind ((error ,handler-function))
			  ,form)))
    (when dv?
      (setq handled-form
	`(restart-case ,handled-form
	   (continue ()
	     :report (lambda (s)
		       (format s "Return value ~S" ,default-value))
	     ,default-value))))
    (when local-abort
      (setq handled-form
	`(restart-case ,handled-form
	   (abort ()
	     :report (lambda (s)
		       (format s "Abort and return value ~S" ,abort-val))
	     (values ,abort-val :abort)))))
    (eval handled-form)))


					       

(defun garnet-protected-read-from-string
    (string &key
	    (context (format nil "Parsing ~S" string))
	    (start 0)
	    (end (length string))
	    (read-package (find-package :user))
	    (read-bindings nil)
	    (default-value nil)
	    (allow-debug nil)
	    (local-abort nil)
	    (abort-val nil))
  "This works rather like garnet-protected-eval except it tries to
read from the string.

<string> is the string to be read from (probably the :string of a text
input gadget).

<start> and <end> allow selecting a substring.

<read-package> (default :user) selects the package to read from.  This
is because I don't want to make any assumptions about what the binding
of package will be at eval time especially in a multiprocessed lisp,
and I think this is safer.  If you want the string to be read in a
different package,  you can try using :read-package *package*

<read-bindings> is a list of (var . form)'s as in a let statement.
These bindings are made (with the let) before reading the string to
allow for effects such as binding the readtable.

<default-value> (default nil) this establishes a continue restart
which returns this value.  Note that this is slightly different from
garnet-protected-eval in that it is always available.

<allow-debug> (default nil) if true, this includes a button which
allows  the debugger to be entered on an error.  Note that the default
value is different from garnet-protected-eval.

If <local-abort> is true (default nil), then a local restart is
established for abort which returns (values <abort-val> :abort)
where <abort-val> is another parameter. (Same as
garnet-protected-eval).

"
  (let* ((form `(let ((*package* ,read-package))
		  (let ,read-bindings
		    (read-from-string ,(subseq string start end)))))
	 (handler-function
	  #'(lambda (condition)
	      (garnet-error-handler context condition :allow-debugger allow-debug)))
	 (handled-form
	  `(handler-bind ((error ,handler-function))
	     ,form)))
    (when T
      (setq handled-form
	`(restart-case ,handled-form
	   (continue ()
	     :report (lambda (s)
		       (format s "Return value ~S" ,default-value))
	     ,default-value))))
    (when local-abort
      (setq handled-form
	`(restart-case ,handled-form
	   (abort ()
	     :report (lambda (s)
		       (format s "Return value ~S" ,abort-val))
	     (values ,abort-val :abort)))))
    (eval handled-form)))


(defun garnet-protected-read
    (&optional (stream *query-io*) &key
	    (context (format nil "Reading from ~S" stream))
	    (read-package (find-package :user))
	    (read-bindings nil)
	    (default-value nil)
	    (allow-debug nil)
	    (local-abort nil)
	    (abort-val nil))
  "This works rather like garnet-protected-eval except it tries to
read from a <stream>.

<stream> is the stream to be read from (default *query-io*).

<read-package> (default :user) selects the package to read from.  This
is because I don't want to make any assumptions about what the binding
of package will be at eval time especially in a multiprocessed lisp,
and I think this is safer.  If you want the string to be read in a
different package,  you can try using :read-package *package*

<read-bindings> is a list of (var . form)'s as in a let statement.
These bindings are made (with the let) before reading the string to
allow for effects such as binding the readtable.

<default-value> (default nil) this establishes a continue restart
which returns this value.  Note that this is slightly different from
garnet-protected-eval in that it is always available.

<allow-debug> (default nil) if true, this includes a button which
allows  the debugger to be entered on an error.  Note that the default
value is different from garnet-protected-eval.

If <local-abort> is true (default nil), then a local restart is
established for abort which returns (values <abort-val> :abort)
where <abort-val> is another parameter. (Same as
garnet-protected-eval).

"
  (let* ((form `(let ((*package* ,read-package))
		  (let ,read-bindings
		    (read ,stream))))
	 (handler-function
	  #'(lambda (condition)
	      (garnet-error-handler context condition :allow-debugger allow-debug)))
	 (handled-form
	  `(handler-bind ((error ,handler-function))
	     ,form)))
    (when T
      (setq handled-form
	`(restart-case ,handled-form
	   (continue ()
	     :report (lambda (s)
		       (format s "Return value ~S" ,default-value))
	     ,default-value))))
    (when local-abort
      (setq handled-form
	`(restart-case ,handled-form
	   (abort ()
	     :report (lambda (s)
		       (format s "Return value ~S" ,abort-val))
	     (values ,abort-val :abort)))))
    (eval handled-form)))

(kr:create-instance 'Error-Prompter-Gadget Prompter-Gadget
  #+kr-doc
  (:documenatation
   "A version of the Prompter-Gadget for use with error recovery by
prompting for a value to use/store.")
  (:modal-p T)
  (:beep-p T)
  (:parent-window nil)
  (:window-top (floor opal:*screen-height* 2))
  (:window-left (floor opal:*screen-width* 2)))


(defun do-prompt (prompt &key (local-abort nil)
		      (default-value nil dv?)
		      (abort-val :ABORT)
		      (satisfy-test #'(lambda (obj) T))
		      (eval-input? nil)
		      (allow-eval? (not eval-input?))
		 &aux flag form val test?)
  "Prompts user for an input.  <Prompt> is printed with ~A as a prompt.
If <local-abort> is true a local abort is set up which will return the
values <abort-val> and :ABORT. 
If <default-value> is supplied, a CONTINUE restart is set up which
allows the user to select the default value.

If <eval-input?> is true, then the expression is evaluated before it
is returned; if not, the unevaluated expression is returned.  

The value supplied by the user is passed to <satisfy-test>.  If that
test fails, the user is prompted again."
  (loop 
    (multiple-value-setq (form flag)
      (with-normal-cursor
	  (apply #'Display-prompt-and-Wait Error-Prompter-Gadget
		 (format nil "~A" prompt)
		 :eval? allow-eval?
		 (if dv? (list :default-value default-value) '()))))
    (unless (eq flag :ABORT)
      (if eval-input?
	  (multiple-value-setq (val flag)
	    (apply #'garnet-protected-eval form 
		   :local-abort local-abort :abort-val abort-val
		   (if dv? (list :default-value default-value) '())))
	(setq val form)))
    (if (eq flag :ABORT)
	(if local-abort (return-from do-prompt (values abort-val :ABORT)))
      (progn
	(multiple-value-setq (test? flag)
	  (ignore-errors (funcall satisfy-test val)))
	(if test? (return-from do-prompt (values val :OK))
	  (if (typep flag 'Condition)
	      (with-normal-cursor
		  (display-query-and-wait Protected-Eval-Error-Gadget
		     (format nil "While testing your input, I generated ~@
                             Error: ~A~%"
			     flag)
		     '(:OK)))))))
    (with-normal-cursor
	(display-query-and-wait Protected-Eval-Error-Gadget
				"Bad Input, Try Again~%"
				'(:OK)))))

;;;
;;;----------------------------------------------------------------------
;;; Changes to protected eval gadget.
;;;----------------------------------------------------------------------
					       
(defun prompter-gadget-eval-func (button but-value)
  (declare (ignore but-value))
  (let* ((prompter (g-value button :parent))
	 (val (g-value prompter :value))
	 (+ (g-value prompter :+))
	 (* (g-value prompter :*))
	 - new-val)
    (setq -
      (restart-case
	  (garnet-protected-read-from-string
	   val :read-package (g-value prompter :read-package)
	   :read-bindings (g-value prompter :default-bindings)
	   :default-value (g-value prompter :default-value))
	(abort () :report "Ignore Read/Eval request."
	  (return-from prompter-gadget-eval-func))))
    (setq new-val
      (restart-case
	  (garnet-protected-eval -)
	(abort () :report "Ignore Eval request."
	  (return-from prompter-gadget-eval-func))))
    (s-value prompter :+ -)
    (s-value prompter :* new-val)
    (s-value prompter :value (format nil "~S" new-val))
    (s-value prompter :modified? nil)
    (opal:update (g-value prompter :window))))

(kr:s-value (kr:g-value Prompter-Gadget :eval-but) :selection-function
  #'(lambda (button value)
      (Prompter-Gadget-Eval-Func button value)))

(defun Prompter-Gadget-Sel-Func (button but-value)
  (let* ((window (g-value button :window))
	 (prompter (g-value button :parent))
	 (waiting (g-value prompter :waiting))
	 (value (if (g-value prompter :modified?)
		    (restart-case
			(garnet-protected-read-from-string
			 (g-value prompter :value)
			 :read-package (g-value prompter :read-package)
			 :read-bindings (g-value prompter :read-bindings)
			 :default-value (g-value prompter :default-value))
		      (abort () :report "Abort Input"
			(setq but-value :abort)))
		  (g-value prompter :*))))
    (kr-send prompter :selection-function prompter value but-value)
    (unless (eql but-value :apply)
      (when (schema-p window)		; May have been destroyed by
					; :selection-function! 
	(s-value window :visible NIL)
	(opal:update window))
      )
    (if waiting (inter:interaction-complete (list value but-value)))))


(kr:s-value (kr:g-value Prompter-Gadget :button) :selection-function
  #'(lambda (button value)
      (Prompter-Gadget-Sel-Func button value)))


