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

Rework display of list-of-fs-objects? 

Try to figure out common parent of objects and display files relative
to this parent.
Assume path in fs-object is always absolute.
This commit is contained in:
mainzelm 2005-05-27 21:32:21 +00:00
parent 03f482a04a
commit 73e5192db0
5 changed files with 106 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3,49 +3,52 @@
(define key-return 10)
(define-record-type filelist-state :filelist-state
(make-filelist-state files select-list working-dir initial-dir)
(make-filelist-state files select-list working-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))
(working-dir filelist-state-working-dir))
(define-record-discloser :filelist-state
(lambda (r)
`(filelist-state ,(filelist-state-working-dir r)
,(filelist-state-files r))))
(define (add-marks-to-special-file fs-object)
(let ((name (fs-object-name fs-object))
(info (fs-object-info fs-object)))
(define (add-marks-to-special-file file-name fs-object)
(let ((info (fs-object-info fs-object)))
(cond
((not info)
(string-append " " name ": error during file-info!"))
(string-append " " file-name ": error during file-info!"))
((file-info-directory? info)
(string-append " " name "/"))
(string-append " " file-name "/"))
((file-info-executable? info)
(string-append "*" name))
(string-append "*" file-name))
((file-info-symlink? info)
(string-append "@" name))
(string-append "@" file-name))
(else
(string-append " " name)))))
(string-append " " file-name)))))
;; leave one line for the heading
(define (calculate-number-of-lines result-buffer)
(- (result-buffer-num-lines result-buffer)
1))
(define (layout-fsobject fsobject)
(add-marks-to-special-file fsobject))
(define (layout-fsobject parent-dir-len fsobject)
(let ((file-name (combine-path (string-drop
(fs-object-path fsobject)
parent-dir-len)
(fs-object-name fsobject))))
(add-marks-to-special-file file-name fsobject)))
(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))
(define (make-file-select-list fsobjects parent-dir num-lines)
(let ((parent-dir-len (string-length parent-dir)))
(make-select-list
(cons (make-unmarked-element 'parent-dir #f " ..")
(map (lambda (fs-object)
(make-unmarked-element
fs-object #t (layout-fsobject parent-dir-len fs-object)))
fsobjects))
num-lines)))
;;; lacks some coolness
(define (abbrev-path path length)
@ -81,8 +84,38 @@
(with-cwd dir
(let ((fs-objects (directory-files)))
(make-filelist-state
fs-objects (make-file-select-list fs-objects num-lines)
(cwd) (cwd)))))
fs-objects (make-file-select-list fs-objects (cwd) num-lines)
(cwd)))))
(define (make-browser-for-fs-objects fs-objects num-lines)
(let ((parent-dir (find-common-parent (map fs-object-path fs-objects))))
(make-filelist-state
fs-objects
(make-file-select-list fs-objects parent-dir num-lines)
parent-dir)))
(define (find-common-parent paths)
(if (null? paths)
""
(let lp ((paths (cdr paths))
(common (car paths))
(common-len (string-length (car paths))))
(if (null? paths)
common
(let ((prefix-len (string-prefix-length common (car paths))))
(cond
((= 0 prefix-len) (error "no prefix??" common (car paths)))
((= 1 prefix-len) "/") ; search ends here
((= prefix-len common-len) ; short cut
(lp (cdr paths)
common
common-len))
(else
(lp (cdr paths)
(substring common
0
prefix-len)
prefix-len))))))))
(define (handle-return-key state selected-entry num-lines)
(cond
@ -94,8 +127,14 @@
(else
(let ((fi (fs-object-info selected-entry)))
(if (and fi (file-info-directory? fi))
(make-browser-for-dir (fs-object-complete-path selected-entry)
num-lines)
(with-errno-handler
((errno packet)
(else
(display packet)
(newline)
state))
(make-browser-for-dir (fs-object-complete-path selected-entry)
num-lines))
state)))))
(define (handle-key-press message)
@ -113,8 +152,7 @@
(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))))))
(filelist-state-working-dir state))))))
(define (filelist-browser message)
(cond
@ -123,7 +161,7 @@
(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)))
(make-browser-for-fs-objects fsobjects num-lines)))
((print-message? message)
(paint-browser (message-result-object message)))

7
scheme/eval.scm
View File

@ -14,6 +14,7 @@
(let-optionals optional-args
((dir (cwd))
(dotfiles? #f))
(map (lambda (file)
(make-fs-object file dir))
(scsh-directory-files dir dotfiles?))))
(let ((abs-dir (absolute-file-name dir)))
(map (lambda (file)
(make-fs-object file abs-dir))
(scsh-directory-files abs-dir dotfiles?)))))

18
scheme/fs-object.scm
View File

@ -9,8 +9,13 @@
(force (really-fs-object-info fso)))
(define (make-fs-object name path)
;; TODO check path for being absolute, name for being relative
;; and slashless
(if (not (file-name-absolute? path))
(error "path argument of make-fs-object not absolute" path))
(really-make-fs-object
name path
;; TODO: this delay is rather useless, we need the info anyway
(delay
(with-fatal-error-handler
(lambda (condition more)
@ -20,7 +25,7 @@
(define-record-discloser :fs-object
(lambda (r)
`(fs-object ,(fs-object-name r))))
`(fs-object ,(fs-object-path r) ,(fs-object-name r))))
(define (combine-path parent name)
(if (string=? parent "")
@ -30,5 +35,12 @@
name)))
(define (fs-object-complete-path fs-object)
(combine-path (fs-object-path fs-object)
(fs-object-name fs-object)))
(absolute-file-name
(fs-object-name fs-object)
(fs-object-path fs-object)))
(define (file-name->fs-object file-name)
(if (file-name-absolute? file-name)
(make-fs-object (file-name-nondirectory file-name)
(file-name-directory file-name))
(error "WRITE-ME file-name->fs-object")))

18
scheme/nuit-packages.scm
View File

@ -87,12 +87,11 @@
;;; file list view plugin
(define-structure dirlist-view-plugin
(export)
(define-structure dirlist-view-plugin (export)
(open (modify nuit-eval (hide string-copy))
define-record-types
srfi-1
(subset srfi-13 (string-copy))
(subset srfi-13 (string-copy string-drop string-prefix-length))
signals
layout
@ -106,12 +105,13 @@
;;; standard command plugin
(define-structure standard-command-plugin
(export standard-command-plugin show-shell-screen)
(export standard-command-plugin show-shell-screen)
(open let-opt
signals
srfi-1
srfi-13
fs-object
pps
nuit-eval
ncurses
@ -127,11 +127,12 @@
fs-object-name
fs-object-path
fs-object-info
fs-object-complete-path))
fs-object-complete-path
combine-path
file-name->fs-object))
(define-structure fs-object fs-object-interface
(open scheme
(subset scsh (file-info))
(open scheme-with-scsh
formats
handle-fatal-error
define-record-types)
@ -195,8 +196,7 @@
;;; nuit evaluates the expressions entered into command buffer in this
;;; package
(define-structure nuit-eval
(interface-of scheme-with-scsh)
(define-structure nuit-eval (interface-of scheme-with-scsh)
(open
(modify scheme-with-scsh
(rename (directory-files scsh-directory-files)))

15
scheme/std-command.scm
View File

@ -84,10 +84,17 @@
(define no-completer (lambda args #f))
(register-plugin!
(make-command-plugin "ls"
no-completer
(lambda (command args)
(directory-files))))
(make-command-plugin
"ls"
no-completer
(lambda (command args)
(if (null? args)
(directory-files (cwd))
(let ((arg (file-name->fs-object
(expand-file-name (car args) (cwd)))))
(if (file-info-directory? (fs-object-info arg))
(directory-files (fs-object-complete-path arg))
arg))))))
(register-plugin!
(make-command-plugin "ps"