225 lines
7.2 KiB
Scheme
225 lines
7.2 KiB
Scheme
(define footer-length 0)
|
|
|
|
(define (make-inspector-selection-list num-cols num-lines focus-obj)
|
|
(let ((menu (prepare-menu focus-obj)))
|
|
(make-select-list
|
|
(if (null? menu) ; the select-list must not be empty
|
|
(list
|
|
(make-unmarked-text-element
|
|
focus-obj #t (val-to-string focus-obj num-cols)))
|
|
(map (lambda (e)
|
|
(make-unmarked-text-element
|
|
(cadr e) #t (layout-menu-entry num-cols e)))
|
|
menu))
|
|
num-lines)))
|
|
|
|
(define (make-header focus-obj num-cols)
|
|
(cons (val-to-string focus-obj num-cols)
|
|
(maybe-source focus-obj #f)))
|
|
; (if (exception-continuation? focus-obj)
|
|
; "Press cont-down key to see more"
|
|
; "")))
|
|
|
|
(define (header-length header)
|
|
(length header))
|
|
|
|
(define (set-header-message! header msg)
|
|
(if (null? (cdr header))
|
|
(set-cdr! header (list msg))
|
|
(begin
|
|
(set-car! (cdr header) msg)
|
|
(set-cdr! (cdr header) '()))))
|
|
|
|
(define (layout-menu-entry num-cols entry)
|
|
(let ((head (format #f "[~a]" (or (car entry) ""))))
|
|
(string-append head (val-to-string (cadr entry)
|
|
(- num-cols (string-length head))))))
|
|
|
|
(define *write-depth* 3)
|
|
(define *write-length* 5)
|
|
|
|
(define (val-to-string val max-length)
|
|
(let ((out (open-output-string)))
|
|
(limited-write val
|
|
out
|
|
*write-depth*
|
|
*write-length*)
|
|
(let ((str (get-output-string out)))
|
|
(substring str 0 (min (string-length str) max-length)))))
|
|
|
|
(define (prepare-selection-for-scheme-mode file-names)
|
|
(string-append "'" (write-to-string file-names)))
|
|
|
|
(define (continuation-debug-data thing)
|
|
(template-debug-data (continuation-template thing)))
|
|
|
|
|
|
; Exception continuations don't have source, so we get the source from
|
|
; the next continuation if it is from the same procedure invocation.
|
|
|
|
(define (maybe-source thing exception?)
|
|
(cond ((not (continuation? thing))
|
|
'())
|
|
((exception-continuation? thing)
|
|
(let ((next (continuation-cont thing)))
|
|
(if (not (eq? next (continuation-parent thing)))
|
|
(maybe-source next #t)
|
|
'())))
|
|
(else
|
|
(let ((dd (continuation-debug-data thing)))
|
|
(if dd
|
|
(let ((source (assoc (continuation-pc thing)
|
|
(debug-data-source dd))))
|
|
(if source
|
|
(maybe-source-info (cdr source) exception?)
|
|
'()))
|
|
'())))))
|
|
|
|
; Show the source code for a continuation, if we have it.
|
|
|
|
(define (maybe-source-info info exception?)
|
|
(if (pair? info)
|
|
(let ((i (car info))
|
|
(exp (cdr info)))
|
|
(if (and (integer? i) (list? exp))
|
|
(let ((out1 (open-output-string))
|
|
(out2 (open-output-string)))
|
|
(display (if exception?
|
|
"Next call is "
|
|
"Waiting for ")
|
|
out1)
|
|
(limited-write (list-ref exp i) out1
|
|
*write-depth* *write-length*)
|
|
(display " in " out2)
|
|
(limited-write (append (sublist exp 0 i)
|
|
(list '^^^)
|
|
(list-tail exp (+ i 1)))
|
|
out2
|
|
*write-depth* *write-length*)
|
|
(list (get-output-string out1)
|
|
(get-output-string out2)))
|
|
'()))
|
|
'()))
|
|
|
|
|
|
|
|
(define key-d 100)
|
|
(define key-u 117)
|
|
(define key-return 10)
|
|
|
|
(define down-key key-d)
|
|
(define up-key key-u)
|
|
(define inspect-key key-return)
|
|
|
|
(define (make-inspector focus-obj buffer)
|
|
(let* ((num-cols (result-buffer-num-cols buffer))
|
|
(num-lines (result-buffer-num-lines buffer))
|
|
(val focus-obj)
|
|
(stack '())
|
|
(header (make-header focus-obj num-cols))
|
|
(num-cols num-cols)
|
|
(num-lines num-lines)
|
|
(selection-list
|
|
(make-inspector-selection-list num-cols
|
|
(- num-lines (header-length header))
|
|
focus-obj)))
|
|
|
|
(define (push-val! new)
|
|
(set! header (make-header new num-cols))
|
|
(set! stack (cons val stack))
|
|
(set! val new)
|
|
(set! selection-list
|
|
(make-inspector-selection-list
|
|
num-cols
|
|
(- num-lines (header-length header))
|
|
new)))
|
|
|
|
(define (inspect-next-continuation)
|
|
(if (continuation? val)
|
|
(push-val! (continuation-parent val))
|
|
(set-header-message!
|
|
header
|
|
"Can't go down from a non-continuation.")))
|
|
|
|
(define (pop-val!)
|
|
(if (null? stack)
|
|
(set-header-message! header "Can't go up from here.")
|
|
(begin
|
|
(set! val (car stack))
|
|
(set! header (make-header val num-cols))
|
|
(set! stack (cdr stack))
|
|
(set! selection-list
|
|
(make-inspector-selection-list
|
|
num-cols
|
|
(- num-lines (header-length header))
|
|
val)))))
|
|
|
|
(define (get-selection-as-ref self focus-object-table)
|
|
(let ((marked (select-list-get-marked selection-list))
|
|
(make-reference (lambda (obj)
|
|
(make-focus-object-reference
|
|
focus-object-table obj))))
|
|
(if (null? marked)
|
|
(write-to-string
|
|
(make-reference (select-list-selected-entry selection-list)))
|
|
(string-append
|
|
"(list "
|
|
(string-join (map write-to-string (map make-reference marked)))
|
|
")"))))
|
|
|
|
(define (get-selection-as-text self for-scheme-mode? focus-object-table)
|
|
(if for-scheme-mode?
|
|
(let ((marked (select-list-get-marked selection-list)))
|
|
(prepare-selection-for-scheme-mode marked))
|
|
""))
|
|
|
|
(lambda (message)
|
|
(case message
|
|
((paint)
|
|
(lambda (self win result-buffer have-focus?)
|
|
(let ((hdr-len (header-length header)))
|
|
(for-each (lambda (text y)
|
|
(mvwaddstr win y 0 text))
|
|
header
|
|
(iota hdr-len))
|
|
(paint-selection-list-at
|
|
selection-list
|
|
0 hdr-len
|
|
win (result-buffer-num-cols result-buffer) have-focus?))))
|
|
((key-press)
|
|
(lambda (self key control-x-pressed?)
|
|
(cond
|
|
((= key down-key)
|
|
(inspect-next-continuation))
|
|
((= key up-key)
|
|
(pop-val!))
|
|
((= key inspect-key)
|
|
(push-val! (select-list-selected-entry selection-list)))
|
|
(else
|
|
(set! selection-list
|
|
(select-list-handle-key-press
|
|
selection-list key))))
|
|
self))
|
|
((get-selection-as-ref)
|
|
get-selection-as-ref)
|
|
((get-selection-as-text)
|
|
get-selection-as-text)
|
|
(else
|
|
(debug-message "inspector did not handle message " message))))))
|
|
|
|
|
|
(define-record-type inspection-object :inspection-object
|
|
(make-inspection-object val)
|
|
inspection-object?
|
|
(val inspection-object-val))
|
|
|
|
(register-plugin!
|
|
(make-view-plugin (lambda (iv buffer)
|
|
(make-inspector (inspection-object-val iv) buffer))
|
|
inspection-object?))
|
|
|
|
(define (with-inspector-handler thunk)
|
|
(with-fatal-and-capturing-error-handler
|
|
(lambda (condition raw-continuation continuation decline)
|
|
(make-inspection-object (cons condition raw-continuation)))
|
|
thunk)) |