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.

scheme/browse-directory-list.scm

@@ -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)
+  (working-dir filelist-state-working-dir))
-  (initial-dir filelist-state-initial-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)
+(define (add-marks-to-special-file file-name fs-object)
-  (let ((name (fs-object-name fs-object))
+  (let ((info (fs-object-info fs-object)))
-	(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)
+(define (layout-fsobject parent-dir-len fsobject)
-  (add-marks-to-special-file 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)
+(define (make-file-select-list fsobjects parent-dir num-lines)
-  (make-select-list
+  (let ((parent-dir-len (string-length parent-dir)))
-   (cons (make-unmarked-element 'parent-dir #f " ..")
+    (make-select-list
-	 (map (lambda (fs-object)
+     (cons (make-unmarked-element 'parent-dir #f " ..")
-		(make-unmarked-element 
+           (map (lambda (fs-object)
-		 fs-object #t (layout-fsobject fs-object)))
+                  (make-unmarked-element 
-	      fsobjects))
+                   fs-object #t (layout-fsobject parent-dir-len fs-object)))
-   num-lines))
+                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)
+       fs-objects (make-file-select-list fs-objects (cwd) num-lines)
-       (cwd) (cwd)))))
+       (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)
+	  (with-errno-handler 
-				num-lines)
+           ((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-working-dir state))))))
-       (filelist-state-initial-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)))

scheme/eval.scm

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

scheme/fs-object.scm

@@ -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)
+  (absolute-file-name
-		(fs-object-name fs-object)))
+   (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")))

scheme/nuit-packages.scm

@@ -87,12 +87,11 @@
 
 ;;; file list view plugin
 
-(define-structure dirlist-view-plugin
+(define-structure dirlist-view-plugin (export)
-    (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
+  (open scheme-with-scsh
-	(subset scsh (file-info))
         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
+(define-structure nuit-eval (interface-of scheme-with-scsh)
-    (interface-of scheme-with-scsh)
   (open 
    (modify scheme-with-scsh
 	   (rename (directory-files scsh-directory-files)))

scheme/std-command.scm

@@ -84,10 +84,17 @@
 (define no-completer (lambda args #f))
 
 (register-plugin!
- (make-command-plugin "ls"
+ (make-command-plugin 
-		      no-completer
+  "ls"
- 		      (lambda (command args)
+  no-completer
- 			(directory-files))))
+  (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"