commander-s/scheme/inspector.scm

(define-record-type inspector-state :inspector-state
  (make-inspector-state val stack header num-cols num-lines selection-list)
  inspector-state?
  (val inspector-state-val)
  (stack inspector-state-stack)
  (header inspector-state-header)
  (num-cols inspector-state-num-cols)
  (num-lines inspector-state-num-lines)
  (selection-list inspector-state-selection-list))

(define footer-length 0)

(define (make-initial-inspector-state focus-obj num-cols num-lines)
  (let ((header (make-header focus-obj num-cols)))
    (make-inspector-state focus-obj
                          '()
                          header
                          num-cols
                          num-lines
                          (make-inspector-selection-list num-cols
                                                         (- num-lines (length header))
                                                         focus-obj))))

(define (make-inspector-selection-list num-cols num-lines focus-obj)
  (let ((menu (prepare-menu focus-obj)))
    (make-select-list
     (map (lambda (e)
	    (make-unmarked-element 
	     (cdr e) #t (layout-menu-entry num-cols e)))
	  menu) 
     num-lines)))

(define (make-header focus-obj num-cols)
  (list (val-to-string focus-obj num-cols)
        (if (exception-continuation? focus-obj)
            "Press cont-down key to see more"
            "")))
 

(define (layout-menu-entry num-cols entry)
  (let ((head (format #f "[~a]" (or (car entry) ""))))
    (string-append head (val-to-string (cdr entry) 
                                       (- num-cols (string-length head))))))

(define (val-to-string val max-length)
  (let ((out (open-output-string)))
    (limited-write val 
                   out 
                   3 
                   5)
    (let ((str (get-output-string out)))
      (substring str 0 (min (string-length str) max-length)))))

(define (inspector-state-exchange-selection-list old-state sl)
  (make-inspector-state (inspector-state-val old-state)
                        (inspector-state-stack old-state)
                        (inspector-state-header old-state)
                        (inspector-state-num-cols old-state)
                        (inspector-state-num-lines old-state)
                        sl))

(define (inspector-state-exchange-header-msg old-state msg)
  (make-inspector-state  (inspector-state-val old-state)
                         (inspector-state-stack old-state)
                         (cons (car (inspector-state-header old-state))
                               (list msg))
                         (inspector-state-num-cols old-state)
                         (inspector-state-num-lines old-state)
                         (inspector-state-selection-list old-state)))


(define (inspector-state-push-value state val)
  (let* ((num-cols (inspector-state-num-cols state))
         (num-lines (inspector-state-num-lines state))
         (hdr (make-header val num-cols)))
    (make-inspector-state val
                          (cons (inspector-state-val state)
                                (inspector-state-stack state))
                          hdr
                          num-cols
                          num-lines
                          (make-inspector-selection-list
                           num-cols
                           (- num-lines (length hdr))
                           val))))

(define (inspector-state-pop-value state)
  (let ((stack (inspector-state-stack state))
        (num-cols (inspector-state-num-cols state))
        (num-lines (inspector-state-num-lines state)))
    (if (null? stack)
        (inspector-state-exchange-header-msg state
                                             "Can't go up from here.")
        (let ((hdr (make-header (car stack) num-cols)))
          (make-inspector-state (car stack)
                                (cdr stack)
                                hdr
                                num-cols
                                num-lines
                                (make-inspector-selection-list
                                 num-cols
                                 (- num-lines (length hdr))
                                 (car stack)))))))

                        
(define (inspect-value val)
  (error "not yet"))

(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)
    (let* ((focus-obj (init-with-result-message-result message))
           (buffer (init-with-result-message-buffer message))
           (num-cols (result-buffer-num-cols buffer))
           (num-lines (result-buffer-num-lines buffer)))
      (make-initial-inspector-state focus-obj
                                    num-cols
                                    num-lines)))
   ((print-message? message)
    (lambda (win result-buffer have-focus?)
      (let* ((state (message-result-object message))
             (hdr (inspector-state-header state))
             (hdr-len (length hdr)))
        (for-each (lambda (text y)
                    (mvwaddstr win y 0 text))
                  hdr
                  (iota hdr-len))
        ((paint-selection-list-at
          (inspector-state-selection-list state)
          0 hdr-len)
         win result-buffer have-focus?))))

   ((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)
        (inspector-state-pop-value old-state))
       (else
        (let ((old-state (message-result-object message)))
          (inspector-state-exchange-selection-list
           old-state
           (select-list-handle-key-press
            (inspector-state-selection-list old-state)
            message)))))))
   (else
    (debug-message "did not handle message " message))))

(define (inspect-next-continuation state)
  (let ((val (inspector-state-val state)))
    (if (continuation? val)
        (inspector-state-push-value state (continuation-parent val))
        (inspector-state-exchange-header-msg
         state
         "Can't go down from a non-continuation."))))
        
(define (error-receiver message)
  (inspector-receiver message))


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

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