mirrors/clog
1
Fork 0
mirror of https://github.com/rabbibotton/clog.git synced 2025-12-06 10:40:45 -08:00
Code Issues Projects Releases Wiki Activity

full debugger

Browse source
This commit is contained in:
David Botton 2024-04-02 18:27:05 -04:00
parent a3be6d4026
commit a77377c35d
2 changed files with 63 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

76
tools/clog-builder-eval.lisp
View file

@ -1,7 +1,52 @@
(in-package :clog-tools)
;; Lisp code evaluation utilities
;; dialog based streams
(defclass dialog-in-str (trivial-gray-streams:fundamental-character-input-stream)
((clog-obj :reader obj :initarg :clog-obj)
(outbuf :reader outbuf :initarg :source)
(buffer :accessor buffer-of :initform "")
(index :accessor index :initform 0)))
(defmethod trivial-gray-streams:stream-read-char ((stream dialog-in-str))
(when (eql (index stream) (length (buffer-of stream)))
(setf (buffer-of stream) "")
(setf (index stream) 0))
(when (eql (index stream) 0)
(let ((sem (bordeaux-threads:make-semaphore)))
(input-dialog (obj stream) (prompt (outbuf stream)) (lambda (result)
(add-line stream result)
(bordeaux-threads:signal-semaphore sem)))
(bordeaux-threads:wait-on-semaphore sem)))
(when (< (index stream) (length (buffer-of stream)))
(prog1
(char (buffer-of stream) (index stream))
(incf (index stream)))))
(defmethod trivial-gray-streams:stream-unread-char ((stream dialog-in-str) character)
(decf (index stream)))
(defmethod trivial-gray-streams:stream-line-column ((stream dialog-in-str))
nil)
(defmethod add-line ((stream dialog-in-str) text)
(setf (buffer-of stream) (format nil "~A~A~%" (buffer-of stream) text)))
(defclass dialog-out-str (trivial-gray-streams:fundamental-character-output-stream)
((buffer :accessor buffer-of :initform "")))
(defmethod trivial-gray-streams:stream-write-char ((stream dialog-out-str) character)
(setf (buffer-of stream) (format nil "~A~A" (buffer-of stream) character)))
(defmethod trivial-gray-streams:stream-line-column ((stream dialog-out-str))
nil)
(defmethod prompt ((stream dialog-out-str))
(prog1
(buffer-of stream)
(setf (buffer-of stream) "")))
;; Lisp code evaluation utilities
(defun one-of (obj pre choices &optional (title "Error") (prompt "Choice"))
(let ((q (format nil "<pre>~A</pre><p style='text-align:left'>" pre))
(n (length choices)) (i))
@ -27,29 +72,32 @@
"Capture lisp evaluaton of FORM."
(let ((result (make-array '(0) :element-type 'base-char
:fill-pointer 0 :adjustable t))
(eval-result))
eval-result)
(with-output-to-string (stream result)
(labels ((my-debugger (condition encapsulation)
(if clog-obj
(let ((restart (one-of clog-obj condition (compute-restarts))))
(when restart
(let ((*debugger-hook* encapsulation))
(invoke-restart-interactively restart))))
(format t "Error - ~A~%" condition))))
(with-open-stream (out-str (make-instance 'dialog-out-str))
(with-open-stream (in-str (make-instance 'dialog-in-str :clog-obj clog-obj :source out-str))
(labels ((my-debugger (condition encapsulation)
(if clog-obj
(let ((restart (one-of clog-obj condition (compute-restarts))))
(when restart
(let ((*debugger-hook* encapsulation))
(invoke-restart-interactively restart))))
(format t "Error - ~A~%" condition))))
(unless (stringp form)
(let ((r (make-array '(0) :element-type 'base-char
:fill-pointer 0 :adjustable t)))
(with-output-to-string (s r)
(print form s))
(setf form r)))
(let* ((*standard-output* stream)
(*error-output* stream)
(*debugger-hook* #'my-debugger)
(*package* (find-package (string-upcase eval-in-package))))
(let* ((*query-io* (make-two-way-stream in-str out-str))
(*standard-output* stream)
(*error-output* stream)
(*debugger-hook* #'my-debugger)
(*package* (find-package (string-upcase eval-in-package))))
(setf eval-result (eval (read-from-string (format nil "(progn ~A)" form))))
(values
(format nil "~A~%=>~A~%" result eval-result)
*package*))))))
*package*))))))))
(defun do-eval (obj form-string cname &key (package "clog-user") (test t) custom-boot)
"Render, evalute and run code for panel"

2
tools/clog-builder-projects.lisp
View file

@ -58,7 +58,7 @@
(let ((val (text-value (entry-point panel))))
(unless (equal val "")
(let ((result (capture-eval (format nil "(~A)" val) :clog-obj panel
:eval-in-package "clog-user")))
:eval-in-package "clog-user")))
(clog-web-alert (connection-body panel) "Result"
(format nil "~&result: ~A" result)
:color-class "w3-green"