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