;;; debugger.lisp
;;;
;;; Copyright (C) 2008-2009 Alessio Stalla
;;;
;;; This program 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
;;; of the License, or (at your option) any later version.
;;;
;;; This program 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; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module.  An independent module is a module which is not derived from
;;; or based on this library.  If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so.  If you do not wish to do so, delete this
;;; exception statement from your version.

(in-package :snow)

(defvar *graphical-debugger-hook*
  (lambda (condition debugger-hook)
    (declare (ignore debugger-hook))
    (show-snow-debugger condition)))

(defun show-snow-debugger (condition)
  (let* ((restarts (compute-restarts))
	 (list (list-widget
	       :model (make-list-model
		       (mapcar (lambda (restart)
				 (format nil "~A" (restart-name restart)))
			       restarts))))
	 (backtrace (system:backtrace)))
    (dont-add ;;So that the debugger can be invoked when *parent* is not nil
     (dialog (:id dlg :title "Condition signaled" :modal-p t)
       (label
	:layout "wrap"
	:text (format nil
		      "Debugger invoked on condition of type ~A:"
		      (type-of condition)))
       (label :layout "wrap" :text (format nil "~A" condition))
       (label :layout "wrap" :text "Available restarts:")
       (scroll (:layout "grow, wrap") list)
       (panel ()
         (button :text "Ok"
		 :on-action (lambda ()
			      (when
				  (>= (widget-property list :selected-index) 0)
				(dispose dlg))))
	 (button :text "Backtrace"
		 :on-action
		 (lambda ()
		   (dialog (:id dlg :title "Backtrace" :modal-p t)
		     (scroll (:layout "wrap")
                       (list-widget :model (make-list-model backtrace)))
		     (button :text "Ok"
			     :on-action (lambda () (dispose dlg)))
		     (pack dlg)
		     (show dlg))))
	 (button :text "Condition"
		 :on-action
		 (lambda ()
		   (dialog (:id dlg :title "Condition" :modal-p t)
		     (scroll (:layout "wrap")
                       (text-area :text (sys::%format nil "~A" condition)))
		     (button :text "Ok"
			     :on-action (lambda () (dispose dlg)))
		     (pack dlg)
		     (show dlg)))))
       (pack dlg)
       (show dlg))
     (let ((*query-io* (make-dialog-prompt-stream)))
       (when (>= (widget-property list :selected-index) 0)
	 (invoke-restart-interactively
	  (nth (widget-property list :selected-index) restarts)))))))

(defun install-graphical-debugger ()
  (let ((old-debugger-hook *debugger-hook*))
    (setq *debugger-hook* *graphical-debugger-hook*)
    (values *debugger-hook* old-debugger-hook)))

(defun test-graphical-debugger ()
  (let ((*debugger-hook* *debugger-hook*))
    (install-graphical-debugger)
    (eval '(omfg))))