├── .gitignore ├── LICENSE ├── README.org ├── ndebug.asd ├── ndebug.lisp ├── package.lisp ├── stream.lisp └── tests ├── package.lisp └── tests.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore compiled lisp files 2 | *.FASL 3 | *.fasl 4 | *.fas 5 | *.lisp-temp 6 | *.dfsl 7 | *.pfsl 8 | *.d64fsl 9 | *.p64fsl 10 | *.lx64fsl 11 | *.lx32fsl 12 | *.dx64fsl 13 | *.dx32fsl 14 | *.fx64fsl 15 | *.fx32fsl 16 | *.sx64fsl 17 | *.sx32fsl 18 | *.wx64fsl 19 | *.wx32fsl 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2022-2025, Atlas Engineer LLC. 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE:NDebug 2 | #+SUBTITLE: A toolkit to construct interface-aware yet standard-compliant debugger hooks 3 | 4 | NDebug provides a small set of utilities to make graphical (or, rather non-REPL-resident) Common Lisp applications easier to integrate with the standard Lisp debugger (~*debugger-hook*~, namely) and implementation-specific debugger hooks (via ~trivial-custom-debugger~), especially in a multi-threaded context. 5 | 6 | * Getting started 7 | ** Installation 8 | 9 | NDebug is pretty light on dependencies: 10 | - [[https://github.com/Shinmera/dissect][Dissect]]. 11 | - [[https://github.com/phoe/trivial-custom-debugger][trivial-custom-debugger]]. 12 | - [[https://github.com/sionescu/bordeaux-threads][Bordeaux Threads]]. 13 | - [[https://github.com/trivial-gray-streams/trivial-gray-streams][Trivial Gray Streams]]. 14 | 15 | ** Usage 16 | NDebug has two API layers: CLOS API and a globals&functions API. The CLOS API is more structured and I recommend to use it in most cases, while the globals&functions API overrides the CLOS methods and allows to customize the solid base CLOS provides. globals&functions is more REPL-friendly, so you may start your debugger with this, while transitioning to the CLOS API later. 17 | 18 | *** CLOS API 19 | 20 | To make your application debugger-friendly, you have to specialize ~ui-display~, ~ui-cleanup~, ~query-read~ and ~query-write~ methods (the latter two are not required and will be replaced with ~*query-io*~ if not present). And then use the ~make-debugger-hook~ function to set the debugger. 21 | 22 | Note that there are 23 | - ~ndebug:invoke~ to invoke a restart for a condition, 24 | - and ~ndebug:evaluate~ (only works on SBCL at the moment) to evaluate the code in the context of the condition. 25 | 26 | #+begin_src lisp 27 | (defclass my-wrapper (ndebug:condition-wrapper) 28 | ((prompt-text :initform "[prompt text]" 29 | :accessor prompt-text) 30 | (debug-window :initform nil 31 | :accessor debug-window))) 32 | 33 | (defmethod ndebug:query-read ((wrapper my-wrapper)) 34 | (prompt :text (prompt-text wrapper))) 35 | 36 | (defmethod ndebug:query-write ((wrapper my-wrapper) (string string)) 37 | (setf (prompt-text wrapper) string)) 38 | 39 | (defmethod ndebug:ui-display ((wrapper my-wrapper)) 40 | (setf (debug-window wrapper) 41 | (make-windown :text-contents (dissect:present (ndebug:stack wrapper) nil) 42 | :buttons (loop for restart in (ndebug:restarts wrapper) 43 | collect (make-button 44 | :label (restart-name restart) 45 | :action (lambda () 46 | (ndebug:invoke wrapper restart))))))) 47 | 48 | (defmethod ndebug:ui-cleanup ((wrapper my-wrapper)) 49 | (delete-window (debug-window wrapper))) 50 | 51 | (ndebug:with-debugger-hook (:wrapper-class 'my-wrapper) 52 | (obviously-erroring-operation)) 53 | #+end_src 54 | 55 | *** Globals&functions API 56 | 57 | With globals&function API you have a bit more flexibility in how you configure the debugger. You can ~let~-bind or ~flet~-bind special variables (~ndebug:*query-read*~, ~ndebug:*query-write*~, ~ndebug:*ui-display*~, ~ndebug:*ui-cleanup*~), you can ~setf~ them, you can provide them as arguments to ~ndebug:make-debugger-hook~ or ~ndebug:with-debugger-hook~. The possibilities are endless, although it tends to look less structured than the CLOS API. 58 | 59 | #+begin_src lisp 60 | (defvar *prompt-text* "[prompt text]") 61 | 62 | (defvar *window* nil) 63 | 64 | (defun show-wrapper-window (wrapper) 65 | (setf 66 | ,*window* 67 | (make-window 68 | :text-contents (dissect:present (ndebug:stack wrapper) nil) 69 | :buttons (loop for restart in (ndebug:restarts wrapper) 70 | collect (make-button 71 | :label (restart-name restart) 72 | :action (lambda () 73 | (ndebug:invoke wrapper restart))))))) 74 | 75 | (let ((ndebug:*query-read* (lambda (wrapper) 76 | (declare (ignore wrapper)) 77 | (prompt :text *prompt-text*)))) 78 | (flet ((cleanup (wrapper) 79 | (declare (ignore wrapper)) 80 | (delete-window *window*))) 81 | (setf ndebug:*ui-cleanup* #'cleanup)) 82 | (ndebug:with-debugger-hook 83 | (:ui-display #'show-wrapper-window 84 | :query-write (setf *prompt-text* %string%)) 85 | (obviously-erroring-operation))) 86 | #+end_src 87 | 88 | ** Mixing the two 89 | 90 | The good thing about these API is that you can intermix those. So, you can subclass the ~ndebug:condition-wrapper~, define some methods on it and then, if there's some corner case (like needing a custom display or custom reading function), you can always provide an additional argument to ~make-debugger-hook~ to override the initial method. 91 | 92 | * To-Dos 93 | - [X] Stop depending on Swank for two-way-stream construction, depend on ~trivial-gray-streams~ instead. 94 | - The implementation is quite basic, but it seems to work. 95 | - [X] (Maybe) stop depending on Lparallel and depend on Bordeaux Thread semaphores/conditions instead. 96 | - Semaphores it is! 97 | - [ ] Better names for handlers? 98 | - [X] Use methods to specialize the behavior? 99 | - [ ] (Maybe) allow falling back to ~*query-io*~ by providing ~nil~ as both ~:query-write~ and ~:query-read~. 100 | -------------------------------------------------------------------------------- /ndebug.asd: -------------------------------------------------------------------------------- 1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC 2 | ;;;; SPDX-License-Identifier: BSD-3-Clause 3 | 4 | (defsystem #:ndebug 5 | :description "A toolkit to construct interface-aware yet standard-compliant debugger hooks." 6 | :author "Atlas Engineer LLC" 7 | :license "BSD 3-Clause" 8 | :version "0.2.0" 9 | :serial t 10 | :depends-on (#:dissect #:trivial-custom-debugger #:bordeaux-threads #:trivial-gray-streams) 11 | :components ((:file "package") 12 | (:file "stream") 13 | (:file "ndebug")) 14 | :in-order-to ((test-op (test-op "ndebug/tests")))) 15 | 16 | (defsystem "ndebug/tests" 17 | :depends-on (ndebug lisp-unit2) 18 | :serial t 19 | :components ((:file "tests/package") 20 | (:file "tests/tests")) 21 | :perform (test-op (o c) 22 | (let* ((*debugger-hook* nil) 23 | (test-results (symbol-call :lisp-unit2 :run-tests 24 | :package :ndebug/tests 25 | :run-contexts (symbol-function 26 | (read-from-string "lisp-unit2:with-summary-context"))))) 27 | (when (or 28 | (uiop:symbol-call :lisp-unit2 :failed test-results) 29 | (uiop:symbol-call :lisp-unit2 :errors test-results)) 30 | ;; Arbitrary but hopefully recognizable exit code. 31 | (quit 18))))) 32 | -------------------------------------------------------------------------------- /ndebug.lisp: -------------------------------------------------------------------------------- 1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC 2 | ;;;; SPDX-License-Identifier: BSD-3-Clause 3 | 4 | (in-package #:ndebug) 5 | 6 | (defvar *query-write* nil 7 | "A function/lambda to unconditionally override/alter the `query-write' call.") 8 | (defvar *query-read* nil 9 | "A function/lambda to unconditionally override/alter the `query-read' call.") 10 | (defvar *ui-display* nil 11 | "A function/lambda to unconditionally override/alter the `ui-display' call.") 12 | (defvar *ui-cleanup* nil 13 | "A function/lambda to unconditionally override/alter the `ui-cleanup' call.") 14 | 15 | (defclass condition-wrapper () 16 | ((condition-itself 17 | :initform (error "condition-wrapper should always wrap a condition.") 18 | :initarg :condition-itself 19 | :accessor condition-itself 20 | :type condition 21 | :documentation "The condition itself.") 22 | (restarts 23 | :initform '() 24 | :initarg :restarts 25 | :accessor restarts 26 | :type list 27 | :documentation "A list of `dissect:restart's for the given condition.") 28 | (chosen-restart 29 | :initform nil 30 | :documentation "The restart chosen in the interface and brought by `invoke'.") 31 | (code-to-evaluate 32 | :initform nil 33 | :type (or list function) 34 | :documentation "The code to evaluate in `evaluate'. 35 | Can be either a list of a zero-argument function.") 36 | (restart-semaphore 37 | :initform (bt:make-semaphore) 38 | :type bt:semaphore 39 | :documentation "The semaphore to wait on until the restart is returned.") 40 | (stack 41 | :initform nil 42 | :initarg :stack 43 | :accessor stack 44 | :documentation "The state of call stack at the time of the condition firing. 45 | A list of `dissect:call' objects.")) 46 | (:documentation "The wrapper for condition. 47 | 48 | Made so that `*debugger-hook*' can wait for the condition to be resolved based on 49 | the `channel', wrapped alongside the condition and its restarts.")) 50 | 51 | (defgeneric query-write (wrapper string) 52 | (:method ((wrapper condition-wrapper) (string string)) 53 | nil) 54 | (:method :around (wrapper string) 55 | (if *query-write* 56 | (funcall *query-write* wrapper string) 57 | (call-next-method))) 58 | (:documentation "The function to call as part of custom `*query-io*' when prompting the user. 59 | Always prefers `*query-write*' (if set) over the default method.")) 60 | 61 | (defgeneric query-read (wrapper) 62 | (:method ((wrapper condition-wrapper)) 63 | nil) 64 | (:method :around (wrapper) 65 | (if *query-read* 66 | (funcall *query-read* wrapper) 67 | (call-next-method))) 68 | (:documentation "The function to call as part of custom `*query-io*' when getting user input. 69 | Always prefers `*query-read*' (if set) over the default method.")) 70 | 71 | (defgeneric ui-display (wrapper) 72 | (:method ((wrapper condition-wrapper)) 73 | nil) 74 | (:method :around (wrapper) 75 | (if *ui-display* 76 | (funcall *ui-display* wrapper) 77 | (call-next-method))) 78 | (:documentation "Part of custom debugger, called when showing the condition to the user. 79 | Always prefers `*ui-display*' (if set) over the default method.")) 80 | 81 | (defgeneric ui-cleanup (wrapper) 82 | (:method ((wrapper condition-wrapper))) 83 | (:method :around (wrapper) 84 | (if *ui-cleanup* 85 | (funcall *ui-cleanup* wrapper) 86 | (call-next-method))) 87 | (:documentation "Part of custom debugger, called once the debugger is done. 88 | Always prefers `*ui-cleanup*' (if set) over the default method.")) 89 | 90 | (declaim (ftype (function (&key (:wrapper-class t) 91 | (:ui-display (or null (function (condition-wrapper)))) 92 | (:ui-cleanup (or null (function (condition-wrapper)))) 93 | (:query-read (or null (function (condition-wrapper) string))) 94 | (:query-write (or null (function (condition-wrapper string)))))) 95 | make-debugger-hook)) 96 | (defun make-debugger-hook (&key (wrapper-class 'condition-wrapper) 97 | (ui-display *ui-display*) (ui-cleanup *ui-cleanup*) 98 | (query-read *query-read*) (query-write *query-write*)) 99 | "Construct a `*debugger-hook*'-compatible function with multi-threading and UI interaction. 100 | 101 | WRAPPER-CLASS is a class designator for the class to wrap the 102 | condition in. Defaults to `condition-wrapper'. WRAPPER-CLASS 103 | designated class must inherit from `condition-wrapper'. 104 | 105 | UI-DISPLAY is a function to invoke when showing the debugger 106 | window/prompt/query. Is called with a condition wrapper to 107 | display. Overrides a `ui-display' method (if present), defined for the 108 | WRAPPER-CLASS. 109 | 110 | UI-CLEANUP is a function to invoke after the debugging is done and the 111 | interface is in need of cleaning up (like removing debug windows or 112 | flushing the shell.) Accepts a condition wrapper to clean up 113 | after. Overrides a `ui-cleanup' method (if present), defined for the 114 | WRAPPER-CLASS. 115 | 116 | QUERY-READ is a function to invoke when querying the user, like 117 | opening a an input window or waiting for shell input. Must return an 118 | inputted string. The only argument is the condition wrapper for a 119 | related condition. Overrides a `query-read' method (if present), 120 | defined for the WRAPPER-CLASS. 121 | 122 | QUERY-WRITE is a unary function to invoke when showing the user the 123 | prompting text, like when opening a dialogue window or writing to the 124 | shell. Can refer to the outside state to interface with the 125 | QUERY-READ. The arguments are: 126 | - Condition wrapper for the current condition. 127 | - The string to show to the user. 128 | Overrides a `query-write' method (if present), defined for the 129 | WRAPPER-CLASS. 130 | 131 | QUERY-READ and QUERY-WRITE should both be present (in which case 132 | prompting happens in the custom interface), or both absent (in which 133 | case the default `*query-io*' is used.)" 134 | (lambda (condition hook) 135 | (let* ((restarts (dissect:restarts)) 136 | (wrapper (make-instance wrapper-class 137 | :condition-itself condition 138 | :restarts restarts 139 | :stack (dissect:stack))) 140 | (*query-io* (if (or (and (ignore-errors (find-method #'query-read nil (list wrapper-class))) 141 | (ignore-errors (find-method #'query-write nil (list wrapper-class 'string)))) 142 | (and query-read query-write)) 143 | (make-debugger-stream 144 | (lambda () 145 | (let* ((*query-read* query-read) 146 | (*debugger-hook* nil) 147 | (result (query-read wrapper))) 148 | (if (uiop:string-suffix-p result #\newline) 149 | result 150 | (uiop:strcat result #\newline)))) 151 | (lambda (string) 152 | (let ((*query-write* query-write) 153 | (*debugger-hook* nil)) 154 | (query-write wrapper string)))) 155 | *query-io*))) 156 | (when (or (ignore-errors (find-method #'ui-display nil (list wrapper-class))) 157 | ui-display) 158 | (let ((*ui-display* ui-display) 159 | (*debugger-hook* nil)) 160 | (ui-display wrapper))) 161 | (unwind-protect 162 | ;; FIXME: Waits indefinitely. Should it? 163 | (let ((restart (loop for got-something = (bt:wait-on-semaphore (slot-value wrapper 'restart-semaphore)) 164 | for code = (slot-value wrapper 'code-to-evaluate) 165 | for restart = (slot-value wrapper 'chosen-restart) 166 | when code 167 | do (let ((*debugger-hook* hook)) 168 | (typecase code 169 | (list (eval code)) 170 | (function (funcall code)))) 171 | and do (setf (slot-value wrapper 'code-to-evaluate) nil) 172 | else when restart 173 | do (return restart))) 174 | (*debugger-hook* hook)) 175 | (invoke-restart-interactively 176 | (etypecase restart 177 | (dissect:restart (dissect:object restart)) 178 | (restart restart) 179 | (symbol (find-restart restart)) 180 | (function restart)))) 181 | (when (or (ignore-errors (find-method #'ui-cleanup nil (list wrapper-class))) 182 | ui-cleanup) 183 | (let ((*ui-cleanup* ui-cleanup) 184 | (*debugger-hook* nil)) 185 | (ui-cleanup wrapper))))))) 186 | 187 | (defgeneric invoke (wrapper restart) 188 | (:method ((wrapper condition-wrapper) (restart symbol)) 189 | (setf (slot-value wrapper 'chosen-restart) restart) 190 | (bt:signal-semaphore (slot-value wrapper 'restart-semaphore))) 191 | (:method ((wrapper condition-wrapper) (restart dissect:restart)) 192 | (setf (slot-value wrapper 'chosen-restart) restart) 193 | (bt:signal-semaphore (slot-value wrapper 'restart-semaphore))) 194 | (:method ((wrapper condition-wrapper) (restart restart)) 195 | (setf (slot-value wrapper 'chosen-restart) restart) 196 | (bt:signal-semaphore (slot-value wrapper 'restart-semaphore))) 197 | (:method ((wrapper condition-wrapper) (restart function)) 198 | (setf (slot-value wrapper 'chosen-restart) restart) 199 | (bt:signal-semaphore (slot-value wrapper 'restart-semaphore))) 200 | (:documentation "Invoke the RESTART in the initial debugger hook of the WRAPPER. 201 | 202 | The RESTART should be one of the `restarts' of the WRAPPER. Otherwise 203 | the behavior is implementation-dependent, but never exactly pretty.")) 204 | 205 | (defgeneric evaluate (wrapper code) 206 | (:method ((wrapper condition-wrapper) (code list)) 207 | (setf (slot-value wrapper 'code-to-evaluate) code) 208 | (bt:signal-semaphore (slot-value wrapper 'restart-semaphore))) 209 | (:method ((wrapper condition-wrapper) (code function)) 210 | (setf (slot-value wrapper 'code-to-evaluate) code) 211 | (bt:signal-semaphore (slot-value wrapper 'restart-semaphore))) 212 | (:documentation "Evaluate the CODE in the debugger WRAPPER context. 213 | 214 | CODE can be 215 | - A quoted list of Lisp code, in which case it will be avaluated. 216 | - A function object, in which case if will be called in the context of the debugger.")) 217 | 218 | (defmacro with-debugger-hook ((&key wrapper-class query-read query-write ui-display ui-cleanup) 219 | &body body) 220 | "Execute the BODY with the newly-created (as per `make-debugger-hook') debugger hook. 221 | 222 | The ARGS are `make-debugger-hook' arguments passed to it with the 223 | following rules: 224 | - If the argument form starts with a `lambda' or `function' (which 225 | sharp-quote expands to), pass it to `make-debugger-hook' as-is. 226 | - If not, then wrap it in a lambda with a special variable 227 | %WRAPPER% (and %STRING% in case of :QUERY-WRITE) accessible to the 228 | argument form. 229 | 230 | Example:" 231 | (declare (ignorable wrapper-class query-read query-write ui-display ui-cleanup)) 232 | (flet ((wrap-lambda-maybe (form) 233 | (list (if (member (first form) '(lambda function)) 234 | form 235 | `(lambda (,(alexandria:symbolicate "%WRAPPER%")) 236 | (declare (ignorable ,(alexandria:symbolicate "%WRAPPER%"))) 237 | ,form))))) 238 | `(trivial-custom-debugger:with-debugger 239 | ((make-debugger-hook 240 | ,@(when wrapper-class 241 | (list :wrapper-class wrapper-class)) 242 | ,@(when query-read 243 | (cons :query-read (wrap-lambda-maybe query-read))) 244 | ,@(when query-write 245 | (list :query-write 246 | (if (member (first query-write) '(lambda function)) 247 | query-write 248 | `(lambda (,(alexandria:symbolicate "%WRAPPER%") 249 | ,(alexandria:symbolicate "%STRING%")) 250 | (declare (ignorable ,(alexandria:symbolicate "%WRAPPER%") 251 | ,(alexandria:symbolicate "%STRING%"))) 252 | ,query-write)))) 253 | ,@(when ui-display 254 | (cons :ui-display (wrap-lambda-maybe ui-display))) 255 | ,@(when ui-cleanup 256 | (cons :ui-cleanup (wrap-lambda-maybe ui-cleanup))))) 257 | ,@body))) 258 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC 2 | ;;;; SPDX-License-Identifier: BSD-3-Clause 3 | 4 | (defpackage #:ndebug 5 | (:use #:cl) 6 | (:export 7 | #:condition-wrapper 8 | #:condition-itself 9 | #:restarts 10 | #:stack 11 | #:*query-read* 12 | #:*query-write* 13 | #:*ui-display* 14 | #:*ui-cleanup* 15 | #:query-read 16 | #:query-write 17 | #:ui-display 18 | #:ui-cleanup 19 | #:invoke 20 | #:evaluate 21 | #:make-debugger-stream 22 | #:make-debugger-hook 23 | #:with-debugger-hook) 24 | (:documentation "NDebug provides several primitives to work with UI-aware debuggers: 25 | 26 | `ndebug:condition-wrapper' is a class to encapsulate all the 27 | meta-information about the condition, otherwise only available in the 28 | debugger hook. With this class, NDebug can pass condition to be 29 | handled elsewhere, including the graphical debugger. 30 | 31 | Important slots: 32 | - `ndebug:condition-itself' as a condition the debugger got. 33 | - `ndebug:restarts' as a list of CL restarts connected to the 34 | condition. 35 | - `ndebug:stack' as a list of `dissect:call's representing the call 36 | stack state at the moment of condition signalling. 37 | - `ndebug::restart-semaphore' and `ndebug::chosen-restart' as internal 38 | details of multi-threaded restart passing. Prefer `ndebug:invoke' 39 | instead, to be safe from future API changes. 40 | 41 | Important methods: 42 | - `ndebug:query-read' and `ndebug:query-write' to provide your own 43 | alternative to `*query-io*' reading/writing facilities 44 | - `ndebug:ui-display' to show the wrapped condition on your UI. 45 | - `ndebug:ui-cleanup' to clean up after handling the condition. 46 | 47 | `ndebug:invoke' safely passes the chosen restart back to the debugger 48 | hook, no matter where the passing happens from. Pass it the restart 49 | you've chosen in the UI -- and you're good! 50 | 51 | `ndebug:make-debugger-stream' constructs a `*query-io*'-friendly 52 | stream based on the input and output functions passed to it. For now, 53 | it's a thin wrapper around the `swank-backend:make-input-stream' and 54 | `swank-backend:make-output-stream', but that may change in the future. 55 | 56 | `ndebug:make-debugger-hook' constructs the UI-aware debugger so that 57 | thing you have to provide is a set of functions to: 58 | - Query the user (:QUERY-READ, overrides the `ndebug:query-read'). 59 | - Show the user debugger prompt (:QUERY-WRITE, overrides the `ndebug:query-write'). 60 | - Show the condition in the UI (:UI-DISPLAY, overrides the `ndebug:ui-display'). 61 | - Clean the UI after the condition is handled (:UI-CLEANUP, overrides the `ndebug:ui-cleanup'). 62 | 63 | Additionally `ndebug:make-debugger-hook' accepts a :WRAPPER-CLASS so 64 | that you can provide your own wrapper class instead of 65 | `ndebug:condition-wrapper'. Note that it has to inherit from 66 | `ndebug:condition-wrapper' for all the NDebug APIs to work properly. 67 | 68 | `ndebug:with-debugger-hook' is a thin wrapper around 69 | `ndebug:make-debugger-hook' to bind the debugger hook to the generated 70 | function for the duration of the body.")) 71 | -------------------------------------------------------------------------------- /stream.lisp: -------------------------------------------------------------------------------- 1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC 2 | ;;;; SPDX-License-Identifier: BSD-3-Clause 3 | 4 | (in-package #:ndebug) 5 | 6 | (defclass debugger-input-stream (trivial-gray-streams:fundamental-character-input-stream) 7 | ((input-fn :initarg :input-fn 8 | :accessor input-fn 9 | :documentation "The one-shot function returning string. 10 | This string is then used for all the input operations.") 11 | (input :initarg :input 12 | :accessor input 13 | :documentation "The string to use as input buffer.") 14 | (index :initform 0 15 | :initarg :index 16 | :accessor index 17 | :documentation "The index in the string."))) 18 | 19 | (defmethod slot-unbound (class (stream debugger-input-stream) (slot-name (eql 'input))) 20 | (setf (input stream) (funcall (input-fn stream)))) 21 | 22 | (defmethod trivial-gray-streams:stream-read-char ((stream debugger-input-stream)) 23 | (when (= (index stream) (length (input stream))) 24 | (setf (input stream) (funcall (input-fn stream)) 25 | (index stream) 0) 26 | (when (uiop:emptyp (input stream)) 27 | (return-from trivial-gray-streams:stream-read-char :eof))) 28 | (prog1 29 | (char (input stream) (index stream)) 30 | (incf (index stream)))) 31 | 32 | (defmethod trivial-gray-streams:stream-listen ((stream debugger-input-stream)) 33 | (< (index stream) (length (input stream)))) 34 | 35 | (defmethod trivial-gray-streams:stream-unread-char ((stream debugger-input-stream) char) 36 | (decf (index stream)) 37 | nil) 38 | 39 | (defmethod trivial-gray-streams:stream-clear-input ((stream debugger-input-stream)) 40 | (setf (input stream) "" 41 | (index stream) 0) 42 | nil) 43 | 44 | (defmethod trivial-gray-streams:stream-line-column ((stream debugger-input-stream)) 45 | nil) 46 | 47 | (defclass debugger-output-stream (trivial-gray-streams:fundamental-character-output-stream) 48 | ((output-fn :initarg :output-fn 49 | :accessor output-fn 50 | :documentation "The one-shot function accepting string and printing it.") 51 | (output :initform (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character) 52 | :initarg :output 53 | :accessor output 54 | :documentation "The vector to use as the output buffer.") 55 | (column :initform 0 56 | :initarg :column 57 | :accessor column))) 58 | 59 | (defmethod trivial-gray-streams:stream-write-char ((stream debugger-output-stream) char) 60 | (vector-push-extend char (output stream)) 61 | (if (char= #\newline char) 62 | (setf (column stream) 0) 63 | (incf (column stream))) 64 | char) 65 | 66 | (defmethod trivial-gray-streams:stream-line-column ((stream debugger-output-stream)) 67 | (column stream)) 68 | 69 | (defmethod trivial-gray-streams:stream-finish-output ((stream debugger-output-stream)) 70 | (funcall (output-fn stream) (coerce (output stream) 'string)) 71 | (loop until (zerop (length (output stream))) 72 | do (vector-pop (output stream))) 73 | nil) 74 | 75 | (defmethod trivial-gray-streams:stream-force-output ((stream debugger-output-stream)) 76 | (trivial-gray-streams:stream-finish-output stream)) 77 | 78 | (defmethod trivial-gray-streams:stream-fresh-line ((stream debugger-output-stream)) 79 | (cond ((zerop (column stream)) nil) 80 | (t (terpri stream) t))) 81 | 82 | 83 | (declaim (ftype (function ((function () string) (function (string))) two-way-stream) 84 | make-debugger-stream)) 85 | (defun make-debugger-stream (input-fn output-fn) 86 | "Construct a `*query-io*'-compatible stream out of INPUT-FN and OUTPUT-FN." 87 | (make-two-way-stream 88 | ;; FIXME: Understand/reproduce how Swank makes those streams. 89 | (make-instance 'debugger-input-stream :input-fn input-fn) 90 | (make-instance 'debugger-output-stream :output-fn output-fn))) 91 | -------------------------------------------------------------------------------- /tests/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC 2 | ;;;; SPDX-License-Identifier: BSD-3-Clause 3 | 4 | (uiop:define-package ndebug/tests 5 | (:use #:cl #:lisp-unit2)) 6 | -------------------------------------------------------------------------------- /tests/tests.lisp: -------------------------------------------------------------------------------- 1 | ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC 2 | ;;;; SPDX-License-Identifier: BSD-3-Clause 3 | 4 | (in-package #:ndebug/tests) 5 | 6 | (defvar what "hello") 7 | 8 | (defun error-with-ignore () 9 | (restart-case 10 | (1+ what) 11 | (ignore () "hello1") 12 | (ignore2 () "hello2"))) 13 | 14 | (defun find-restart-by-name (name restarts) 15 | (loop for r in restarts 16 | when (search name 17 | (symbol-name 18 | (typecase r 19 | (restart (restart-name r)) 20 | (dissect:restart (restart-name (dissect:object r))))) 21 | :test #'string-equal) 22 | do (return r))) 23 | 24 | (define-test debugger-handler-bind () 25 | (ndebug:with-debugger-hook (:ui-display 26 | (ndebug:invoke 27 | %wrapper% 28 | (assert-true (find-restart-by-name "supersede" (ndebug:restarts %wrapper%)))))) 29 | (uiop:with-temporary-file (:pathname p) 30 | (assert-true (uiop:file-exists-p p)) 31 | (assert-equal "" (uiop:read-file-string p)) 32 | (let ((s (open p :direction :output))) 33 | (assert-true (uiop:file-exists-p p)) 34 | (format s "hello") 35 | (force-output s) 36 | (assert-equal "hello" (uiop:read-file-string p)) 37 | (close s)) 38 | (assert-true (uiop:file-exists-p p)))) 39 | 40 | (define-test multithreaded () 41 | (ndebug:with-debugger-hook (:ui-display 42 | (bt:make-thread 43 | (lambda () 44 | (ndebug:invoke 45 | %wrapper% 46 | (find-restart-by-name "ignore" (ndebug:restarts %wrapper%)))))) 47 | (assert-equal "hello1" (error-with-ignore)))) 48 | 49 | (define-test with-debugger-hook-expansion () 50 | (ndebug:with-debugger-hook 51 | (:ui-display (ndebug:invoke 52 | %wrapper% 53 | (assert-true (find-restart-by-name "ignore" (ndebug:restarts %wrapper%))))) 54 | (assert-equal "hello1" (error-with-ignore)))) 55 | 56 | (defclass my-wrapper (ndebug:condition-wrapper) 57 | ((restart-findable-name :initform "ignore" 58 | :accessor restart-findable-name 59 | :type string))) 60 | 61 | (defmethod ndebug:ui-display ((wrapper my-wrapper)) 62 | (ndebug:invoke wrapper (find-restart-by-name (restart-findable-name wrapper) 63 | (ndebug:restarts wrapper)))) 64 | 65 | (define-test class-based-debugging () 66 | (ndebug:with-debugger-hook 67 | (:wrapper-class 'my-wrapper) 68 | (assert-equal "hello1" (error-with-ignore)))) 69 | 70 | (define-test class-based-debugging-overriden () 71 | (ndebug:with-debugger-hook 72 | (:wrapper-class 'my-wrapper 73 | :ui-display (ndebug:invoke 74 | %wrapper% 75 | (assert-true (find-restart-by-name "ignore2" (ndebug:restarts %wrapper%))))) 76 | (assert-equal "hello2" (error-with-ignore)))) 77 | 78 | (defvar %foo% "before debug") 79 | 80 | (define-test try-evaluate () 81 | (ndebug:with-debugger-hook (:ui-display 82 | (lambda (wrapper) 83 | (ndebug:evaluate 84 | wrapper 85 | (lambda () 86 | (format t "Setting foo to after debug~%") 87 | (setf %foo% "after debug"))) 88 | (ndebug:invoke 89 | wrapper 90 | (assert-true (find-restart-by-name "supersede" 91 | (ndebug:restarts wrapper)))))) 92 | (uiop:with-temporary-file (:pathname p) 93 | (assert-equal "before debug" %foo%) 94 | (assert-true (uiop:file-exists-p p)) 95 | (assert-equal "" (uiop:read-file-string p)) 96 | (let ((s (open p :direction :output))) 97 | (assert-true (uiop:file-exists-p p)) 98 | (format s "hello") 99 | (force-output s) 100 | (assert-equal "hello" (uiop:read-file-string p)) 101 | (close s)) 102 | (assert-true (uiop:file-exists-p p)) 103 | (assert-equal "after debug" %foo%)))) 104 | --------------------------------------------------------------------------------