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

make the browse-directory-list plugin work again, i.e. rewrite it 

using select-list
This commit is contained in:
eknauel 2005-05-26 11:35:17 +00:00
parent eb5fff8905
commit 93c6d96922
3 changed files with 156 additions and 331 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

446
scheme/browse-directory-list.scm
View File

@ -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 (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)))))
(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))
;; leave one line for the heading
(define (calculate-number-of-lines result-buffer)
(- (result-buffer-num-lines result-buffer)
1))
(define browse-dir-list-receiver
(lambda (message)
(debug-message "browse-dir-list-receiver " message)
(cond
(define (layout-fsobject fsobject)
(add-marks-to-special-file fsobject))
((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)))))
(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))
((next-command-message? message)
(init-with-list-of-files (directory-files) (cwd)))
;;; lacks some coolness
(define (abbrev-path path length)
(if (< (string-length path) length)
path
(string-copy path
(- (string-length path) length))))
((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 header-line-path
"Paths relative to ")
((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)))
(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>"))))
(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?)))
(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)))))
(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)))))
(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))))))
(define (filelist-browser message)
(cond
((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)))
(cond
((print-message? message)
(paint-browser (message-result-object message)))
;; 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))))))
;; 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))))))
((= 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))))
((= 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))))
((= key 10)
(selected-browse-dir-list model))
;; 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)))
(else model))))
((restore-message? message)
(let* ((model (message-result-object message))
(initial-wd (browse-dir-list-res-obj-initial-wd model)))
(chdir initial-wd)))
((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)))))))
((key-pressed-message? message)
(handle-key-press message))
(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?))

21
scheme/fs-object.scm
View File

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

20
scheme/nuit-packages.scm
View File

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