mirror of
https://gitlab.com/eql/lqml.git
synced 2025-12-06 10:31:34 -08:00
59 lines
2.2 KiB
Common Lisp
59 lines
2.2 KiB
Common Lisp
(defpackage :debug-ui
|
|
(:use :cl :qml)
|
|
(:export
|
|
#:*debug-dialog*))
|
|
|
|
(in-package :debug-ui)
|
|
|
|
(defvar *error-output-buffer* (make-string-output-stream))
|
|
(defvar *terminal-out-buffer* (make-string-output-stream))
|
|
(defvar *gui-debug-io* nil)
|
|
(defvar *gui-debug-dialog* nil)
|
|
|
|
(defun ini ()
|
|
(setf *gui-debug-dialog* 'dialogs:debug-dialog)
|
|
(ini-streams)
|
|
(setf *debug-io* *gui-debug-io*))
|
|
|
|
(defun ini-streams ()
|
|
(setf *error-output* (make-broadcast-stream *error-output*
|
|
*error-output-buffer*))
|
|
(setf *terminal-io* (make-two-way-stream (two-way-stream-input-stream *terminal-io*)
|
|
(make-broadcast-stream (two-way-stream-output-stream *terminal-io*)
|
|
*terminal-out-buffer*))
|
|
*gui-debug-io* (make-two-way-stream (input-hook:add 'handle-debug-io)
|
|
(two-way-stream-output-stream *terminal-io*))))
|
|
|
|
(defun clear-buffers ()
|
|
(dolist (s (list *error-output-buffer*
|
|
*terminal-out-buffer*))
|
|
(get-output-stream-string s)))
|
|
|
|
(defun find-quit-restart ()
|
|
;; find best restart for ':q' (default) to exit the debugger
|
|
(let ((restarts (compute-restarts)))
|
|
(if (= 1 (length restarts))
|
|
":r1"
|
|
(let ((restart-names (mapcar (lambda (r)
|
|
(symbol-name (restart-name r)))
|
|
restarts)))
|
|
;; precedence role
|
|
(dolist (name '("RESTART-TOPLEVEL"
|
|
"ABORT"
|
|
"RESTART-QT-EVENTS"))
|
|
(x:when-it (position name restart-names :test 'string=)
|
|
(return-from find-quit-restart (format nil ":r~D" x:it)))))))
|
|
":q")
|
|
|
|
(defun handle-debug-io ()
|
|
(let ((cmd (funcall *gui-debug-dialog*
|
|
(list (cons (get-output-stream-string *error-output-buffer*)
|
|
"#d00000")
|
|
(cons (get-output-stream-string *terminal-out-buffer*)
|
|
"black")))))
|
|
(when (string-equal ":q" cmd)
|
|
(setf cmd (find-quit-restart)))
|
|
(format nil "~A~%" (if (x:empty-string cmd) ":q" cmd))))
|
|
|
|
(ini)
|
|
|