Sorting for file-system viewer

part of darcs patch Mon Sep 19 21:06:27 EEST 2005  Martin Gasbichler <gasbichl@informatik.uni-tuebingen.de>

scheme/browse-directory-list.scm

@@ -1,3 +1,6 @@
+(define-option 'ls 'sort-up-key (char->ascii #\s))
+(define-option 'ls 'sort-down-key (char->ascii #\S))
+
 (define key-m 109)
 (define key-u 117)
 (define key-return 10)
@@ -21,19 +24,25 @@
 
 (define (format-permissions mode)
   (apply string-append
-	 (map (lambda (mask.symbol)
+	 (cons
-		(if (have-permission? mode (car mask.symbol))
+          (cond
-		    (cdr mask.symbol)
+           ((have-permission? mode #o1000) "t") ; sticky
-		    "-"))
+           ((have-permission? mode #o2000) "s") ; setgit 
-	      '((#o0400 . "r")   ;; owner read
+           ((have-permission? mode #o4000) "s") ; setuid
-		(#o0200 . "w")   ;; owner write
+           (else "-"))
-		(#o0100 . "x")   ;; owner exec
+          (map (lambda (mask.symbol)
-		(#o0040 . "r")   ;; group read
+                 (if (have-permission? mode (car mask.symbol))
-		(#o0020 . "w")   ;; group write
+                     (cdr mask.symbol)
-		(#o0010 . "x")   ;; group exec
+                     "-"))
-		(#o0004 . "r")   ;; others read
+               '((#o0400 . "r");; owner read
-		(#o0002 . "w")   ;; others write
+                 (#o0200 . "w");; owner write
-		(#o0001 . "x")))))   ;; others exec
+                 (#o0100 . "x");; owner exec
+                 (#o0040 . "r");; group read
+                 (#o0020 . "w");; group write
+                 (#o0010 . "x");; group exec
+                 (#o0004 . "r");; others read
+                 (#o0002 . "w");; others write
+                 (#o0001 . "x"))))));; others exec
 
 (define (digits-left-of-comma-as-string float)
   (string-drop-right 
@@ -69,6 +78,18 @@
   (- (result-buffer-num-lines result-buffer)
      1))
 
+(define (make-file-select-line)
+  (make-select-line
+   (list
+    (make-unmarked-text-element 'file-name #f 
+                                (left-align-string 31 "File name"))
+    (make-unmarked-text-element 'size #f 
+                                (right-align-string 8 "Size "))
+    (make-unmarked-text-element 'user/group #f
+                                (left-align-string 18 "User:Group "))
+    (make-unmarked-text-element 'mode #f (left-align-string 10 "Mode ")))))
+
+
 (define (layout-fsobject parent-dir-len fsobject num-cols)
   (let ((file-name (combine-path (string-drop
                                   (fs-object-path fsobject)
@@ -80,8 +101,7 @@
       (fill-up-string 
        30 (add-marks-to-special-file file-name fsobject))
       " "
-      (fill-up-string
+      (right-align-string 7 (format-size (file-info:size fi)))
-       7 (format-size (file-info:size fi)))
       " "
       (format-user/group fi)
       " "
@@ -117,12 +137,13 @@
 	wdir (- width (string-length header-line-path)))
        "<unknown>")))
 
-(define (paint-browser select-list wdir win buffer have-focus?)
+(define (paint-browser wdir select-line select-list win buffer have-focus?)
   (wattron win (A-BOLD))
   (mvwaddstr win 0 0
 	     (make-header-line 
 	      wdir (result-buffer-num-cols buffer)))
   (wattrset win (A-NORMAL))
+  (paint-select-line-at select-line 1 1 win buffer)
   (paint-selection-list-at select-list 1 2 win
 			   buffer have-focus?))
 
@@ -162,11 +183,12 @@
     (let ((fs-objects fs-objects)
           (buffer buffer)
           (select-list
-           (make-file-select-list 
+           (make-file-select-list
 	    fs-objects working-dir
 	    ;; we need one line for the header
 	    (- (result-buffer-num-lines buffer) 1)
-	    (result-buffer-num-cols buffer))))
+	    (result-buffer-num-cols buffer)))
+          (select-line (make-file-select-line)))
 
       (define (handle-return-key self selected-entry num-lines)
 	(cond
@@ -187,16 +209,63 @@
 				       buffer))
 		self)))))
 
+      (define (set-fs-objects! new-fs-objects)
+        (set! fs-objects new-fs-objects)
+        (set! select-list
+              (make-file-select-list
+               fs-objects working-dir
+               ;; we need one line for the header
+               (- (result-buffer-num-lines buffer) 1)
+               (result-buffer-num-cols buffer))))
+
       (define (handle-key-press self key)
 	(cond
 	 ((= key key-return)
 	  (handle-return-key
 	   self (select-list-selected-entry select-list)
 	   (calculate-number-of-lines buffer)))
-	 (else
+         ((or (= key (config 'ls 'sort-up-key))
+              (= key (config 'ls 'sort-down-key)))
+          (let ((column (select-line-selected-entry select-line)))
+            (receive (compare-up compare-down select)
+                (case column
+                  ((file-name) 
+                   ;; TODO: use path stripped by parent
+                   (values string<? string>? fs-object-complete-path))
+                  ((size) 
+                   (values < 
+                           > 
+                           (lambda (fso)
+                             (file-info:size (fs-object-info fso)))))
+                  ((user/group) 
+                   (values string<? 
+                           string>? 
+                           (lambda (fso)
+                             (format-user/group (fs-object-info fso)))))
+                  ((mode) 
+                   (values < 
+                           > 
+                           (lambda (fso)
+                             (file-info:mode (fs-object-info fso)))))
+                  (else
+                   (error "unknown column" column)))
+              (let ((compare (if (= key (config 'ls 'sort-up-key))
+                                 compare-up
+                                 compare-down)))
+                (set-fs-objects!
+                 (list-sort
+                  (lambda (p1 p2)
+                    (compare (select p1) (select p2)))
+                  fs-objects))
+                self))))
+         ((select-list-key? key)
 	  (set! select-list
 		(select-list-handle-key-press select-list key))
-	  self)))
+	  self)
+         ((select-line-key? key)
+          (select-line-handle-key-press! select-line key)
+          self)
+         (else self)))
 
       (define (prepare-selection-for-scheme-mode file-names)
 	(string-append "'" (write-to-string file-names)))
@@ -233,9 +302,9 @@
       (lambda (message)
 	(cond
 	 ((eq? message 'paint)
-	  (lambda (self . args)
+	  (lambda (self win buffer have-focus?)
-	    (apply paint-browser
+	    (paint-browser working-dir select-line select-list 
-		   (append (list select-list working-dir) args))))
+                           win buffer have-focus?)))
 
 	 ((eq? message 'key-press)
 	  (lambda (self key control-x-pressed?)

scheme/nuit-packages.scm

@@ -217,13 +217,16 @@
                  string-drop-right string-prefix-length))
 	signals
         let-opt
+        sorting
 
+        configuration
 	focus-table
 	objects
 	layout
         utils
 	fs-object
 	select-list
+        select-line
         select-element
 	plugin
 	ncurses