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

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

(define-record-type filelist-state :filelist-state
  (make-filelist-state files select-list working-dir initial-dir)
  filelist-state?
  (files filelist-state-files)
  (select-list filelist-state-select-list)
  (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)
  (let ((name (fs-object-name fs-object))
	(info (fs-object-info fs-object)))
    (cond
     ((file-info-directory? info)
      (string-append " " name "/"))
     ((file-info-executable? info)
      (string-append "*" name))
     ((file-info-symlink? info)
      (string-append "@" name))
     (else
      (string-append " " 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)
  (add-marks-to-special-file fsobject))

(define (make-file-select-list fsobjects num-lines)
  (make-select-list
   (cons (make-unmarked-element 'parent-dir #f " ..")
	 (map (lambda (fs-object)
		(make-unmarked-element 
		 fs-object #t (layout-fsobject 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 state width)
  (let ((dir (filelist-state-working-dir state)))
    (string-append 
     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)))
	
   ((print-message? message)
    (paint-browser (message-result-object message)))

   ((key-pressed-message? message)
    (handle-key-press message))
   
   (else
    (values))))

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

(register-plugin! 
 (make-view-plugin filelist-browser
		   list-of-fs-objects?))