Kill `browse-list' plugin. Introduce module `select-list', a library
for programming multi-page menus in the result-buffer. Remove the print-object and make plugins return a function to paint the result-buffer instead.
This commit is contained in:
eknauel
parent
4e7e1301cb
commit
0447ccfa3e
|
|
@ -161,7 +161,11 @@
|
|||
(marked-pos (get-marked-positions-3
|
||||
(browse-dir-list-res-obj-file-list model)
|
||||
(browse-dir-list-res-obj-marked-items model))))
|
||||
(make-print-object pos-y pos-x text (list pos-y) marked-pos)))
|
||||
(debug-message "browse-dir-list-receiver "
|
||||
"pos-y " pos-y " pos-x " pos-x
|
||||
" marked-pos " marked-pos)
|
||||
(make-simple-result-buffer-printer
|
||||
pos-y pos-x text (list pos-y) marked-pos)))
|
||||
|
||||
((key-pressed-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,15 @@
|
|||
(define-syntax run/strings-status
|
||||
(syntax-rules ()
|
||||
((_ epf)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(run/port+proc epf))
|
||||
(lambda (port proc)
|
||||
(let ((string-list (port->string-list port))
|
||||
(status (wait proc)))
|
||||
(close-input-port port)
|
||||
(values string-list status)))))))
|
||||
|
||||
(define (directory-files . optional-args)
|
||||
(let-optionals optional-args
|
||||
((dir (cwd))
|
||||
|
|
|
|||
|
|
@ -23,8 +23,9 @@
|
|||
(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-print-object 1 1 (cons head-line menu)
|
||||
'() '()))))
|
||||
(make-simple-result-buffer-printer
|
||||
1 1 (cons head-line menu) '() '()))))
|
||||
|
||||
((key-pressed-message? message)
|
||||
(let ((old-state (message-result-object message))
|
||||
(key (key-pressed-message-key message)))
|
||||
|
|
|
|||
|
|
@ -61,3 +61,129 @@
|
|||
(let ((tmp (list-tail l pos)))
|
||||
(reverse (list-tail (reverse tmp)
|
||||
(- (length tmp) k)))))
|
||||
|
||||
;; crappy redrawing code
|
||||
|
||||
(define-record-type result-buffer :result-buffer
|
||||
(make-result-buffer line column y x num-lines num-cols highlighted marked)
|
||||
result-buffer?
|
||||
(line result-buffer-line
|
||||
set-result-buffer-line!)
|
||||
(column result-buffer-column
|
||||
set-result-buffer-column!)
|
||||
(y result-buffer-y set-result-buffer-y!)
|
||||
(x result-buffer-x set-result-buffer-x!)
|
||||
(num-lines result-buffer-num-lines
|
||||
set-result-buffer-num-lines!)
|
||||
(num-cols result-buffer-num-cols
|
||||
set-result-buffer-num-cols!)
|
||||
(highlighted result-buffer-highlighted
|
||||
set-result-buffer-highlighted!)
|
||||
(marked result-buffer-marked
|
||||
set-result-buffer-marked!))
|
||||
|
||||
;;selection of the visible area of the buffer
|
||||
(define (prepare-lines l height pos)
|
||||
(if (< (length l) height)
|
||||
(let loop ((tmp-list l))
|
||||
(if (= height (length tmp-list))
|
||||
tmp-list
|
||||
(loop (append tmp-list (list "")))))
|
||||
(if (< pos height)
|
||||
(sublist l 0 height)
|
||||
(sublist l (- pos height) height))))
|
||||
|
||||
(define (get-right-result-lines result-buffer text)
|
||||
(prepare-lines text
|
||||
(result-buffer-num-lines result-buffer)
|
||||
(result-buffer-line result-buffer)))
|
||||
|
||||
;;marked and highlighted lines
|
||||
(define (right-highlighted-lines result-buffer lines)
|
||||
(let ((pos-result (result-buffer-line result-buffer))
|
||||
(result-lines (result-buffer-num-lines result-buffer)))
|
||||
(let loop ((lines lines) (new '()))
|
||||
(if (null? lines)
|
||||
new
|
||||
(let ((el (car lines)))
|
||||
(if (<= pos-result result-lines)
|
||||
;;auf der ersten Seite
|
||||
(loop (cdr lines)
|
||||
(append new (list el)))
|
||||
(let* ((offset (- pos-result result-lines))
|
||||
(new-el (- el offset)))
|
||||
(loop (cdr lines)
|
||||
(append new (list new-el))))))))))
|
||||
|
||||
(define (right-marked-lines result-buffer lines)
|
||||
(let ((pos-result (result-buffer-column result-buffer))
|
||||
(result-lines (result-buffer-num-lines result-buffer))
|
||||
(marked-lines (result-buffer-marked result-buffer)))
|
||||
(let loop ((old marked-lines)
|
||||
(new '()))
|
||||
(if (null? old)
|
||||
new
|
||||
(let ((el (car old)))
|
||||
(if (<= pos-result result-lines)
|
||||
;;auf der ersten Seite
|
||||
(loop (cdr old)
|
||||
(append new (list el)))
|
||||
(let* ((offset (- pos-result result-lines))
|
||||
(new-el (- el offset )))
|
||||
(loop (cdr old)
|
||||
(append new (list new-el))))))))))
|
||||
|
||||
(define (make-simple-result-buffer-printer
|
||||
pos-y pos-x text highlighted-lines marked-lines)
|
||||
(lambda (window result-buffer result-buffer-has-focus?)
|
||||
|
||||
(set-result-buffer-y! result-buffer pos-y)
|
||||
(set-result-buffer-column! result-buffer pos-x)
|
||||
(set-result-buffer-highlighted! result-buffer
|
||||
highlighted-lines)
|
||||
(set-result-buffer-marked! result-buffer
|
||||
marked-lines)
|
||||
(set-result-buffer-highlighted!
|
||||
result-buffer (right-highlighted-lines result-buffer text))
|
||||
(set-result-buffer-marked!
|
||||
result-buffer (right-marked-lines result-buffer text))
|
||||
|
||||
(let ((lines (get-right-result-lines result-buffer text))
|
||||
(result-lines (result-buffer-num-lines result-buffer))
|
||||
(result-cols (result-buffer-num-cols result-buffer)))
|
||||
|
||||
(let loop ((pos 1))
|
||||
(if (> pos result-lines)
|
||||
(values)
|
||||
(let* ((line (list-ref lines (- pos 1)))
|
||||
(fitting-line
|
||||
(if (> (string-length line) result-cols)
|
||||
(let ((start-line
|
||||
(substring line 0
|
||||
(- (ceiling (/ result-cols 2))
|
||||
3)))
|
||||
(end-line
|
||||
(substring line
|
||||
(- (string-length line)
|
||||
(ceiling
|
||||
(/ result-cols 2)))
|
||||
(string-length line))))
|
||||
(string-append start-line "..." end-line))
|
||||
line)))
|
||||
(if (and result-buffer-has-focus?
|
||||
(member pos highlighted-lines))
|
||||
(begin
|
||||
(wattron window (A-REVERSE))
|
||||
(mvwaddstr window pos 1 line)
|
||||
(wattrset window (A-NORMAL))
|
||||
(loop (+ pos 1)))
|
||||
(if (member pos marked-lines)
|
||||
(begin
|
||||
(wattron window (A-BOLD))
|
||||
(mvwaddstr window pos 1 line)
|
||||
(wattrset window (A-NORMAL))
|
||||
(loop (+ pos 1)))
|
||||
(begin
|
||||
(mvwaddstr window pos 1 line)
|
||||
(loop (+ pos 1)))))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -56,31 +56,11 @@
|
|||
;;state of the lower window (Result-Window)
|
||||
;;----------------------------
|
||||
;;Text
|
||||
(define text-result (list "Type 'shortcuts' for help"))
|
||||
|
||||
;;line of the result-window
|
||||
(define pos-result 0)
|
||||
|
||||
;;column
|
||||
(define pos-result-col 0)
|
||||
|
||||
;;y-coordinate of the cursor in the result-buffer
|
||||
(define result-buffer-pos-y 0)
|
||||
|
||||
;;x-coordinate of the cursor in the result-buffer
|
||||
(define result-buffer-pos-x 0)
|
||||
|
||||
;;lines of the lower window
|
||||
(define result-lines 0)
|
||||
|
||||
;;columns in the lower window
|
||||
(define result-cols 0)
|
||||
|
||||
;;lines to be highlighted
|
||||
(define highlighted-lines '())
|
||||
|
||||
;;lines to be marked
|
||||
(define marked-lines '())
|
||||
(define result-buffer
|
||||
(make-result-buffer 0 0 0 0
|
||||
#f #f ; set in INIT-WINDOWS
|
||||
'() '()))
|
||||
|
||||
;;miscelaneous state
|
||||
;;-------------------
|
||||
|
|
@ -221,7 +201,7 @@
|
|||
(refresh-result-window))
|
||||
(else
|
||||
(focus-command-buffer!)
|
||||
(move-cursor command-buffer)
|
||||
(move-cursor command-buffer result-buffer)
|
||||
(refresh-command-window))))
|
||||
|
||||
(define (toggle-command/scheme-mode)
|
||||
|
|
@ -232,7 +212,7 @@
|
|||
(enter-command-mode!)))
|
||||
(paint-command-frame-window)
|
||||
(paint-command-window-contents)
|
||||
(move-cursor command-buffer)
|
||||
(move-cursor command-buffer result-buffer)
|
||||
(refresh-command-window))
|
||||
|
||||
(define (handle-return-key)
|
||||
|
|
@ -323,6 +303,7 @@
|
|||
(let ((key-message
|
||||
(make-key-pressed-message
|
||||
(active-command) (current-result)
|
||||
result-buffer
|
||||
ch key-control-x)))
|
||||
(update-current-result!
|
||||
(post-message
|
||||
|
|
@ -373,8 +354,10 @@
|
|||
(history-entry-plugin (entry-data (current-history-item)))
|
||||
(make-key-pressed-message
|
||||
(active-command) (current-result)
|
||||
result-buffer
|
||||
ch c-x-pressed?)))
|
||||
(paint-result-window (entry-data (current-history-item)))
|
||||
(move-cursor command-buffer result-buffer)
|
||||
(refresh-result-window))
|
||||
(loop (wait-for-input) #f))
|
||||
(else
|
||||
|
|
@ -382,7 +365,7 @@
|
|||
(werase (app-window-curses-win command-window))
|
||||
(print-command-buffer (app-window-curses-win command-window)
|
||||
command-buffer)
|
||||
(move-cursor command-buffer)
|
||||
(move-cursor command-buffer result-buffer)
|
||||
(refresh-command-window)
|
||||
(loop (wait-for-input) c-x-pressed?)))))))
|
||||
|
||||
|
|
@ -428,6 +411,11 @@
|
|||
result-frame-window result-window)))
|
||||
(for-each window-init-curses-win! all-windows)
|
||||
|
||||
(set-result-buffer-num-lines!
|
||||
result-buffer (- (app-window-height result-window) 2))
|
||||
(set-result-buffer-num-cols!
|
||||
result-buffer (- (app-window-width result-window) 3))
|
||||
|
||||
(debug-message "init-windows!: bar-1 " bar-1
|
||||
" active-command-window " active-command-window
|
||||
" command-frame-window " command-frame-window
|
||||
|
|
@ -480,9 +468,6 @@
|
|||
(let ((win (app-window-curses-win result-frame-window)))
|
||||
(wclear win)
|
||||
(box win (ascii->char 0) (ascii->char 0))
|
||||
;;; EK: wtf is going on here?
|
||||
(set! result-lines (- (app-window-height result-window) 2))
|
||||
(set! result-cols (- (app-window-width result-window) 3))
|
||||
(wrefresh win)))
|
||||
|
||||
(define (paint-result-window entry)
|
||||
|
|
@ -502,7 +487,7 @@
|
|||
(paint-active-command-window)
|
||||
(scroll-command-buffer)
|
||||
(paint-command-window-contents)
|
||||
(move-cursor command-buffer)
|
||||
(move-cursor command-buffer result-buffer)
|
||||
(refresh-result-window)
|
||||
(refresh-command-window))
|
||||
|
||||
|
|
@ -514,7 +499,7 @@
|
|||
(paint-active-command-window)
|
||||
(paint-result-frame-window)
|
||||
;(paint-result-window)
|
||||
(move-cursor command-buffer)
|
||||
(move-cursor command-buffer result-buffer)
|
||||
(refresh-command-window)
|
||||
(refresh-result-window))
|
||||
|
||||
|
|
@ -665,17 +650,6 @@
|
|||
(add-to-command-buffer (char->ascii first-ch))
|
||||
(loop (substring str 1 (string-length str)))))))
|
||||
|
||||
;;selection of the visible area of the buffer
|
||||
(define (prepare-lines l height pos)
|
||||
(if (< (length l) height)
|
||||
(let loop ((tmp-list l))
|
||||
(if (= height (length tmp-list))
|
||||
tmp-list
|
||||
(loop (append tmp-list (list "")))))
|
||||
(if (< pos height)
|
||||
(sublist l 0 height)
|
||||
(sublist l (- pos height) height))))
|
||||
|
||||
;;; FIXME: I guess s48 knows a better way to do this (see ,inspect)
|
||||
(define (maybe-shorten-string string width)
|
||||
(if (> (string-length string) width)
|
||||
|
|
@ -696,115 +670,35 @@
|
|||
(history-entry-command (entry-data entry)) width)))))
|
||||
(wrefresh win)))
|
||||
|
||||
(define (paint-result-buffer print-object)
|
||||
(let* ((window (app-window-curses-win result-window))
|
||||
(text (print-object-text print-object))
|
||||
(pos-y (print-object-pos-y print-object))
|
||||
(pos-x (print-object-pos-x print-object))
|
||||
(highlighted-lns (print-object-highlighted-lines print-object))
|
||||
(marked-lns (print-object-marked-lines print-object)))
|
||||
(set! text-result text)
|
||||
(set! pos-result pos-y)
|
||||
(set! pos-result-col pos-x)
|
||||
(set! highlighted-lines highlighted-lns)
|
||||
(set! marked-lines marked-lns)
|
||||
(right-highlighted-lines)
|
||||
(right-marked-lines)
|
||||
(let ((lines (get-right-result-lines)))
|
||||
(let loop ((pos 1))
|
||||
(if (> pos result-lines)
|
||||
(values)
|
||||
(let ((line (list-ref lines (- pos 1))))
|
||||
(begin
|
||||
(if (not (standard-result-obj? (current-result)))
|
||||
(set! line
|
||||
(if (> (string-length line) result-cols)
|
||||
(let ((start-line
|
||||
(substring line 0
|
||||
(- (ceiling (/ result-cols 2))
|
||||
3)))
|
||||
(end-line
|
||||
(substring line
|
||||
(- (string-length line)
|
||||
(ceiling
|
||||
(/ result-cols 2)))
|
||||
(string-length line))))
|
||||
(string-append start-line "..." end-line))
|
||||
line)))
|
||||
(if (and (member pos highlighted-lines)
|
||||
(focus-on-result-buffer?))
|
||||
(begin
|
||||
(wattron window (A-REVERSE))
|
||||
(mvwaddstr window pos 1 line)
|
||||
(wattrset window (A-NORMAL))
|
||||
;(wrefresh window)
|
||||
(loop (+ pos 1)))
|
||||
(if (member pos marked-lines)
|
||||
(begin
|
||||
(wattron window (A-BOLD))
|
||||
(mvwaddstr window pos 1 line)
|
||||
(wattrset window (A-NORMAL))
|
||||
;(wrefresh window)
|
||||
(loop (+ pos 1)))
|
||||
(begin
|
||||
(mvwaddstr window pos 1 line)
|
||||
;(wrefresh window)
|
||||
(loop (+ pos 1))))))))))))
|
||||
|
||||
;;visible lines
|
||||
(define (get-right-result-lines)
|
||||
(prepare-lines text-result result-lines pos-result))
|
||||
|
||||
;;marked and highlighted lines
|
||||
(define (right-highlighted-lines)
|
||||
(let loop ((old highlighted-lines)
|
||||
(new '()))
|
||||
(if (null? old)
|
||||
(set! highlighted-lines new)
|
||||
(let ((el (car old)))
|
||||
(if (<= pos-result result-lines)
|
||||
;;auf der ersten Seite
|
||||
(loop (cdr old)
|
||||
(append new (list el)))
|
||||
(let* ((offset (- pos-result result-lines))
|
||||
(new-el (- el offset )))
|
||||
(loop (cdr old)
|
||||
(append new (list new-el)))))))))
|
||||
|
||||
(define (right-marked-lines)
|
||||
(let loop ((old marked-lines)
|
||||
(new '()))
|
||||
(if (null? old)
|
||||
(set! marked-lines new)
|
||||
(let ((el (car old)))
|
||||
(if (<= pos-result result-lines)
|
||||
;;auf der ersten Seite
|
||||
(loop (cdr old)
|
||||
(append new (list el)))
|
||||
(let* ((offset (- pos-result result-lines))
|
||||
(new-el (- el offset )))
|
||||
(loop (cdr old)
|
||||
(append new (list new-el)))))))))
|
||||
(define (paint-result-buffer paint-proc)
|
||||
(paint-proc (app-window-curses-win result-window)
|
||||
result-buffer
|
||||
(focus-on-result-buffer?)))
|
||||
|
||||
;;Cursor
|
||||
;;move cursor to the corrct position
|
||||
(define (move-cursor buffer)
|
||||
(if (focus-on-command-buffer?)
|
||||
(cursor-right-pos (app-window-curses-win command-window)
|
||||
buffer)
|
||||
(begin
|
||||
(compute-y-x)
|
||||
(wmove (app-window-curses-win result-window)
|
||||
result-buffer-pos-y result-buffer-pos-x)
|
||||
(wrefresh (app-window-curses-win result-window))
|
||||
buffer)))
|
||||
(define (move-cursor command-buffer result-buffer)
|
||||
(cond
|
||||
((focus-on-command-buffer?)
|
||||
(cursor-right-pos
|
||||
(app-window-curses-win command-window)
|
||||
command-buffer))
|
||||
(else
|
||||
(compute-y-x result-buffer)
|
||||
(wmove (app-window-curses-win result-window)
|
||||
(result-buffer-y result-buffer)
|
||||
(result-buffer-x result-buffer))
|
||||
(wrefresh (app-window-curses-win result-window)))))
|
||||
|
||||
;;compue pos-x and pos-y
|
||||
(define (compute-y-x)
|
||||
(if (>= pos-result result-lines)
|
||||
(set! result-buffer-pos-y result-lines)
|
||||
(set! result-buffer-pos-y pos-result))
|
||||
(set! result-buffer-pos-x pos-result-col))
|
||||
(define (compute-y-x result-buffer)
|
||||
(let ((pos-result (result-buffer-line result-buffer))
|
||||
(pos-result-col (result-buffer-column result-buffer))
|
||||
(result-lines (result-buffer-num-lines result-buffer)))
|
||||
(if (>= pos-result result-lines)
|
||||
(set-result-buffer-y! result-buffer result-lines)
|
||||
(set-result-buffer-y! result-buffer pos-result))
|
||||
(set-result-buffer-x! result-buffer pos-result-col)))
|
||||
|
||||
(define (sublist l pos k)
|
||||
(let ((tmp (list-tail l pos)))
|
||||
|
|
@ -814,15 +708,6 @@
|
|||
;;When NUIT is closed the state has to be restored, in order to let the
|
||||
;;user start again from scratch
|
||||
(define (restore-state)
|
||||
(set! text-result (list "Start entering commands."))
|
||||
(set! pos-result 0)
|
||||
(set! pos-result-col 0)
|
||||
(set! result-buffer-pos-y 0)
|
||||
(set! result-buffer-pos-x 0)
|
||||
(set! result-lines 0)
|
||||
(set! result-cols 0)
|
||||
(set! highlighted-lines '())
|
||||
(set! marked-lines '())
|
||||
(set! history '())
|
||||
(set! history-pos 0)
|
||||
(set! active-keyboard-interrupt #f))
|
||||
|
|
@ -846,8 +731,8 @@
|
|||
(result-text standard-result-obj-result-text)
|
||||
(result standard-result-obj-result))
|
||||
|
||||
(define init-std-res (make-standard-result-obj 1 1 text-result
|
||||
(car text-result)))
|
||||
(define init-std-res
|
||||
(make-standard-result-obj 1 1 '("") ""))
|
||||
|
||||
;;Standard-Receiver:
|
||||
(define (standard-receiver-rec message)
|
||||
|
|
@ -874,7 +759,9 @@
|
|||
(result (standard-result-obj-result model))
|
||||
(text (layout-result-standard
|
||||
(exp->string result) width)))
|
||||
(make-print-object pos-y pos-x text '() '())))
|
||||
(make-simple-result-buffer-printer
|
||||
pos-y pos-x text '() '())))
|
||||
|
||||
((key-pressed-message? message)
|
||||
(message-result-object message))
|
||||
((restore-message? message)
|
||||
|
|
|
|||
|
|
@ -26,12 +26,36 @@
|
|||
get-marked-positions-2
|
||||
get-marked-positions-3
|
||||
exp->string
|
||||
sublist))
|
||||
sublist
|
||||
|
||||
;; old drawing cruft
|
||||
make-result-buffer
|
||||
result-buffer?
|
||||
result-buffer-line
|
||||
set-result-buffer-line!
|
||||
result-buffer-column
|
||||
set-result-buffer-column!
|
||||
result-buffer-y
|
||||
set-result-buffer-y!
|
||||
result-buffer-x
|
||||
set-result-buffer-x!
|
||||
result-buffer-num-lines
|
||||
set-result-buffer-num-lines!
|
||||
result-buffer-num-cols
|
||||
set-result-buffer-num-cols!
|
||||
result-buffer-highlighted
|
||||
set-result-buffer-highlighted!
|
||||
result-buffer-marked
|
||||
set-result-buffer-marked!
|
||||
make-simple-result-buffer-printer))
|
||||
|
||||
(define-structure layout layout-interface
|
||||
(open scheme
|
||||
srfi-6 ;; basic string ports
|
||||
)
|
||||
define-record-types
|
||||
|
||||
tty-debug
|
||||
ncurses)
|
||||
(files layout))
|
||||
|
||||
;;; process viewer plugin
|
||||
|
|
@ -39,10 +63,14 @@
|
|||
(define-structure process-view-plugin
|
||||
(export)
|
||||
(open scheme
|
||||
define-record-types
|
||||
srfi-1
|
||||
srfi-13
|
||||
formats
|
||||
|
||||
pps
|
||||
plugin
|
||||
select-list
|
||||
tty-debug)
|
||||
(files process))
|
||||
|
||||
|
|
@ -60,17 +88,6 @@
|
|||
tty-debug)
|
||||
(files browse-directory-list))
|
||||
|
||||
;;; browse-list plugin
|
||||
|
||||
(define-structure browse-list-plugin
|
||||
(export)
|
||||
(open scheme
|
||||
define-record-types
|
||||
ncurses
|
||||
plugin
|
||||
layout)
|
||||
(files browse-list))
|
||||
|
||||
;;; standard command plugin
|
||||
|
||||
(define-structure standard-command-plugin
|
||||
|
|
@ -92,6 +109,31 @@
|
|||
define-record-types)
|
||||
(files fs-object))
|
||||
|
||||
;;; browse list stuff
|
||||
|
||||
(define-interface select-list-interface
|
||||
(export make-select-list
|
||||
select-list?
|
||||
select-list-cursor-index
|
||||
select-list-cursor-y
|
||||
select-list-handle-key-press
|
||||
unmark-current-line
|
||||
mark-current-line
|
||||
move-cursor-up
|
||||
move-cursor-down
|
||||
paint-selection-list))
|
||||
|
||||
(define-structure select-list select-list-interface
|
||||
(open scheme
|
||||
srfi-1
|
||||
define-record-types
|
||||
|
||||
tty-debug
|
||||
plugin
|
||||
layout
|
||||
ncurses)
|
||||
(files select-list))
|
||||
|
||||
;;; inspector
|
||||
|
||||
(define-interface nuit-inspector-interface
|
||||
|
|
@ -104,6 +146,7 @@
|
|||
formats
|
||||
define-record-types
|
||||
|
||||
layout
|
||||
tty-debug
|
||||
plugin)
|
||||
(files inspector))
|
||||
|
|
@ -138,14 +181,6 @@
|
|||
|
||||
register-plugin!
|
||||
|
||||
make-print-object
|
||||
print-object?
|
||||
print-object-pos-y
|
||||
print-object-pos-x
|
||||
print-object-text
|
||||
print-object-highlighted-lines
|
||||
print-object-marked-lines
|
||||
|
||||
next-command-message?
|
||||
next-command-string
|
||||
next-command-message-parameters
|
||||
|
|
@ -156,6 +191,7 @@
|
|||
init-with-result-message-width
|
||||
|
||||
key-pressed-message?
|
||||
key-pressed-message-result-buffer
|
||||
key-pressed-message-result-object
|
||||
key-pressed-message-key
|
||||
key-pressed-message-prefix-key
|
||||
|
|
@ -223,11 +259,9 @@
|
|||
pps
|
||||
history
|
||||
;; the following modules are plugins
|
||||
browse-list-plugin
|
||||
dirlist-view-plugin
|
||||
process-view-plugin
|
||||
standard-command-plugin
|
||||
nuit-inspector-plugin)
|
||||
(files nuit-engine
|
||||
handle-fatal-error))
|
||||
|
||||
|
|
|
|||
|
|
@ -29,21 +29,6 @@
|
|||
(set! *view-plugins* (cons plugin *view-plugins*)))
|
||||
(error "unknown plugin type" plugin)))
|
||||
|
||||
;; answers
|
||||
|
||||
(define-record-type print-object :print-object
|
||||
(make-print-object pos-y
|
||||
pos-x
|
||||
text
|
||||
highlighted-lines
|
||||
marked-lines)
|
||||
print-object?
|
||||
(pos-y print-object-pos-y)
|
||||
(pos-x print-object-pos-x)
|
||||
(text print-object-text)
|
||||
(highlighted-lines print-object-highlighted-lines)
|
||||
(marked-lines print-object-marked-lines))
|
||||
|
||||
;; messages
|
||||
|
||||
(define-record-type next-command-message :next-command-message
|
||||
|
|
@ -67,10 +52,12 @@
|
|||
(define-record-type key-pressed-message :key-pressed-message
|
||||
(make-key-pressed-message command-string
|
||||
result-object
|
||||
result-buffer
|
||||
key prefix-key)
|
||||
key-pressed-message?
|
||||
(command-string key-pressed-command-string)
|
||||
(result-object key-pressed-message-result-object)
|
||||
(result-buffer key-pressed-message-result-buffer)
|
||||
(key key-pressed-message-key)
|
||||
(prefix-key key-pressed-message-prefix-key))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,37 +1,69 @@
|
|||
(define-record-type plugin-state :plugin-state
|
||||
(make-plugin-state processes selection-list cursor-x)
|
||||
plugin-state?
|
||||
(processes plugin-state-processes)
|
||||
(selection-list plugin-state-selection-list)
|
||||
(cursor-x plugin-state-cursor-x))
|
||||
|
||||
(define-record-discloser :plugin-state
|
||||
(lambda (r)
|
||||
`(plugin-state ,(plugin-state-selection-list r))))
|
||||
|
||||
(define (list-of-processes? thing)
|
||||
(and (proper-list? thing)
|
||||
(every process-info? thing)))
|
||||
|
||||
(define (print-processes processes)
|
||||
(map (lambda (pi)
|
||||
(apply format
|
||||
(append
|
||||
(list #f
|
||||
"~A ~A ~A ~A '~A ~A'~%")
|
||||
(map (lambda (s) (s pi))
|
||||
(list process-info-pid
|
||||
process-info-ppid
|
||||
process-info-real-uid
|
||||
process-info-%cpu
|
||||
process-info-executable
|
||||
process-info-command-line)))))
|
||||
processes))
|
||||
(define (string-take-max s nchars)
|
||||
(if (>= nchars (string-length s))
|
||||
s
|
||||
(string-take s nchars)))
|
||||
|
||||
(define (layout-process width p)
|
||||
(string-take-max
|
||||
(apply format
|
||||
(append
|
||||
(list #f "~A ~A ~A ~A '~A ~A'~%")
|
||||
(map (lambda (s) (s p))
|
||||
(list process-info-pid
|
||||
process-info-ppid
|
||||
process-info-real-uid
|
||||
process-info-%cpu
|
||||
process-info-executable
|
||||
process-info-command-line))))
|
||||
width))
|
||||
|
||||
(define (make-process-selection-list width processes)
|
||||
(let ((layout (lambda (p) (layout-process width p))))
|
||||
(make-select-list
|
||||
(zip processes (map layout processes)))))
|
||||
|
||||
(define (pps-receiver message)
|
||||
(debug-message "pps-receiver " message)
|
||||
(cond
|
||||
((next-command-message? message)
|
||||
(pps))
|
||||
|
||||
((init-with-result-message? message)
|
||||
(init-with-result-message-result message))
|
||||
(let ((processes (init-with-result-message-result message))
|
||||
(width (init-with-result-message-width message)))
|
||||
(make-plugin-state
|
||||
processes (make-process-selection-list width processes) 1)))
|
||||
|
||||
((print-message? message)
|
||||
(let ((processes (message-result-object message)))
|
||||
(make-print-object 1 1 (print-processes processes)
|
||||
'() '())))
|
||||
(paint-selection-list
|
||||
(plugin-state-selection-list
|
||||
(message-result-object message))))
|
||||
|
||||
((key-pressed-message? message)
|
||||
(pps))
|
||||
(let ((old-state (message-result-object message)))
|
||||
(make-plugin-state
|
||||
(plugin-state-processes old-state)
|
||||
(select-list-handle-key-press
|
||||
(plugin-state-selection-list old-state)
|
||||
message)
|
||||
(plugin-state-cursor-x old-state))))
|
||||
|
||||
((restore-message? message)
|
||||
(values))
|
||||
|
||||
((selection-message? message)
|
||||
"'()")))
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,168 @@
|
|||
(define-record-type element :element
|
||||
(make-element marked? value text)
|
||||
element?
|
||||
(marked? element-marked? set-element-marked?!)
|
||||
(value element-value)
|
||||
(text element-text))
|
||||
|
||||
(define-record-discloser :element
|
||||
(lambda (r)
|
||||
`(element ,(element-marked? r) ,(element-text r))))
|
||||
|
||||
(define (make-unmarked-element value text)
|
||||
(make-element #f value text))
|
||||
|
||||
(define-record-type select-list :select-list
|
||||
(really-make-select-list elements view-index cursor-index cursor-y)
|
||||
select-list?
|
||||
(elements select-list-elements)
|
||||
(view-index select-list-view-index)
|
||||
(cursor-index select-list-cursor-index)
|
||||
(cursor-y select-list-cursor-y))
|
||||
|
||||
(define-record-discloser :select-list
|
||||
(lambda (r)
|
||||
`(select-list (index ,(select-list-cursor-index r))
|
||||
(view-index ,(select-list-view-index r))
|
||||
(y ,(select-list-cursor-y r)))))
|
||||
|
||||
(define (make-select-list value/text-tuples)
|
||||
(really-make-select-list
|
||||
(map (lambda (value/text)
|
||||
(apply make-unmarked-element value/text))
|
||||
value/text-tuples)
|
||||
0 0 1))
|
||||
|
||||
(define key-m 109)
|
||||
|
||||
(define key-u 117)
|
||||
|
||||
(define (select-list-handle-key-press select-list key-message)
|
||||
(let ((key (key-pressed-message-key key-message))
|
||||
(result-buffer (key-pressed-message-result-buffer key-message)))
|
||||
(cond
|
||||
((= key key-m)
|
||||
(mark-current-line select-list))
|
||||
((= key key-u)
|
||||
(unmark-current-line select-list))
|
||||
((= key key-up)
|
||||
(move-cursor-up select-list result-buffer))
|
||||
((= key key-down)
|
||||
(move-cursor-down select-list result-buffer))
|
||||
(else
|
||||
select-list))))
|
||||
|
||||
(define (mark/unmark-current-line-maker mark)
|
||||
(lambda (select-list)
|
||||
(let* ((index (select-list-cursor-index select-list))
|
||||
(elements (select-list-elements select-list)))
|
||||
(really-make-select-list
|
||||
(fold-right
|
||||
(lambda (element.i result)
|
||||
(let ((el (car element.i))
|
||||
(i (cadr element.i)))
|
||||
(cons (make-element
|
||||
(if (= index i) mark (element-marked? el))
|
||||
(element-value el)
|
||||
(element-text el))
|
||||
result)))
|
||||
'() (zip elements (iota (length elements))))
|
||||
(select-list-view-index select-list)
|
||||
index (select-list-cursor-y select-list)))))
|
||||
|
||||
(define unmark-current-line
|
||||
(mark/unmark-current-line-maker #f))
|
||||
|
||||
(define mark-current-line
|
||||
(mark/unmark-current-line-maker #t))
|
||||
|
||||
;; returns: y cursor-index view-index
|
||||
(define (calculate-view index-move cursor-move
|
||||
elements view-index cursor-index
|
||||
num-lines y)
|
||||
(let ((new-index (index-move cursor-index))
|
||||
(max-index (- (length elements) 1)))
|
||||
(cond
|
||||
((< new-index 0)
|
||||
(values 0 0 view-index))
|
||||
((> new-index max-index)
|
||||
(values y max-index view-index))
|
||||
((and (>= (- new-index view-index) num-lines)
|
||||
(> new-index cursor-index))
|
||||
(values 1 new-index (+ view-index num-lines)))
|
||||
((and (< new-index cursor-index)
|
||||
(>= view-index cursor-index))
|
||||
(values num-lines new-index (- view-index num-lines)))
|
||||
(else
|
||||
(values (cursor-move y) (index-move cursor-index) view-index)))))
|
||||
|
||||
(define (copy-element-list elements)
|
||||
(fold-right
|
||||
(lambda (el result)
|
||||
(cons
|
||||
(make-element (element-marked? el)
|
||||
(element-value el)
|
||||
(element-text el))
|
||||
result))
|
||||
'() elements))
|
||||
|
||||
(define (move-cursor-maker index-move cursor-move)
|
||||
(lambda (select-list result-buffer)
|
||||
(let* ((elements (select-list-elements select-list))
|
||||
(old-index (select-list-cursor-index select-list)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(calculate-view index-move cursor-move
|
||||
elements
|
||||
(select-list-view-index select-list)
|
||||
old-index
|
||||
(result-buffer-num-lines result-buffer)
|
||||
(select-list-cursor-y select-list)))
|
||||
(lambda (y cursor-index view-index)
|
||||
(really-make-select-list
|
||||
(copy-element-list elements)
|
||||
view-index
|
||||
cursor-index
|
||||
y))))))
|
||||
|
||||
(define move-cursor-up
|
||||
(let ((sub-one (lambda (y) (- y 1))))
|
||||
(move-cursor-maker sub-one sub-one)))
|
||||
|
||||
(define move-cursor-down
|
||||
(let ((add-one (lambda (y) (+ y 1))))
|
||||
(move-cursor-maker add-one add-one)))
|
||||
|
||||
(define (take-max lst num)
|
||||
(if (>= num (length lst))
|
||||
lst
|
||||
(take lst num)))
|
||||
|
||||
(define (select-visible-elements select-list result-buffer)
|
||||
(let ((num-lines (result-buffer-num-lines result-buffer)))
|
||||
(take-max (drop (select-list-elements select-list)
|
||||
(select-list-view-index select-list))
|
||||
(+ 1 num-lines)))) ;;; wtf? why this
|
||||
|
||||
(define (paint-selection-list select-list)
|
||||
(lambda (win result-buffer have-focus?)
|
||||
(let lp ((elts
|
||||
(select-visible-elements select-list result-buffer))
|
||||
(y 0)
|
||||
(i (select-list-view-index select-list)))
|
||||
(cond
|
||||
((null? elts)
|
||||
(values))
|
||||
((= i (select-list-cursor-index select-list))
|
||||
(wattron win (A-REVERSE))
|
||||
(mvwaddstr win y 0 (element-text (car elts)))
|
||||
(wattrset win (A-NORMAL))
|
||||
(lp (cdr elts) (+ y 1) (+ i 1)))
|
||||
((element-marked? (car elts))
|
||||
(wattron win (A-BOLD))
|
||||
(mvwaddstr win y 0 (element-text (car elts)))
|
||||
(wattrset win (A-NORMAL))
|
||||
(lp (cdr elts) (+ y 1) (+ i 1)))
|
||||
(else
|
||||
(mvwaddstr win y 0 (element-text (car elts)))
|
||||
(lp (cdr elts) (+ y 1) (+ i 1)))))))
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
#f)
|
||||
|
||||
(define (standard-command-plugin-evaluater command args)
|
||||
(directory-files))
|
||||
(run/strings (,command ,@args)))
|
||||
|
||||
(define standard-command-plugin
|
||||
(make-command-plugin #f
|
||||
|
|
|
|||
Loading…
Reference in New Issue