Fix a few bugs in fsobjects-viewer

scheme/browse-directory-list.scm

@@ -65,11 +65,6 @@
   (paint-selection-list-at select-list 1 2 win
 			   buffer have-focus?))
 
-(define (make-browser-for-dir instance dir)
-  (let ((new-instance (make-fsobjects-viewer)))
-    (send new-instance 'init-browser-for-dir
-	  dir (send instance 'get-buffer))))
-
 (define (find-common-parent paths)
   (if (null? paths)
       ""
@@ -99,7 +94,7 @@
     (let* ((maybe-parent 
 	    (file-name-directory (send instance 'get-working-dir)))
 	   (parent (if (string=? maybe-parent "") "/" maybe-parent)))
-      (make-browser-for-dir instance parent)))
+      (make-browser-for-dir parent (send instance 'get-buffer))))
    (else
     (let ((fi (fs-object-info selected-entry)))
       (if (and fi (file-info-directory? fi))
@@ -109,8 +104,8 @@
              (display packet)
              (newline)
              instance))
-           (make-browser-for-dir instance 
+           (make-browser-for-dir (fs-object-complete-path selected-entry)
-				 (fs-object-complete-path selected-entry)))
+                                 (send instance 'get-buffer)))
 	  instance)))))
 
 (define (handle-key-press instance key)
@@ -126,58 +121,52 @@
 	    (select-list-handle-key-press select-list key))
       instance))))
 
-(define (make-fsobjects-viewer fs-objects buffer)
+(define (make-browser-for-dir dir buffer)
-  (let* ((fs-objects fs-objects)
+  (with-cwd dir
-         (buffer buffer)
+    (make-fsobjects-viewer (directory-files)
-         (working-dir (find-common-parent
+                           buffer
-                       (map fs-object-path fs-objects)))
+                           (cwd))))
-         (select-list
-          (make-file-select-list fs-objects 
-                                 working-dir
-                                 (result-buffer-num-lines buffer))))
   
-    (lambda (message)
+(define (make-fsobjects-viewer fs-objects buffer . maybe-parent)
-      (cond
+  (let-optionals maybe-parent
+      ((working-dir (find-common-parent
+                     (map fs-object-path fs-objects))))
+    (let ((fs-objects fs-objects)
+          (buffer buffer)
+          (select-list
+           (make-file-select-list fs-objects 
+                                  working-dir
+                                  (- (result-buffer-num-lines buffer) 2))))
 
-       ((eq? message 'init-browser-for-dir)
+          (lambda (message)
-	(lambda (self new-dir new-buffer)
+            (cond
-	  (with-cwd new-dir
+             ((eq? message 'paint)
-	    (let ((new-fs-objects (directory-files)))
+              (lambda (self . args)
-	      (set! buffer new-buffer)
+                (apply paint-browser
-	      (set! fs-objects new-fs-objects)
+                       (append (list select-list working-dir) args))))
-	      (set! working-dir new-dir)
-	      (set! select-list
-		    (make-file-select-list 
-		     fs-objects (cwd) (result-buffer-num-lines new-buffer)))
-	      self))))
 
-       ((eq? message 'paint)
+             ((eq? message 'key-press)
-	(lambda (self . args)
+              (lambda (self key control-x-pressed?)
-	  (apply paint-browser 
+                (handle-key-press self key)))
-		 (append (list select-list working-dir) args))))
 
-       ((eq? message 'key-press)
+             ((eq? message 'get-select-list)
-	(lambda (self key control-x-pressed?)
+              (lambda (self)
-	  (handle-key-press self key)))
+                select-list))
        
-       ((eq? message 'get-select-list)
+             ((eq? message 'set-select-list!)
-	(lambda (self)
+              (lambda (self new-select-list)
-	  select-list))
+                (set! select-list new-select-list)))
 
-       ((eq? message 'set-select-list!)
+             ((eq? message 'get-buffer)
-	(lambda (self new-select-list)
+              (lambda (self)
-	  (set! select-list new-select-list)))
+                buffer))
 
-       ((eq? message 'get-buffer)
+             ((eq? message 'get-working-dir)
-	(lambda (self)
+              (lambda (self)
-	  buffer))
+                working-dir))
        
-       ((eq? message 'get-working-dir)
+             (else
-	(lambda (self)
+              (error "fsobjects-viewer unknown message" message))))))))
-	  working-dir))
-       
-       (else
-	(error "fsobjects-viewer unknown message" message))))))
 
 (define (list-of-fs-objects? thing)
   (and (proper-list? thing)

scheme/nuit-packages.scm

@@ -107,6 +107,7 @@
 	srfi-1
 	(subset srfi-13 (string-copy string-drop string-prefix-length))
 	signals
+        let-opt
 
 	objects
 	layout