diff --git a/scheme/inspector.scm b/scheme/inspector.scm index 164776b..2cc87e1 100644 --- a/scheme/inspector.scm +++ b/scheme/inspector.scm @@ -1,12 +1,110 @@ (define-record-type inspector-state :inspector-state - (make-inspector-state val stack) + (make-inspector-state val stack header num-cols num-lines selection-list) inspector-state? (val inspector-state-val) - (stack inspector-state-stack)) + (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 + (zip + (map cdr menu) ;; drop name + (map (lambda (e) #t) menu) ;; all are selectable + (map (lambda (e) (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) - (make-inspector-state val '())) + (error "not yet")) (define key-d 100) (define key-u 117) @@ -18,13 +116,26 @@ (debug-message "inspector-receiver " message) (cond ((init-with-result-message? message) - (make-inspector-state (init-with-result-message-result 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) - (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) '() '())))) + (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)) @@ -33,36 +144,27 @@ ((= key down-key) (inspect-next-continuation old-state)) ((= key up-key) - (pop-inspector-stack old-state)) - (else old-state)))) + (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) - (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)))) + (inspector-state-push-value state (continuation-parent val)) + (inspector-state-exchange-header-msg + state + "Can't go down from a non-continuation.")))) -(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! + (inspector-receiver message)) (register-plugin! diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index 4586dbd..0810ef0 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -148,8 +148,13 @@ continuations formats define-record-types - - layout + srfi-1 + srfi-6 + display-conditions + + ncurses + layout + select-list tty-debug plugin) (files inspector))