make the browse-directory-list plugin work again, i.e. rewrite it
using select-list
This commit is contained in:
eknauel
parent
eb5fff8905
commit
93c6d96922
|
|
@ -1,345 +1,141 @@
|
|||
;;This addition provides a directory-tree-browsing-functionality.
|
||||
;;This means:
|
||||
;;When using it you hand over a list of strings, that shall be
|
||||
;;interpreted as paths and a string that represents the path, relative to
|
||||
;;which the path-list is given.
|
||||
;;In the result-window of the NUIT a file-browsing screen is shown
|
||||
;;which you can browse in using arrow-keys and enter. You can also
|
||||
;;select some items and paste them into the upper window.
|
||||
|
||||
;;If there are paths to files handed over that do not exist, they will not be
|
||||
;;displayed in the browser!
|
||||
|
||||
;;If the given path does not exist you will not be able to navigate!
|
||||
|
||||
(define key-m 109)
|
||||
(define key-u 117)
|
||||
(define key-return 10)
|
||||
|
||||
(define-record-type browse-dir-list-res-obj browse-dir-list-res-obj
|
||||
(make-browse-dir-list-res-obj pos-y
|
||||
pos-x
|
||||
file-list
|
||||
result-text
|
||||
working-directory
|
||||
width
|
||||
initial-wd
|
||||
marked-items
|
||||
res-marked-items
|
||||
c-x-pressed)
|
||||
browse-dir-list-res-obj?
|
||||
(pos-y browse-dir-list-res-obj-pos-y)
|
||||
(pos-x browse-dir-list-res-obj-pos-x)
|
||||
(file-list browse-dir-list-res-obj-file-list)
|
||||
(result-text browse-dir-list-res-obj-result-text)
|
||||
(working-directory browse-dir-list-res-obj-working-directory)
|
||||
(width browse-dir-list-res-obj-width)
|
||||
(initial-wd browse-dir-list-res-obj-initial-wd)
|
||||
(marked-items browse-dir-list-res-obj-marked-items)
|
||||
(res-marked-items browse-dir-list-res-obj-res-marked-items)
|
||||
(c-x-pressed browse-dir-list-res-obj-c-x-pressed))
|
||||
(define-record-type filelist-state :filelist-state
|
||||
(make-filelist-state files select-list working-dir initial-dir)
|
||||
filelist-state?
|
||||
(files filelist-state-files)
|
||||
(select-list filelist-state-select-list)
|
||||
(working-dir filelist-state-working-dir)
|
||||
(initial-dir filelist-state-initial-dir))
|
||||
|
||||
(define (layout-dir-list files wdir width)
|
||||
(let ((marked-files (mark-special-files wdir files)))
|
||||
(append
|
||||
(list
|
||||
(if (<= (string-length wdir) (- width 25))
|
||||
(string-append "Paths relative to " wdir " :")
|
||||
(let ((dir-string (substring wdir
|
||||
(- (string-length wdir)
|
||||
(- width 25))
|
||||
(string-length wdir))))
|
||||
(string-append "Paths relative to ..."
|
||||
dir-string))))
|
||||
marked-files)))
|
||||
(define-record-discloser :filelist-state
|
||||
(lambda (r)
|
||||
`(filelist-state ,(filelist-state-working-dir r)
|
||||
,(filelist-state-files r))))
|
||||
|
||||
(define (mark-special-files dir files)
|
||||
(map (lambda (file)
|
||||
(let ((complete-name (string-append dir "/" file)))
|
||||
(cond
|
||||
((file-directory? complete-name)
|
||||
(string-append " " file "/"))
|
||||
((file-executable? complete-name)
|
||||
(string-append "*" file))
|
||||
((file-symlink? complete-name)
|
||||
(string-append "@" file))
|
||||
(else
|
||||
(string-append " " file)))))
|
||||
files))
|
||||
|
||||
;;selection->descend
|
||||
(define selected-browse-dir-list
|
||||
(lambda (model)
|
||||
(let ((ln (browse-dir-list-res-obj-pos-y model))
|
||||
(wd (browse-dir-list-res-obj-working-directory model)))
|
||||
(if (not (file-exists? wd))
|
||||
model
|
||||
(begin (chdir wd)
|
||||
(if (or (>= ln (+ (length
|
||||
(browse-dir-list-res-obj-result-text model)) 1))
|
||||
(<= ln 1))
|
||||
model
|
||||
(if (= ln 2)
|
||||
(if (not (equal? "/" (cwd)))
|
||||
(begin
|
||||
(chdir "..")
|
||||
(let* ((new-result (directory-files))
|
||||
(width (browse-dir-list-res-obj-width model))
|
||||
(new-text (layout-dir-list
|
||||
new-result (cwd) width))
|
||||
(new-model (make-browse-dir-list-res-obj
|
||||
2
|
||||
1
|
||||
new-result
|
||||
new-text
|
||||
(cwd)
|
||||
width
|
||||
(browse-dir-list-res-obj-initial-wd
|
||||
model)
|
||||
(browse-dir-list-res-obj-marked-items
|
||||
model)
|
||||
(browse-dir-list-res-obj-res-marked-items
|
||||
model)
|
||||
(browse-dir-list-res-obj-c-x-pressed
|
||||
model))))
|
||||
new-model))
|
||||
model)
|
||||
(let* ((text (browse-dir-list-res-obj-result-text model))
|
||||
(ent (list-ref text (- ln 1)))
|
||||
(len (string-length ent))
|
||||
(last-char (substring ent (- len 1) len))
|
||||
(rest (substring ent 1 (- len 1))))
|
||||
(if (equal? last-char "/")
|
||||
(begin
|
||||
(chdir wd)
|
||||
(chdir rest)
|
||||
(let* ((new-result (directory-files))
|
||||
(width (browse-dir-list-res-obj-width model))
|
||||
(new-text (layout-dir-list
|
||||
new-result (cwd) width))
|
||||
(new-model (make-browse-dir-list-res-obj
|
||||
2
|
||||
1
|
||||
new-result
|
||||
new-text
|
||||
(cwd)
|
||||
width
|
||||
(browse-dir-list-res-obj-initial-wd
|
||||
model)
|
||||
(browse-dir-list-res-obj-marked-items
|
||||
model)
|
||||
(browse-dir-list-res-obj-res-marked-items
|
||||
model)
|
||||
(browse-dir-list-res-obj-c-x-pressed model))))
|
||||
new-model))
|
||||
model)))))))))
|
||||
|
||||
(define (init-with-list-of-files files dir width)
|
||||
(make-browse-dir-list-res-obj
|
||||
2 1
|
||||
files (layout-dir-list files dir width) dir
|
||||
width (cwd) '() '() #f))
|
||||
|
||||
(define browse-dir-list-receiver
|
||||
(lambda (message)
|
||||
(debug-message "browse-dir-list-receiver " message)
|
||||
(define (add-marks-to-special-file fs-object)
|
||||
(let ((name (fs-object-name fs-object))
|
||||
(info (fs-object-info fs-object)))
|
||||
(cond
|
||||
((file-info-directory? info)
|
||||
(string-append " " name "/"))
|
||||
((file-info-executable? info)
|
||||
(string-append "*" name))
|
||||
((file-info-symlink? info)
|
||||
(string-append "@" name))
|
||||
(else
|
||||
(string-append " " name)))))
|
||||
|
||||
((init-with-result-message? message)
|
||||
(let ((fs-objects (init-with-result-message-result message)))
|
||||
(init-with-list-of-files
|
||||
(map fs-object-name fs-objects) (cwd)
|
||||
(result-buffer-num-cols
|
||||
(init-with-result-message-buffer message)))))
|
||||
;; leave one line for the heading
|
||||
(define (calculate-number-of-lines result-buffer)
|
||||
(- (result-buffer-num-lines result-buffer)
|
||||
1))
|
||||
|
||||
((next-command-message? message)
|
||||
(init-with-list-of-files (directory-files) (cwd)))
|
||||
(define (layout-fsobject fsobject)
|
||||
(add-marks-to-special-file fsobject))
|
||||
|
||||
((print-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
(pos-y (browse-dir-list-res-obj-pos-y model))
|
||||
(pos-x (browse-dir-list-res-obj-pos-x model))
|
||||
(text (browse-dir-list-res-obj-result-text model))
|
||||
(marked-pos (get-marked-positions-3
|
||||
(browse-dir-list-res-obj-file-list model)
|
||||
(browse-dir-list-res-obj-marked-items model))))
|
||||
(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)))
|
||||
(define (make-file-select-list fsobjects num-lines)
|
||||
(make-select-list
|
||||
(cons (make-unmarked-element 'parent-dir #f " ..")
|
||||
(map (lambda (fs-object)
|
||||
(make-unmarked-element
|
||||
fs-object #t (layout-fsobject fs-object)))
|
||||
fsobjects))
|
||||
num-lines))
|
||||
|
||||
((key-pressed-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
(key (key-pressed-message-key message))
|
||||
(c-x-pressed (browse-dir-list-res-obj-c-x-pressed model)))
|
||||
;;; lacks some coolness
|
||||
(define (abbrev-path path length)
|
||||
(if (< (string-length path) length)
|
||||
path
|
||||
(string-copy path
|
||||
(- (string-length path) length))))
|
||||
|
||||
(cond
|
||||
(define header-line-path
|
||||
"Paths relative to ")
|
||||
|
||||
;; user pressed 'm' --- mark current entry
|
||||
((= key key-m)
|
||||
(let* ((marked-items (browse-dir-list-res-obj-marked-items model))
|
||||
(res-marked-items (browse-dir-list-res-obj-res-marked-items
|
||||
model))
|
||||
(actual-pos (browse-dir-list-res-obj-pos-y model))
|
||||
(all-items (browse-dir-list-res-obj-file-list model)))
|
||||
(if (<= actual-pos 2)
|
||||
model
|
||||
(let* ((actual-item (list-ref all-items (- actual-pos 3)))
|
||||
(actual-res-item
|
||||
(if (not (string=? (cwd) "/"))
|
||||
(string-append (cwd) "/" actual-item)
|
||||
(string-append "/" actual-item))))
|
||||
(if (member actual-res-item marked-items)
|
||||
model
|
||||
(let* ((new-res-marked-items (append res-marked-items
|
||||
(list
|
||||
actual-res-item)))
|
||||
(new-marked-items (append marked-items
|
||||
(list actual-item)))
|
||||
(new-model (make-browse-dir-list-res-obj
|
||||
(browse-dir-list-res-obj-pos-y model)
|
||||
(browse-dir-list-res-obj-pos-x model)
|
||||
(browse-dir-list-res-obj-file-list
|
||||
model)
|
||||
(browse-dir-list-res-obj-result-text
|
||||
model)
|
||||
(browse-dir-list-res-obj-working-directory
|
||||
model)
|
||||
(browse-dir-list-res-obj-width model)
|
||||
(browse-dir-list-res-obj-initial-wd
|
||||
model)
|
||||
new-marked-items
|
||||
new-res-marked-items
|
||||
#f)))
|
||||
new-model))))))
|
||||
(define (make-header-line state width)
|
||||
(let ((dir (filelist-state-working-dir state)))
|
||||
(string-append
|
||||
header-line-path
|
||||
(if dir
|
||||
(abbrev-path
|
||||
dir (- width (string-length header-line-path)))
|
||||
"<unknown>"))))
|
||||
|
||||
;; user pressed 'u' --- unmark current entry
|
||||
((= key key-u)
|
||||
(let* ((marked-items (browse-dir-list-res-obj-marked-items model))
|
||||
(res-marked-items (browse-dir-list-res-obj-res-marked-items
|
||||
model))
|
||||
(actual-pos (browse-dir-list-res-obj-pos-y model))
|
||||
(all-items (browse-dir-list-res-obj-file-list model)))
|
||||
(if (<= actual-pos 2)
|
||||
model
|
||||
(let* ((actual-item (list-ref all-items (- actual-pos 3)))
|
||||
(actual-res-item (string-append (cwd) "/" actual-item))
|
||||
(rest (member actual-item marked-items))
|
||||
(res-rest (member actual-res-item res-marked-items)))
|
||||
(if (not res-rest)
|
||||
model
|
||||
(let* ((after-item (length rest))
|
||||
(all-items (length marked-items))
|
||||
(before-item (sublist marked-items
|
||||
0
|
||||
(- all-items
|
||||
after-item )))
|
||||
(new-marked-items (append before-item
|
||||
(list-tail rest 1)))
|
||||
(after-res-item (length res-rest))
|
||||
(all-res-items (length res-marked-items))
|
||||
(before-res-item (sublist res-marked-items
|
||||
0
|
||||
(- all-res-items
|
||||
after-res-item)))
|
||||
(new-res-marked-items (append before-res-item
|
||||
(list-tail res-rest
|
||||
1)))
|
||||
(new-model (make-browse-dir-list-res-obj
|
||||
(browse-dir-list-res-obj-pos-y model)
|
||||
(browse-dir-list-res-obj-pos-x model)
|
||||
(browse-dir-list-res-obj-file-list
|
||||
model)
|
||||
(browse-dir-list-res-obj-result-text
|
||||
model)
|
||||
(browse-dir-list-res-obj-working-directory
|
||||
model)
|
||||
(browse-dir-list-res-obj-width model)
|
||||
(browse-dir-list-res-obj-initial-wd
|
||||
model)
|
||||
new-marked-items
|
||||
new-res-marked-items
|
||||
#f)))
|
||||
new-model))))))
|
||||
(define (paint-browser state)
|
||||
(lambda (win result-buffer have-focus?)
|
||||
(wattron win (A-BOLD))
|
||||
(mvwaddstr win 0 0
|
||||
(make-header-line
|
||||
state (result-buffer-num-cols result-buffer)))
|
||||
(wattrset win (A-NORMAL))
|
||||
((paint-selection-list-at
|
||||
(filelist-state-select-list state) 1 2)
|
||||
win result-buffer have-focus?)))
|
||||
|
||||
((= key key-up)
|
||||
(let ((posy (browse-dir-list-res-obj-pos-y model)))
|
||||
(if (<= posy 2)
|
||||
model
|
||||
(let* ((new-posy (- posy 1))
|
||||
(new-model (make-browse-dir-list-res-obj
|
||||
new-posy
|
||||
(browse-dir-list-res-obj-pos-x model)
|
||||
(browse-dir-list-res-obj-file-list model)
|
||||
(browse-dir-list-res-obj-result-text model)
|
||||
(browse-dir-list-res-obj-working-directory
|
||||
model)
|
||||
(browse-dir-list-res-obj-width model)
|
||||
(browse-dir-list-res-obj-initial-wd model)
|
||||
(browse-dir-list-res-obj-marked-items model)
|
||||
(browse-dir-list-res-obj-res-marked-items
|
||||
model)
|
||||
#f)))
|
||||
new-model))))
|
||||
(define (make-browser-for-dir dir num-lines)
|
||||
(with-cwd dir
|
||||
(let ((fs-objects (directory-files)))
|
||||
(make-filelist-state
|
||||
fs-objects (make-file-select-list fs-objects num-lines)
|
||||
(cwd) (cwd)))))
|
||||
|
||||
((= key key-down)
|
||||
(let ((posy (browse-dir-list-res-obj-pos-y model))
|
||||
(num-lines (length
|
||||
(browse-dir-list-res-obj-result-text model))))
|
||||
(if (>= posy num-lines)
|
||||
model
|
||||
(let* ((new-posy (+ posy 1))
|
||||
(new-model (make-browse-dir-list-res-obj
|
||||
new-posy
|
||||
(browse-dir-list-res-obj-pos-x model)
|
||||
(browse-dir-list-res-obj-file-list model)
|
||||
(browse-dir-list-res-obj-result-text model)
|
||||
(browse-dir-list-res-obj-working-directory
|
||||
model)
|
||||
(browse-dir-list-res-obj-width model)
|
||||
(browse-dir-list-res-obj-initial-wd model)
|
||||
(browse-dir-list-res-obj-marked-items model)
|
||||
(browse-dir-list-res-obj-res-marked-items
|
||||
model)
|
||||
#f)))
|
||||
new-model))))
|
||||
(define (handle-return-key state selected-entry num-lines)
|
||||
(cond
|
||||
((eq? selected-entry 'parent-dir)
|
||||
(let* ((maybe-parent
|
||||
(file-name-directory (filelist-state-working-dir state)))
|
||||
(parent (if (string=? maybe-parent "") "/" maybe-parent)))
|
||||
(make-browser-for-dir parent num-lines)))
|
||||
(else
|
||||
(let ((fi (fs-object-info selected-entry)))
|
||||
(if (file-info-directory? fi)
|
||||
(make-browser-for-dir (fs-object-complete-path selected-entry)
|
||||
num-lines)
|
||||
state)))))
|
||||
|
||||
((= key 10)
|
||||
(selected-browse-dir-list model))
|
||||
(define (handle-key-press message)
|
||||
(let* ((state (message-result-object message))
|
||||
(select-list (filelist-state-select-list state))
|
||||
(key (key-pressed-message-key message)))
|
||||
(cond
|
||||
((= key key-return)
|
||||
(handle-return-key
|
||||
state (select-list-selected-entry select-list)
|
||||
(calculate-number-of-lines
|
||||
(key-pressed-message-result-buffer message))))
|
||||
(else
|
||||
(make-filelist-state
|
||||
(filelist-state-files state)
|
||||
(select-list-handle-key-press
|
||||
(filelist-state-select-list state) message)
|
||||
(filelist-state-working-dir state)
|
||||
(filelist-state-initial-dir state))))))
|
||||
|
||||
;; user pressed C-x
|
||||
((= key 24)
|
||||
(make-browse-dir-list-res-obj
|
||||
(browse-dir-list-res-obj-pos-y model)
|
||||
(browse-dir-list-res-obj-pos-x model)
|
||||
(browse-dir-list-res-obj-file-list model)
|
||||
(browse-dir-list-res-obj-result-text model)
|
||||
(browse-dir-list-res-obj-working-directory
|
||||
model)
|
||||
(browse-dir-list-res-obj-width model)
|
||||
(browse-dir-list-res-obj-initial-wd model)
|
||||
(browse-dir-list-res-obj-marked-items model)
|
||||
(browse-dir-list-res-obj-res-marked-items
|
||||
model)
|
||||
(not c-x-pressed)))
|
||||
(define (filelist-browser message)
|
||||
(cond
|
||||
|
||||
(else model))))
|
||||
((init-with-result-message? message)
|
||||
(let ((fsobjects (init-with-result-message-result message))
|
||||
(num-lines (calculate-number-of-lines
|
||||
(init-with-result-message-buffer message))))
|
||||
(make-browser-for-dir (cwd) num-lines)))
|
||||
|
||||
((print-message? message)
|
||||
(paint-browser (message-result-object message)))
|
||||
|
||||
((restore-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
(initial-wd (browse-dir-list-res-obj-initial-wd model)))
|
||||
(chdir initial-wd)))
|
||||
((key-pressed-message? message)
|
||||
(handle-key-press message))
|
||||
|
||||
((selection-message? message)
|
||||
(let* ((model (message-result-object message))
|
||||
(marked-items (browse-dir-list-res-obj-res-marked-items model)))
|
||||
(string-append "'" (exp->string marked-items)))))))
|
||||
(else
|
||||
(values))))
|
||||
|
||||
(define (list-of-fs-objects? thing)
|
||||
(and (proper-list? thing)
|
||||
(every fs-object? thing)))
|
||||
|
||||
(register-plugin!
|
||||
(make-view-plugin browse-dir-list-receiver
|
||||
(make-view-plugin filelist-browser
|
||||
list-of-fs-objects?))
|
||||
|
|
|
|||
|
|
@ -1,9 +1,26 @@
|
|||
(define-record-type fs-object :fs-object
|
||||
(make-fs-object name path)
|
||||
(really-make-fs-object name path info)
|
||||
fs-object?
|
||||
(name fs-object-name)
|
||||
(path fs-object-path))
|
||||
(path fs-object-path)
|
||||
(info fs-object-info))
|
||||
|
||||
(define (make-fs-object name path)
|
||||
(really-make-fs-object
|
||||
name path
|
||||
(file-info (combine-path path name))))
|
||||
|
||||
(define-record-discloser :fs-object
|
||||
(lambda (r)
|
||||
`(fs-object ,(fs-object-name r))))
|
||||
|
||||
(define (combine-path parent name)
|
||||
(if (string=? parent "")
|
||||
name
|
||||
(string-append parent
|
||||
"/"
|
||||
name)))
|
||||
|
||||
(define (fs-object-complete-path fs-object)
|
||||
(combine-path (fs-object-path fs-object)
|
||||
(fs-object-name fs-object)))
|
||||
|
|
|
|||
|
|
@ -79,11 +79,15 @@
|
|||
|
||||
(define-structure dirlist-view-plugin
|
||||
(export)
|
||||
(open scheme-with-scsh
|
||||
(open (modify nuit-eval (hide string-copy))
|
||||
define-record-types
|
||||
srfi-1
|
||||
(subset srfi-13 (string-copy))
|
||||
signals
|
||||
|
||||
layout
|
||||
fs-object
|
||||
srfi-1
|
||||
select-list
|
||||
plugin
|
||||
ncurses
|
||||
tty-debug)
|
||||
|
|
@ -103,10 +107,13 @@
|
|||
(export make-fs-object
|
||||
fs-object?
|
||||
fs-object-name
|
||||
fs-object-path))
|
||||
fs-object-path
|
||||
fs-object-info
|
||||
fs-object-complete-path))
|
||||
|
||||
(define-structure fs-object fs-object-interface
|
||||
(open scheme
|
||||
(subset scsh (file-info))
|
||||
define-record-types)
|
||||
(files fs-object))
|
||||
|
||||
|
|
@ -115,6 +122,11 @@
|
|||
(define-interface select-list-interface
|
||||
(export make-select-list
|
||||
select-list?
|
||||
|
||||
make-unmarked-element
|
||||
make-marked-element
|
||||
element?
|
||||
|
||||
select-list-handle-key-press
|
||||
unmark-current-line
|
||||
mark-current-line
|
||||
|
|
@ -129,7 +141,7 @@
|
|||
(open scheme
|
||||
srfi-1
|
||||
define-record-types
|
||||
let-opt
|
||||
signals
|
||||
|
||||
tty-debug
|
||||
plugin
|
||||
|
|
|
|||
Loading…
Reference in New Issue