commander-s/scheme/browse-directory-list.scm

(define key-m 109)
(define key-u 117)
(define key-return 10)

(define (add-marks-to-special-file file-name fs-object)
  (let ((info (fs-object-info fs-object)))
    (cond
     ((not info)
      (string-append " " file-name ": error during file-info!"))
     ((file-info-directory? info)
      (string-append " " file-name "/"))
     ((file-info-executable? info)
      (string-append "*" file-name))
     ((file-info-symlink? info)
      (string-append "@" file-name))
     (else
      (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 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 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)
  (if (< (string-length path) length)
      path
      (string-copy path 
		   (- (string-length path) length))))

(define header-line-path
  "Paths relative to ")

(define (make-header-line wdir width)
  (string-append 
   header-line-path
   (if wdir
       (abbrev-path 
	wdir (- width (string-length header-line-path)))
       "<unknown>")))

(define (paint-browser select-list wdir 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-selection-list-at select-list 1 2 win
			   buffer have-focus?))

(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 instance selected-entry num-lines)
  (cond
   ((eq? selected-entry 'parent-dir)
    (let* ((maybe-parent 
	    (file-name-directory (send instance 'get-working-dir)))
	   (parent (if (string=? maybe-parent "") "/" maybe-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))
	  (with-errno-handler 
           ((errno packet) 
            (else
             (display packet)
             (newline)
             instance))
           (make-browser-for-dir (fs-object-complete-path selected-entry)
                                 (send instance 'get-buffer)))
	  instance)))))

(define (handle-key-press instance key)
  (let ((select-list (send instance 'get-select-list))
	(buffer (send instance 'get-buffer)))
    (cond
     ((= key key-return)
      (handle-return-key
       instance (select-list-selected-entry select-list)
       (calculate-number-of-lines buffer)))
     (else
      (send instance 'set-select-list!
	    (select-list-handle-key-press select-list key))
      instance))))

(define (make-browser-for-dir dir buffer)
  (with-cwd dir
    (make-fsobjects-viewer (directory-files)
                           buffer
                           (cwd))))
  
(define (make-fsobjects-viewer fs-objects buffer . maybe-parent)
  (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))))

          (lambda (message)
            (cond
             ((eq? message 'paint)
              (lambda (self . args)
                (apply paint-browser
                       (append (list select-list working-dir) args))))

             ((eq? message 'key-press)
              (lambda (self key control-x-pressed?)
                (handle-key-press self key)))

             ((eq? message 'get-select-list)
              (lambda (self)
                select-list))
       
             ((eq? message 'set-select-list!)
              (lambda (self new-select-list)
                (set! select-list new-select-list)))

             ((eq? message 'get-buffer)
              (lambda (self)
                buffer))

             ((eq? message 'get-working-dir)
              (lambda (self)
                working-dir))
       
             (else
              (error "fsobjects-viewer unknown message" message)))))))

(define (list-of-fs-objects? thing)
  (and (proper-list? thing)
       (every fs-object? thing)))

(register-plugin! 
 (make-view-plugin make-fsobjects-viewer
		   list-of-fs-objects?))