This repository has been archived by the owner on Apr 2, 2023. It is now read-only.
-
-
Notifications
You must be signed in to change notification settings - Fork 5
/
Copy pathdebugger.lisp
189 lines (153 loc) · 7.34 KB
/
debugger.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
#|
This file is a part of Qtools-UI
(c) 2015 Shirakumo http://tymoon.eu ([email protected])
Author: Nicolas Hafner <[email protected]>
|#
(in-package #:org.shirakumo.qtools.ui)
(in-readtable :qtools)
(defun remove-newlines (string)
(remove #\Linefeed string))
(defun set-foreground-color (widget color)
(setf (q+:color (q+:palette widget) (q+:qpalette.foreground)) color))
(defun make-section-heading (parent format &rest args)
(q+:make-qlabel (format NIL "<span style=\"font-weight: bold; font-size: 13pt;\">~?</span>"
format args) parent))
(defun invoke-gui-debugger (condition &optional (debugger-class 'debugger))
(dissect:with-capped-stack ()
(with-finalizing ((debugger (make-instance debugger-class :environment condition)))
(q+:exec debugger)
(typecase (exit-restart debugger)
(symbol (invoke-restart (exit-restart debugger)))
(dissect:restart (dissect:invoke (exit-restart debugger)))))))
(define-widget debugger (QDialog)
((environment :initarg :condition :initarg :environment :accessor environment)
(exit-restart :initform NIL :accessor exit-restart)))
(define-initializer (debugger setup 100)
(setf environment
(etypecase environment
(dissect:environment environment)
(condition (dissect:capture-environment environment))
(null (dissect:capture-environment))))
(setf (q+:window-title debugger) (format NIL "Debugger~@[ [~a]~]" (type-of (dissect:environment-condition environment)))))
(define-subwidget (debugger condition)
(if (dissect:environment-condition environment)
(make-instance 'condition-view :condition (dissect:environment-condition environment)
:debugger debugger)
(q+:make-qwidget debugger)))
(define-subwidget (debugger restarts)
(make-instance 'restart-view :restarts (dissect:environment-restarts environment)
:debugger debugger))
(define-subwidget (debugger stacktrace)
(make-instance 'stacktrace-view :stacktrace (dissect:environment-stack environment)
:debugger debugger))
(define-subwidget (debugger scroller) (q+:make-qscrollarea debugger)
(setf (q+:widget scroller) stacktrace)
(setf (q+:widget-resizable scroller) T)
(setf (q+:vertical-scroll-bar-policy scroller) (q+:qt.scroll-bar-always-on))
(setf (q+:horizontal-scroll-bar-policy scroller) (q+:qt.scroll-bar-always-off)))
(define-subwidget (debugger layout) (q+:make-qvboxlayout debugger)
(q+:add-widget layout condition)
(q+:add-widget layout (make-section-heading debugger "Active Restarts:"))
(q+:add-widget layout restarts)
(q+:add-widget layout (make-section-heading debugger "Stack Trace:"))
(q+:add-widget layout scroller))
(defmethod exit-with-restart ((debugger debugger) restart)
(setf (exit-restart debugger) restart)
(q+:close debugger))
(define-override (debugger key-release-event) (ev)
(flet ((exit-with-nth (n)
(let ((restart (nth n (dissect:environment-restarts environment))))
(when restart (exit-with-restart debugger restart)))))
(qtenumcase (q+:key ev)
((q+:qt.key_q) (q+:close debugger))
((q+:qt.key_c) (exit-with-restart debugger 'continue))
((q+:qt.key_a) (exit-with-restart debugger 'abort))
((q+:qt.key_0) (exit-with-nth 0))
((q+:qt.key_1) (exit-with-nth 1))
((q+:qt.key_2) (exit-with-nth 2))
((q+:qt.key_3) (exit-with-nth 3))
((q+:qt.key_4) (exit-with-nth 4))
((q+:qt.key_5) (exit-with-nth 5))
((q+:qt.key_6) (exit-with-nth 6))
((q+:qt.key_7) (exit-with-nth 7))
((q+:qt.key_8) (exit-with-nth 8))
((q+:qt.key_8) (exit-with-nth 9))))
(stop-overriding))
(define-widget condition-view (QWidget)
((condition :initarg :condition)
(debugger :initarg :debugger)))
(define-subwidget (condition-view report) (q+:make-qlabel condition-view)
(setf (q+:word-wrap report) T)
(setf (q+:text report) (format NIL "~a" condition)))
(define-subwidget (condition-view type)
(make-section-heading condition-view "Condition of type ~a" (type-of condition))
(set-foreground-color type (q+:make-qcolor 250 50 50)))
(define-subwidget (condition-view layout) (q+:make-qvboxlayout condition-view)
(setf (q+:margin layout) 0)
(q+:add-widget layout type)
(q+:add-widget layout report))
(define-widget restart-view (QWidget)
((restarts :initarg :restarts)
(debugger :initarg :debugger)))
(define-subwidget (restart-view layout) (q+:make-qvboxlayout restart-view)
(setf (q+:margin layout) 0)
(setf (q+:spacing layout) 0)
(dolist (restart restarts)
(q+:add-widget layout (make-instance 'restart-item :restart restart :debugger debugger))))
(define-widget restart-item (QWidget)
((restart :initarg :restart)
(debugger :initarg :debugger)))
(define-subwidget (restart-item name) (q+:make-qpushbutton (princ-to-string (dissect:name restart)) restart-item)
(setf (q+:size-policy name) (values (q+:qsizepolicy.maximum) (q+:qsizepolicy.maximum))))
(define-subwidget (restart-item report) (q+:make-qlabel restart-item)
(setf (q+:text report) (remove-newlines (dissect:report restart))))
(define-subwidget (restart-item layout) (q+:make-qhboxlayout restart-item)
(setf (q+:margin layout) 0)
(q+:add-widget layout name)
(q+:add-widget layout report))
(define-slot (restart-item invoke) ()
(declare (connected name (clicked)))
(exit-with-restart debugger restart))
(define-widget stacktrace-view (QWidget)
((stacktrace :initarg :stacktrace)
(debugger :initarg :debugger)))
(define-subwidget (stacktrace-view layout) (q+:make-qformlayout stacktrace-view)
(set-foreground-color stacktrace-view (q+:make-qcolor 120 120 120))
(setf (q+:margin layout) 0)
;; (setf (q+:spacing layout) 0)
(dolist (frame stacktrace)
(q+:add-row layout (format NIL "~3d" (dissect:pos frame))
(make-instance 'call-item :frame frame :debugger debugger))))
(define-widget call-item (QWidget)
((frame :initarg :frame)
(debugger :initarg :debugger)))
(define-subwidget (call-item call) (q+:make-qlabel call-item)
(set-foreground-color call (q+:make-qcolor 220 220 220))
(setf (q+:text call) (remove-newlines (prin1-to-string (dissect:call frame))))
(setf (q+:size-policy call) (values (q+:qsizepolicy.expanding) (q+:qsizepolicy.maximum))))
(define-subwidget (call-item args) (make-instance 'arglist-view :args (dissect:args frame) :debugger debugger)
(setf (q+:visible args) NIL))
(define-subwidget (call-item layout) (q+:make-qvboxlayout call-item)
(setf (q+:margin layout) 0)
(q+:add-widget layout call)
(q+:add-widget layout args))
(define-override (call-item mouse-release-event) (ev)
(setf (q+:visible args) (not (q+:is-visible args)))
(stop-overriding))
(define-widget arglist-view (QWidget)
((args :initarg :args)
(debugger :initarg :debugger)))
(define-subwidget (arglist-view layout) (q+:make-qformlayout arglist-view)
(setf (q+:margin layout) 0)
(loop for arg in args
for i from 0
do (q+:add-row layout
(format NIL "~3d" i)
(make-instance 'arg-item :arg arg :debugger debugger))))
(define-widget arg-item (QLabel)
((arg :initarg :arg)
(debugger :initarg :debugger)))
(define-initializer (arg-item setup)
(set-foreground-color arg-item (q+:make-qcolor 230 0 0))
(setf (q+:word-wrap arg-item) T)
(setf (q+:text arg-item) (prin1-to-string arg)))