commander-s/scheme/inspector.scm

(define-record-type inspector-state :inspector-state
  (make-inspector-state val stack)
  inspector-state?
  (val inspector-state-val)
  (stack inspector-state-stack))


(define (inspect-value val)
  (make-inspector-state val '()))

(define key-d 100)
(define key-u 117)

(define down-key key-d)
(define up-key key-u)

(define (inspector-receiver message)
  (debug-message "inspector-receiver " message)
  (cond 
   ((init-with-result-message? message)
    (make-inspector-state (init-with-result-message-result message) '()))
   ((print-message? message)
    (let ((val (inspector-state-val (message-result-object message))))
      (let ((head-line (format #f "~a" val))
            (menu (map (lambda (val) (format #f "~a" val)) (prepare-menu val))))
	(make-simple-result-buffer-printer
	 1 1 (cons head-line menu) '() '()))))

   ((key-pressed-message? message)
    (let ((old-state (message-result-object message))
          (key (key-pressed-message-key message)))
      (cond
       ((= key down-key)
        (inspect-next-continuation old-state))
       ((= key up-key)
        (pop-inspector-stack old-state))
       (else old-state))))
   (else
    (debug-message "did not handle message " message))))

(define (inspect-next-continuation state)
  (let ((val (inspector-state-val state)))
    (if (continuation? val)
        (make-inspector-state (continuation-parent val)
                              (cons val (inspector-state-stack state)))
        (begin
          (debug-message "Can't go down from a non-continuation." val)
          state))))
        
(define (pop-inspector-stack state)
  (let ((stack (inspector-state-stack state)))
    (if (null? stack)
        (begin
          (debug-message "Can't go up from here.")
          state)
        (make-inspector-state (car stack)
                              (cdr stack)))))
   
(define (error-receiver message)
  (debug-message "error-receiver " message)
  (cond
   ((init-with-result-message? message)
    (make-inspector-state (init-with-result-message-result message) '()))
   (else
    (inspector-receiver message)))) ;; inheritance!


(register-plugin! 
 (make-view-plugin error-receiver exception-continuation?))

(register-plugin! 
 (make-view-plugin inspector-receiver inspector-state?))