scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
commander-s/scheme/browse-directory-list.scm

363 lines
12 KiB
Scheme
Raw Normal View History

more modularityand modified shortcuts
2004-10-14 07:58:20 -04:00
;;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!
use `m' and `u' for selecting/unselecting items
2005-05-17 05:56:11 -04:00
(define key-m 109)
(define key-u 117)
more modularityand modified shortcuts
2004-10-14 07:58:20 -04:00
(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))
;;Layout of the directory-tree-browser
(define layout-result-browse-dir-list
(lambda (result-str result width directory)
Remove set! on local variables. They are just ugly.
2005-05-17 16:08:39 -04:00
(let ((printed-file-list (print-file-list-1 result directory)))
(append
(list
(if (<= (string-length directory) (- width 25))
(string-append "Paths relative to " directory " :")
(let ((dir-string (substring directory
(- (string-length directory)
(- width 25))
(string-length directory))))
(string-append "Paths relative to ..."
dir-string))))
printed-file-list))))
more modularityand modified shortcuts
2004-10-14 07:58:20 -04:00
;;One File per-line
;;In case the object is a directory "/" is added
(define print-file-list-1
(lambda (file-list dir)
(let loop ((old file-list)
(new '()))
(if (equal? '() old)
new
(let* ((hd (list-ref old 0))
(hd-path (string-append dir "/" hd))
(tl (cdr old)))
(if (file-exists? hd-path)
(if (file-directory? hd-path)
(let ((new-str (string-append " " hd "/")))
(loop tl (append new (list new-str))))
(loop tl (append new (list (string-append " " hd)))))
(loop tl new)))))))
;;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 (evaluate "(directory-files)"))
(new-result-string (exp->string new-result))
(width (browse-dir-list-res-obj-width model))
(new-text (layout-result-browse-dir-list
new-result-string
new-result width (cwd)))
(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 (evaluate "(directory-files)"))
(new-result-string (exp->string new-result))
(width (browse-dir-list-res-obj-width model))
(new-text (layout-result-browse-dir-list
new-result-string new-result width
(cwd)))
(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 browse-dir-list-receiver
(lambda (message)
(cond
((next-command-message? message)
(let* ((command (next-command-string message))
(parameters (next-command-message-parameters message))
(width (next-command-message-width message)))
(if (< (length parameters) 2)
Remove set! on local variables. They are just ugly.
2005-05-17 16:08:39 -04:00
(let* ((result (list "forgot parameters?"))
(text
(layout-result-standard "forgot parameters?"
result width))
(browse-obj
more modularityand modified shortcuts
2004-10-14 07:58:20 -04:00
(make-browse-dir-list-res-obj 1 1 result text (cwd)
width (cwd) '() '() #f)))
Remove set! on local variables. They are just ugly.
2005-05-17 16:08:39 -04:00
browse-obj)
more modularityand modified shortcuts
2004-10-14 07:58:20 -04:00
(let* ((file-list
(evaluate (list-ref parameters 0)))
(dir (evaluate (list-ref parameters 1)))
(result-string (exp->string file-list))
(width (next-command-message-width message))
(text
(layout-result-browse-dir-list result-string
file-list width dir))
(browse-obj
(make-browse-dir-list-res-obj 2 1 file-list text dir width
(cwd) '() '() #f)))
browse-obj))))
((print-message? message)
(let* ((model (print-message-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))))
(make-print-object pos-y pos-x text (list pos-y) marked-pos)))
((key-pressed-message? message)
(let* ((model (key-pressed-message-result-model message))
(key (key-pressed-message-key message))
(c-x-pressed (browse-dir-list-res-obj-c-x-pressed model)))
use `m' and `u' for selecting/unselecting items
2005-05-17 05:56:11 -04:00
(cond
;; 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
Remove set! on local variables. They are just ugly.
2005-05-17 16:08:39 -04:00
(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))))
use `m' and `u' for selecting/unselecting items
2005-05-17 05:56:11 -04:00
(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)))
Remove set! on local variables. They are just ugly.
2005-05-17 16:08:39 -04:00
new-model))))))
more modularityand modified shortcuts
2004-10-14 07:58:20 -04:00
use `m' and `u' for selecting/unselecting items
2005-05-17 05:56:11 -04:00
;; 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)))
more modularityand modified shortcuts
2004-10-14 07:58:20 -04:00
new-model))))))
use `m' and `u' for selecting/unselecting items
2005-05-17 05:56:11 -04:00
more modularityand modified shortcuts
2004-10-14 07:58:20 -04:00
((= 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))))
use `m' and `u' for selecting/unselecting items
2005-05-17 05:56:11 -04:00
more modularityand modified shortcuts
2004-10-14 07:58:20 -04:00
((= key 10)
(selected-browse-dir-list model))
use `m' and `u' for selecting/unselecting items
2005-05-17 05:56:11 -04:00
;; 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))))
more modularityand modified shortcuts
2004-10-14 07:58:20 -04:00
((restore-message? message)
(let* ((model (restore-message-object message))
(initial-wd (browse-dir-list-res-obj-initial-wd model)))
(chdir initial-wd)))
((selection-message? message)
(let* ((model (selection-message-object message))
(marked-items (browse-dir-list-res-obj-res-marked-items model)))
(string-append "'" (exp->string marked-items)))))))
(define browse-dir-list-rec (make-receiver "browse-dir-list"
browse-dir-list-receiver))
(set! receivers (cons browse-dir-list-rec receivers))