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

using select-list

scheme/browse-directory-list.scm

@@ -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
+(define-record-type filelist-state :filelist-state
-  (make-browse-dir-list-res-obj pos-y
+  (make-filelist-state files select-list working-dir initial-dir)
-				pos-x
+  filelist-state?
-				file-list
+  (files filelist-state-files)
-				result-text
+  (select-list filelist-state-select-list)
-				working-directory
+  (working-dir filelist-state-working-dir)
-				width
+  (initial-dir filelist-state-initial-dir))
-				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 (layout-dir-list files wdir width)
+(define-record-discloser :filelist-state
-  (let ((marked-files (mark-special-files wdir files)))
+  (lambda (r)
-    (append
+    `(filelist-state ,(filelist-state-working-dir r)
-     (list
+		     ,(filelist-state-files r))))
-      (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 (mark-special-files dir files)
+(define (add-marks-to-special-file fs-object)
-  (map (lambda (file)
+  (let ((name (fs-object-name fs-object))
-	 (let ((complete-name (string-append dir "/" file)))
+	(info (fs-object-info fs-object)))
-	   (cond
+    (cond
-	    ((file-directory? complete-name)
+     ((file-info-directory? info)
-	     (string-append " " file "/"))
+      (string-append " " name "/"))
-	    ((file-executable? complete-name)
+     ((file-info-executable? info)
-	     (string-append "*" file))
+      (string-append "*" name))
-	    ((file-symlink? complete-name)
+     ((file-info-symlink? info)
-	     (string-append "@" file))
+      (string-append "@" name))
-	    (else
+     (else
-	     (string-append " " file)))))
+      (string-append " " name)))))
-       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 (init-with-list-of-files files dir width)
+;; leave one line for the heading
-  (make-browse-dir-list-res-obj
+(define (calculate-number-of-lines result-buffer)
-   2 1
+  (- (result-buffer-num-lines result-buffer)
-   files (layout-dir-list files dir width) dir
+     1))
-   width (cwd) '() '() #f))
 
-(define browse-dir-list-receiver
+(define (layout-fsobject fsobject)
-  (lambda (message)
+  (add-marks-to-special-file fsobject))
-    (debug-message "browse-dir-list-receiver " message)
-    (cond 
 
-     ((init-with-result-message? message)
+(define (make-file-select-list fsobjects num-lines)
-      (let ((fs-objects (init-with-result-message-result message)))
+  (make-select-list
-	(init-with-list-of-files
+   (cons (make-unmarked-element 'parent-dir #f " ..")
-	 (map fs-object-name fs-objects) (cwd)
+	 (map (lambda (fs-object)
-	 (result-buffer-num-cols
+		(make-unmarked-element 
-	  (init-with-result-message-buffer message)))))
+		 fs-object #t (layout-fsobject fs-object)))
+	      fsobjects))
+   num-lines))
 
-     ((next-command-message? message)
+;;; lacks some coolness
-      (init-with-list-of-files (directory-files) (cwd)))
+(define (abbrev-path path length)
+  (if (< (string-length path) length)
+      path
+      (string-copy path 
+		   (- (string-length path) length))))
 
-     ((print-message? message)
+(define header-line-path
-      (let* ((model (message-result-object message))
+  "Paths relative to ")
-	     (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)))
 
-     ((key-pressed-message? message)
+(define (make-header-line state width)
-      (let* ((model (message-result-object message))
+  (let ((dir (filelist-state-working-dir state)))
-	     (key (key-pressed-message-key message))
+    (string-append 
-	     (c-x-pressed (browse-dir-list-res-obj-c-x-pressed model)))
+     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-pressed-message? message)
-	 ((= key key-m)
+    (handle-key-press message))
-	  (let* ((marked-items (browse-dir-list-res-obj-marked-items model))
+   
-		 (res-marked-items (browse-dir-list-res-obj-res-marked-items
+   (else
-				    model))
+    (values))))
-		 (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)))))))
 
 (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?))

scheme/fs-object.scm

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

scheme/nuit-packages.scm

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