;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Implementation

(defmacro named-lambda (name (&rest args) &body body)
  (declare (ignorable name))
  #-(or clisp allegro lispworks)
  `(#+sbcl   sb-int:named-lambda
    #+ccl    ccl::nlambda
    #+ecl    ext::lambda-block
    #+clasp  ext::lambda-block
    #+abcl   system:named-lambda
    #+clisp  function
    #+(or sbcl ccl ecl clasp abcl clisp) ,name
    #-(or sbcl ccl ecl clasp abcl clisp) lambda
    ,args ,@body)
  #+(or clisp allegro)
  `(#+clisp function
    #+allegro named-function
    ,name (lambda ,args ,@body))
  #+lispworks
  `(lambda ,args
     (declare (hcl:lambda-name ,name))
     ,@body))

(defun install-debugger (hook)
  (assert (functionp hook))
  (flet (#+common-lisp
         (make-invoke-hook (hook)
           (assert (functionp hook))
           (named-lambda invoke-hook (condition old-hook)
             (let (*debugger-hook*)
               (funcall hook condition old-hook))))
         #+clisp
         (make-clisp-hook (hook)
           (named-lambda break-driver (continuable &optional condition print-it)
             (declare (ignore continuable print-it))
             (let (*debugger-hook*)
               (with-simple-restart (continue "Continue execution.")
                 (funcall hook condition hook)))))
         #+allegro
         (make-acl-hook (hook)
           (named-lambda break-hook (&rest args)
             (let ((condition (fifth args)))
               (funcall hook condition hook))))
         #+lispworks
         (make-lispworks-hook (hook)
           (list (named-lambda debugger-wrapper (function condition)
                   (declare (ignore function))
                   (funcall hook condition hook)))))
    #+common-lisp (setf *debugger-hook* hook)
    #+sbcl        (setf sb-ext:*invoke-debugger-hook* (make-invoke-hook hook))
    #+ccl         (setf ccl:*break-hook* (make-invoke-hook hook))
    #+ecl         (setf ext:*invoke-debugger-hook* (make-invoke-hook hook))
    #+clasp       (setf ext:*invoke-debugger-hook* (make-invoke-hook hook))
    #+abcl        (setf sys::*invoke-debugger-hook* (make-invoke-hook hook))
    #+clisp       (setf sys::*break-driver* (make-clisp-hook hook))
    #+allegro     (setf excl::*break-hook* (make-acl-hook hook))
    #+lispworks   (setf dbg::*debugger-wrapper-list* (make-lispworks-hook hook))))

(defun call-with-debugger (hook thunk)
  (let (#+common-lisp cl:*debugger-hook*
        #+sbcl        sb-ext:*invoke-debugger-hook*
        #+ccl         ccl:*break-hook*
        #+ecl         ext:*invoke-debugger-hook*
        #+abcl        sys::*invoke-debugger-hook*
        #+clisp       sys::*break-driver*
        #+allegro     excl::*break-hook*
        #+lispworks   dbg::*debugger-wrapper-list*)
    (install-debugger hook)
    (funcall thunk)))

(defmacro with-debugger ((hook) &body body)
  `(call-with-debugger ,hook (lambda () ,@body)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Tests

(defun test-error ()
  (labels ((hook (condition hook)
             (declare (ignore hook))
             (when (and (null *debugger-hook*)
                        (typep condition 'simple-error)
                        (string= "Test 42" (princ-to-string condition)))
               (return-from test-error t))))
    (with-debugger (#'hook)
      (error "Test ~A" 42))))

(defun test-break ()
  (labels ((hook (condition hook)
             (declare (ignore hook))
             (when (and (null *debugger-hook*)
                        (find-restart 'continue condition)
                        (typep condition 'simple-condition)
                        (string= "Test 42" (princ-to-string condition)))
               (return-from test-break t))))
    (with-debugger (#'hook)
      (break "Test ~A" 42))))

(defun test-signal ()
  (labels ((hook (condition hook)
             (declare (ignore hook))
             (when (and (null *debugger-hook*)
                        (find-restart 'continue condition))
               (return-from test-signal t))))
    (with-debugger (#'hook)
      (let ((*break-on-signals* 'error))
        (signal 'simple-error)))))

(defun test-invoke-debugger ()
  (labels ((hook (condition hook)
             (declare (ignore hook))
             (when (and (null *debugger-hook*)
                        (typep condition 'simple-error)
                        (string= "Test 42" (princ-to-string condition)))
               (return-from test-invoke-debugger t))))
    (with-debugger (#'hook)
      (let ((*break-on-signals* 'error))
        (invoke-debugger (make-condition 'simple-error
                                         :format-control "Test ~D"
                                         :format-arguments '(42)))))))

(defun test-trivial-debugger ()
  "Returns T if all tests pass."
  (and (test-error) (test-break) (test-signal) (test-invoke-debugger)))