commander-s/scheme/inspector.scm

(define footer-length 0)

(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-text-element 
	     (cdr 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 (cdr 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 (inspect-value val)
  (error "not yet"))

(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))))))

(register-plugin! 
 (make-view-plugin make-inspector exception-continuation?))