diff --git a/scheme/inspector.scm b/scheme/inspector.scm index c8ff958..29ed3c3 100644 --- a/scheme/inspector.scm +++ b/scheme/inspector.scm @@ -1,26 +1,5 @@ -(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 @@ -35,7 +14,6 @@ (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) "")))) @@ -51,58 +29,6 @@ (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")) @@ -112,63 +38,66 @@ (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?)))) +(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 (length header)) + focus-obj))) - ((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) + (if (continuation? val) + (set! stack (cons stack (continuation-parent val))) + (set! header + "Can't go down from a non-continuation."))) -(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)) + (define (inspector-state-pop-value) + (if (null? stack) + (set! header "Can't go up from here.") + (begin + (set! header (make-header (car stack) num-cols)) + (set! val (car stack)) + (set! stack (cdr stack)) + (set! selection-list + (make-inspector-selection-list + num-cols + (- num-lines (length header)) + val))))) + (lambda (message) + (case message + ((paint) + (lambda (self win result-buffer have-focus?) + (let ((hdr-len (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 have-focus?)))) + + ((key-press) + (lambda (self key control-x-pressed?) + (cond + ((= key down-key) + (inspect-next-continuation)) + ((= key up-key) + (inspector-state-pop-value)) + (else + (set! selection-list + (select-list-handle-key-press + selection-list key)))) + self)) + (else + (error "did not handle message " message)))))) (register-plugin! - (make-view-plugin error-receiver exception-continuation?)) - -(register-plugin! - (make-view-plugin inspector-receiver inspector-state?)) + (make-view-plugin make-inspector exception-continuation?)) diff --git a/scheme/process.scm b/scheme/process.scm index 7f9404c..6c22393 100644 --- a/scheme/process.scm +++ b/scheme/process.scm @@ -30,22 +30,15 @@ processes) num-lines))) -(define (make-pps-viewer) - (let ((processes #f) - (select-list #f)) +(define (make-pps-viewer processes buffer) + (let ((processes processes) + (select-list + (make-process-selection-list + (result-buffer-num-cols buffer) + (result-buffer-num-lines buffer) + processes))) (lambda (message) (cond - - ((eq? message 'init) - (lambda (self process-list buffer) - (let ((num-cols (result-buffer-num-cols buffer)) - (num-lines (result-buffer-num-lines buffer))) - (set! processes process-list) - (set! select-list - (make-process-selection-list - num-cols num-lines processes)) - self))) - ((eq? message 'paint) (lambda (self . args) (apply paint-selection-list diff --git a/scheme/std-viewer.scm b/scheme/std-viewer.scm index bb15c4b..cefa830 100644 --- a/scheme/std-viewer.scm +++ b/scheme/std-viewer.scm @@ -1,21 +1,12 @@ -(define (make-standard-viewer) +(define (make-standard-viewer value buffer) (let ((x 1) (y 1) - (text "") - (value #f)) - + (value value) + (text (layout-result-standard + (exp->string value) + (result-buffer-num-cols buffer)))) (lambda (message) (cond - - ((eq? message 'init) - (lambda (self new-value buffer) - (set! value new-value) - (set! text - (layout-result-standard - (exp->string value) - (result-buffer-num-cols buffer))) - self)) - ((eq? message 'paint) (lambda (self win buffer have-focus?) ;; #### get rid of this cruft