scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Use select-list in the inspector

This commit is contained in:
mainzelm 2005-05-25 15:18:26 +00:00
parent 6ef959883f
commit 026c86a317
2 changed files with 140 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

164
scheme/inspector.scm
View File

@ -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!

9
scheme/nuit-packages.scm
View File

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