Kill `browse-list' plugin. Introduce module `select-list', a library

for programming multi-page menus in the result-buffer. Remove the
print-object and make plugins return a function to paint the
result-buffer instead.

scheme/browse-directory-list.scm

@@ -161,7 +161,11 @@
 	     (marked-pos (get-marked-positions-3
 			  (browse-dir-list-res-obj-file-list model)
 			  (browse-dir-list-res-obj-marked-items model))))
-	(make-print-object pos-y pos-x text (list pos-y) marked-pos))) 
+	(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)
       (let* ((model (message-result-object message))

scheme/eval.scm

@@ -1,3 +1,15 @@
+(define-syntax run/strings-status
+  (syntax-rules ()
+     ((_ epf)
+      (call-with-values
+         (lambda ()
+             (run/port+proc epf))
+         (lambda (port proc)
+            (let ((string-list (port->string-list port))
+                   (status (wait proc)))
+               (close-input-port port)
+               (values string-list status)))))))
+
 (define (directory-files . optional-args)
   (let-optionals optional-args
       ((dir (cwd))

scheme/inspector.scm

@@ -23,8 +23,9 @@
     (let ((val (inspector-state-val (message-result-object message))))
       (let ((head-line (format #f "~a" val))
             (menu (map (lambda (val) (format #f "~a" val)) (prepare-menu val))))
-      (make-print-object 1 1 (cons head-line menu)
+	(make-simple-result-buffer-printer
-                         '() '()))))
+	 1 1 (cons head-line menu) '() '()))))
+
    ((key-pressed-message? message)
     (let ((old-state (message-result-object message))
           (key (key-pressed-message-key message)))

scheme/layout.scm

@@ -61,3 +61,129 @@
   (let ((tmp (list-tail l pos)))
     (reverse (list-tail (reverse tmp) 
 			(- (length tmp) k)))))
+
+;; crappy redrawing code
+
+(define-record-type result-buffer :result-buffer
+  (make-result-buffer line column y x num-lines num-cols highlighted marked)
+  result-buffer?
+  (line result-buffer-line
+	set-result-buffer-line!)
+  (column result-buffer-column 
+	  set-result-buffer-column!)
+  (y result-buffer-y set-result-buffer-y!)
+  (x result-buffer-x set-result-buffer-x!)
+  (num-lines result-buffer-num-lines
+	     set-result-buffer-num-lines!)
+  (num-cols result-buffer-num-cols
+	    set-result-buffer-num-cols!)
+  (highlighted result-buffer-highlighted
+	       set-result-buffer-highlighted!)
+  (marked result-buffer-marked
+	  set-result-buffer-marked!))
+
+;;selection of the visible area of the buffer
+(define (prepare-lines l height pos)
+  (if (< (length l) height)
+      (let loop ((tmp-list l))
+	(if (= height (length tmp-list))
+	    tmp-list
+	    (loop (append tmp-list (list "")))))
+      (if (<  pos height)
+	  (sublist l 0 height)
+	  (sublist l (- pos height) height))))
+
+(define (get-right-result-lines result-buffer text)
+  (prepare-lines text 
+		 (result-buffer-num-lines result-buffer)
+		 (result-buffer-line result-buffer)))
+
+;;marked and highlighted lines
+(define (right-highlighted-lines result-buffer lines)
+  (let ((pos-result (result-buffer-line result-buffer))
+	(result-lines (result-buffer-num-lines result-buffer)))
+    (let loop ((lines lines) (new '()))
+      (if (null? lines)
+	  new
+	  (let ((el (car lines)))
+	    (if (<= pos-result result-lines)
+		;;auf der ersten Seite
+		(loop (cdr lines)
+		      (append new (list el)))
+		(let* ((offset (- pos-result result-lines))
+		       (new-el (- el offset)))
+		  (loop (cdr lines)
+			(append new (list new-el))))))))))
+
+(define (right-marked-lines result-buffer lines)
+  (let ((pos-result (result-buffer-column result-buffer))
+	(result-lines (result-buffer-num-lines result-buffer))
+	(marked-lines (result-buffer-marked result-buffer)))
+    (let loop ((old marked-lines)
+	       (new '()))
+      (if (null? old)
+	  new
+	  (let ((el (car old)))
+	    (if (<= pos-result result-lines)
+		;;auf der ersten Seite
+		(loop (cdr old)
+		      (append new (list el)))
+		(let* ((offset (- pos-result result-lines))
+		       (new-el (- el offset )))
+		  (loop (cdr old)
+			(append new (list new-el))))))))))
+
+(define (make-simple-result-buffer-printer 
+	 pos-y pos-x text highlighted-lines marked-lines)
+  (lambda (window result-buffer result-buffer-has-focus?)
+
+    (set-result-buffer-y! result-buffer pos-y)
+    (set-result-buffer-column! result-buffer pos-x)
+    (set-result-buffer-highlighted! result-buffer
+				    highlighted-lines)
+    (set-result-buffer-marked! result-buffer
+			       marked-lines)
+    (set-result-buffer-highlighted! 
+     result-buffer (right-highlighted-lines result-buffer text))
+    (set-result-buffer-marked!
+     result-buffer (right-marked-lines result-buffer text))
+
+    (let ((lines (get-right-result-lines result-buffer text))
+	  (result-lines (result-buffer-num-lines result-buffer))
+	  (result-cols (result-buffer-num-cols result-buffer)))
+      
+      (let loop ((pos 1))
+	(if (> pos result-lines)
+	    (values)
+	    (let* ((line (list-ref lines (- pos 1)))
+		   (fitting-line
+		    (if (> (string-length line) result-cols)
+			(let ((start-line 
+			       (substring line 0
+					  (- (ceiling (/ result-cols 2))
+					     3)))
+			      (end-line
+			       (substring line 
+					  (- (string-length line)
+					     (ceiling 
+					      (/ result-cols 2)))
+					  (string-length line))))
+			  (string-append start-line "..." end-line))
+			line)))
+	      (if (and result-buffer-has-focus?
+		       (member pos highlighted-lines))
+		  (begin
+		    (wattron window (A-REVERSE))
+		    (mvwaddstr window pos 1 line)
+		    (wattrset window (A-NORMAL))
+		    (loop (+ pos 1)))
+		  (if (member pos marked-lines)
+		      (begin
+			(wattron window (A-BOLD))
+			(mvwaddstr window pos 1 line)
+			(wattrset window (A-NORMAL))
+			(loop (+ pos 1)))
+		      (begin
+			(mvwaddstr window pos 1 line)
+			(loop (+ pos 1)))))))))))
+

scheme/nuit-engine.scm

@@ -56,31 +56,11 @@
 ;;state of the lower window (Result-Window)
 ;;----------------------------
 ;;Text
-(define text-result (list "Type 'shortcuts' for help"))
 
-;;line of the result-window
+(define result-buffer
-(define pos-result 0)
+  (make-result-buffer 0 0 0 0
-
+		      #f #f ; set in INIT-WINDOWS
-;;column
+		      '() '()))
-(define pos-result-col 0)
-
-;;y-coordinate of the cursor in the result-buffer
-(define result-buffer-pos-y 0)
-
-;;x-coordinate of the cursor in the result-buffer
-(define result-buffer-pos-x 0)
-
-;;lines of the lower window
-(define result-lines 0)
-
-;;columns in the lower window
-(define result-cols 0)
-
-;;lines to be highlighted
-(define highlighted-lines '())
-
-;;lines to be marked
-(define marked-lines '())
 
 ;;miscelaneous state
 ;;-------------------
@@ -221,7 +201,7 @@
     (refresh-result-window))
    (else
     (focus-command-buffer!)
-    (move-cursor command-buffer)
+    (move-cursor command-buffer result-buffer)
     (refresh-command-window))))
 
 (define (toggle-command/scheme-mode)
@@ -232,7 +212,7 @@
     (enter-command-mode!)))
   (paint-command-frame-window)
   (paint-command-window-contents)
-  (move-cursor command-buffer)
+  (move-cursor command-buffer result-buffer)
   (refresh-command-window))
 
 (define (handle-return-key)
@@ -323,6 +303,7 @@
       (let ((key-message
 	     (make-key-pressed-message
 	      (active-command) (current-result)
+	      result-buffer
 	      ch key-control-x)))
 	(update-current-result!
 	 (post-message
@@ -373,8 +354,10 @@
 	    (history-entry-plugin (entry-data (current-history-item)))
 	    (make-key-pressed-message 
 	     (active-command) (current-result)
+	     result-buffer
 	     ch c-x-pressed?)))
 	  (paint-result-window (entry-data (current-history-item)))
+	  (move-cursor command-buffer result-buffer)
 	  (refresh-result-window))
 	(loop (wait-for-input) #f))
        (else
@@ -382,7 +365,7 @@
 	(werase (app-window-curses-win command-window))
 	(print-command-buffer (app-window-curses-win command-window) 
 			      command-buffer)
-	(move-cursor command-buffer)
+	(move-cursor command-buffer result-buffer)
 	(refresh-command-window)
 	(loop (wait-for-input) c-x-pressed?)))))))
 
@@ -428,6 +411,11 @@
 			   result-frame-window result-window)))
     (for-each window-init-curses-win! all-windows)
 
+    (set-result-buffer-num-lines! 
+     result-buffer (- (app-window-height result-window) 2))
+    (set-result-buffer-num-cols!
+     result-buffer (- (app-window-width result-window) 3))
+  
     (debug-message "init-windows!: bar-1 " bar-1 
 		   " active-command-window " active-command-window
 		   " command-frame-window " command-frame-window
@@ -480,9 +468,6 @@
   (let ((win (app-window-curses-win result-frame-window)))
     (wclear win)
     (box win (ascii->char 0) (ascii->char 0))
-    ;;; EK: wtf is going on here?
-    (set! result-lines (- (app-window-height result-window) 2))
-    (set! result-cols (- (app-window-width result-window) 3))
     (wrefresh win)))
 
 (define (paint-result-window entry)
@@ -502,7 +487,7 @@
   (paint-active-command-window)
   (scroll-command-buffer)
   (paint-command-window-contents)
-  (move-cursor command-buffer)
+  (move-cursor command-buffer result-buffer)
   (refresh-result-window)
   (refresh-command-window))
 
@@ -514,7 +499,7 @@
   (paint-active-command-window)
   (paint-result-frame-window)
   ;(paint-result-window)
-  (move-cursor command-buffer)
+  (move-cursor command-buffer result-buffer)
   (refresh-command-window)
   (refresh-result-window))
 
@@ -665,17 +650,6 @@
 	  (add-to-command-buffer (char->ascii first-ch))
 	  (loop (substring str 1 (string-length str)))))))
 
-;;selection of the visible area of the buffer
-(define (prepare-lines l height pos)
-  (if (< (length l) height)
-      (let loop ((tmp-list l))
-	(if (= height (length tmp-list))
-	    tmp-list
-	    (loop (append tmp-list (list "")))))
-      (if (<  pos height)
-	  (sublist l 0 height)
-	  (sublist l (- pos height) height))))
-
 ;;; FIXME: I guess s48 knows a better way to do this (see ,inspect)
 (define (maybe-shorten-string string width)
   (if (> (string-length string) width)
@@ -696,115 +670,35 @@
 		       (history-entry-command (entry-data entry)) width)))))
     (wrefresh win)))
 
-(define (paint-result-buffer print-object)
+(define (paint-result-buffer paint-proc)
-  (let* ((window (app-window-curses-win result-window))
+  (paint-proc (app-window-curses-win result-window)
-	 (text (print-object-text print-object))
+	      result-buffer
-	 (pos-y (print-object-pos-y print-object))
+	      (focus-on-result-buffer?)))
-	 (pos-x (print-object-pos-x print-object))
-	 (highlighted-lns (print-object-highlighted-lines print-object))
-	 (marked-lns (print-object-marked-lines print-object)))
-    (set! text-result text)
-    (set! pos-result pos-y)
-    (set! pos-result-col pos-x)
-    (set! highlighted-lines highlighted-lns)
-    (set! marked-lines marked-lns)
-    (right-highlighted-lines)
-    (right-marked-lines)
-    (let ((lines (get-right-result-lines)))
-      (let loop ((pos 1))
-	(if (> pos result-lines)
-	    (values)
-	    (let ((line (list-ref lines (- pos 1))))
-	      (begin
-		(if (not (standard-result-obj? (current-result)))
-		    (set! line 
-			  (if (> (string-length line) result-cols)
-			      (let ((start-line 
-				     (substring line 0
-						(- (ceiling (/ result-cols 2))
-						   3)))
-				    (end-line
-				     (substring line 
-						(- (string-length line)
-						   (ceiling 
-						    (/ result-cols 2)))
-						(string-length line))))
-				(string-append start-line "..." end-line))
-			      line)))
-		(if (and (member pos highlighted-lines)
-			 (focus-on-result-buffer?))
-		    (begin
-		      (wattron window (A-REVERSE))
-		      (mvwaddstr window pos 1 line)
-		      (wattrset window (A-NORMAL))
-		      ;(wrefresh window)
-		      (loop (+ pos 1)))
-		    (if (member pos marked-lines)
-			(begin
-			  (wattron window (A-BOLD))
-			  (mvwaddstr window pos 1 line)
-			  (wattrset window (A-NORMAL))
-			  ;(wrefresh window)
-			  (loop (+ pos 1)))
-			(begin
-			  (mvwaddstr window pos 1 line)
-			  ;(wrefresh window)
-			  (loop (+ pos 1))))))))))))
-  
-;;visible lines
-(define (get-right-result-lines)
-  (prepare-lines text-result result-lines pos-result))
-	  
-;;marked and highlighted lines
-(define (right-highlighted-lines)
-  (let loop ((old highlighted-lines)
-	     (new '()))
-    (if (null? old)
-	(set! highlighted-lines new)
-	(let ((el (car old)))
-	  (if (<= pos-result result-lines)
-	      ;;auf der ersten Seite
-	      (loop (cdr old)
-		    (append new (list el)))
-	      (let* ((offset (- pos-result result-lines))
-		     (new-el (- el offset )))
-		(loop (cdr old)
-		      (append new (list new-el)))))))))
-
-(define (right-marked-lines)
-  (let loop ((old marked-lines)
-	     (new '()))
-    (if (null? old)
-	(set! marked-lines new)
-	(let ((el (car old)))
-	  (if (<= pos-result result-lines)
-	      ;;auf der ersten Seite
-	      (loop (cdr old)
-		    (append new (list el)))
-	      (let* ((offset (- pos-result result-lines))
-		     (new-el (- el offset )))
-		(loop (cdr old)
-		      (append new (list new-el)))))))))
   
 ;;Cursor
 ;;move cursor to the corrct position
-(define (move-cursor buffer)
+(define (move-cursor command-buffer result-buffer)
-  (if (focus-on-command-buffer?)
+  (cond
-      (cursor-right-pos (app-window-curses-win command-window)
+   ((focus-on-command-buffer?)
-			buffer)
+    (cursor-right-pos 
-      (begin
+     (app-window-curses-win command-window)
-	(compute-y-x)
+     command-buffer))
-	(wmove (app-window-curses-win result-window) 
+   (else
-	       result-buffer-pos-y result-buffer-pos-x)
+    (compute-y-x result-buffer)
-	(wrefresh (app-window-curses-win result-window))
+    (wmove (app-window-curses-win result-window) 
-	buffer)))
+	   (result-buffer-y result-buffer)
+	   (result-buffer-x result-buffer))
+    (wrefresh (app-window-curses-win result-window)))))
 
 ;;compue pos-x and pos-y
-(define (compute-y-x)
+(define (compute-y-x result-buffer)
-  (if (>= pos-result result-lines)
+  (let ((pos-result (result-buffer-line result-buffer))
-      (set! result-buffer-pos-y result-lines)
+	(pos-result-col (result-buffer-column result-buffer))
-      (set! result-buffer-pos-y pos-result))
+	(result-lines (result-buffer-num-lines result-buffer)))
-  (set! result-buffer-pos-x pos-result-col))
+    (if (>= pos-result result-lines)
+	(set-result-buffer-y! result-buffer result-lines)
+	(set-result-buffer-y! result-buffer pos-result))
+    (set-result-buffer-x! result-buffer pos-result-col)))
 
 (define (sublist l pos k)
   (let ((tmp (list-tail l pos)))
@@ -814,15 +708,6 @@
 ;;When NUIT is closed the state has to be restored, in order to let the
 ;;user start again from scratch 
 (define (restore-state)
-  (set! text-result (list "Start entering commands."))
-  (set! pos-result 0)
-  (set! pos-result-col 0)
-  (set! result-buffer-pos-y 0)
-  (set! result-buffer-pos-x 0)
-  (set! result-lines 0)
-  (set! result-cols 0)
-  (set! highlighted-lines '())
-  (set! marked-lines '())
   (set! history '())
   (set! history-pos 0)
   (set! active-keyboard-interrupt #f))
@@ -846,8 +731,8 @@
   (result-text standard-result-obj-result-text)
   (result standard-result-obj-result))
 
-(define init-std-res (make-standard-result-obj 1 1 text-result 
+(define init-std-res 
-					       (car text-result)))
+  (make-standard-result-obj 1 1 '("") ""))
 
 ;;Standard-Receiver:
 (define (standard-receiver-rec message)
@@ -874,7 +759,9 @@
 	   (result (standard-result-obj-result model))
 	   (text (layout-result-standard 
 		  (exp->string result) width)))
-      (make-print-object pos-y pos-x text '() '())))
+      (make-simple-result-buffer-printer
+       pos-y pos-x text '() '())))
+
    ((key-pressed-message? message)
     (message-result-object message))
    ((restore-message? message)

scheme/nuit-packages.scm

@@ -26,12 +26,36 @@
 	  get-marked-positions-2
 	  get-marked-positions-3
 	  exp->string
-	  sublist))
+	  sublist
+
+	  ;; old drawing cruft
+	  make-result-buffer
+	  result-buffer?
+	  result-buffer-line
+	  set-result-buffer-line!
+	  result-buffer-column
+	  set-result-buffer-column!
+	  result-buffer-y
+	  set-result-buffer-y!
+	  result-buffer-x
+	  set-result-buffer-x!
+	  result-buffer-num-lines
+	  set-result-buffer-num-lines!
+	  result-buffer-num-cols
+	  set-result-buffer-num-cols!
+	  result-buffer-highlighted
+	  set-result-buffer-highlighted!
+	  result-buffer-marked
+	  set-result-buffer-marked!
+	  make-simple-result-buffer-printer))
 
 (define-structure layout layout-interface
   (open scheme
 	srfi-6			;; basic string ports
-	)
+	define-record-types
+
+	tty-debug
+	ncurses)
   (files layout))
 
 ;;; process viewer plugin
@@ -39,10 +63,14 @@
 (define-structure process-view-plugin
     (export)
   (open scheme
+	define-record-types
 	srfi-1
+	srfi-13
 	formats
+
 	pps
 	plugin
+	select-list
 	tty-debug)
   (files process))
 
@@ -60,17 +88,6 @@
 	tty-debug)
   (files browse-directory-list))
 
-;;; browse-list plugin
-
-(define-structure browse-list-plugin
-    (export)
-  (open scheme
-	define-record-types
-	ncurses
-	plugin
-	layout)
-  (files browse-list))
-
 ;;; standard command plugin
 
 (define-structure standard-command-plugin
@@ -92,6 +109,31 @@
 	define-record-types)
   (files fs-object))
 
+;;; browse list stuff
+
+(define-interface select-list-interface
+  (export make-select-list
+	  select-list?
+	  select-list-cursor-index
+	  select-list-cursor-y
+	  select-list-handle-key-press
+	  unmark-current-line
+	  mark-current-line
+	  move-cursor-up
+	  move-cursor-down
+	  paint-selection-list))
+
+(define-structure select-list select-list-interface
+  (open scheme
+	srfi-1
+	define-record-types
+	
+	tty-debug
+	plugin
+	layout
+	ncurses)
+  (files select-list))
+
 ;;; inspector
 
 (define-interface nuit-inspector-interface
@@ -104,6 +146,7 @@
         formats
         define-record-types
 
+	layout
         tty-debug
         plugin)
   (files inspector))
@@ -138,14 +181,6 @@
 
 	  register-plugin!
 
-	  make-print-object
-	  print-object?
-	  print-object-pos-y
-	  print-object-pos-x
-	  print-object-text
-	  print-object-highlighted-lines
-	  print-object-marked-lines
-
 	  next-command-message?
 	  next-command-string
 	  next-command-message-parameters
@@ -156,6 +191,7 @@
 	  init-with-result-message-width
 
 	  key-pressed-message?
+	  key-pressed-message-result-buffer
 	  key-pressed-message-result-object
 	  key-pressed-message-key
 	  key-pressed-message-prefix-key
@@ -223,11 +259,9 @@
 	pps
 	history
 	;; the following modules are plugins
-	browse-list-plugin
 	dirlist-view-plugin
 	process-view-plugin
 	standard-command-plugin
         nuit-inspector-plugin)
   (files nuit-engine
 	 handle-fatal-error))
-

scheme/plugins.scm

@@ -29,21 +29,6 @@
     (set! *view-plugins* (cons plugin *view-plugins*)))
    (error "unknown plugin type" plugin)))
 
-;; answers
-
-(define-record-type print-object :print-object
-  (make-print-object pos-y
-		     pos-x
-		     text
-		     highlighted-lines
-		     marked-lines)
-  print-object?
-  (pos-y print-object-pos-y)
-  (pos-x print-object-pos-x)
-  (text print-object-text)
-  (highlighted-lines print-object-highlighted-lines)
-  (marked-lines print-object-marked-lines))
-
 ;; messages
 
 (define-record-type next-command-message :next-command-message
@@ -67,10 +52,12 @@
 (define-record-type key-pressed-message :key-pressed-message
   (make-key-pressed-message command-string
 			    result-object
+			    result-buffer
 			    key prefix-key)
   key-pressed-message?
   (command-string key-pressed-command-string)
   (result-object key-pressed-message-result-object)
+  (result-buffer key-pressed-message-result-buffer)
   (key key-pressed-message-key)
   (prefix-key key-pressed-message-prefix-key))
 

scheme/process.scm

@@ -1,37 +1,69 @@
+(define-record-type plugin-state :plugin-state
+  (make-plugin-state processes selection-list cursor-x)
+  plugin-state?
+  (processes plugin-state-processes)
+  (selection-list plugin-state-selection-list)
+  (cursor-x plugin-state-cursor-x))
+
+(define-record-discloser :plugin-state
+  (lambda (r)
+    `(plugin-state ,(plugin-state-selection-list r))))
+
 (define (list-of-processes? thing)
   (and (proper-list? thing)
        (every process-info? thing)))
 
-(define (print-processes processes)
+(define (string-take-max s nchars)
-  (map (lambda (pi)
+  (if (>= nchars (string-length s))
-	 (apply format 
+      s
-		(append
+      (string-take s nchars)))
-		 (list #f 
+
-		       "~A ~A ~A ~A '~A ~A'~%")
+(define (layout-process width p)
-		 (map (lambda (s) (s pi))
+  (string-take-max
-		      (list process-info-pid 
+   (apply format 
-			    process-info-ppid
+	  (append
-			    process-info-real-uid 
+	   (list #f "~A ~A ~A ~A '~A ~A'~%")
-			    process-info-%cpu
+	   (map (lambda (s) (s p))
-			    process-info-executable
+		(list process-info-pid 
-			    process-info-command-line)))))
+		      process-info-ppid
-       processes))
+		      process-info-real-uid 
+		      process-info-%cpu
+		      process-info-executable
+		      process-info-command-line))))
+   width))
+  
+(define (make-process-selection-list width processes)
+  (let ((layout (lambda (p) (layout-process width p))))
+    (make-select-list
+     (zip processes (map layout processes)))))
 
 (define (pps-receiver message)
   (debug-message "pps-receiver " message)
   (cond
-   ((next-command-message? message)
+
-    (pps))
    ((init-with-result-message? message)
-    (init-with-result-message-result message))
+    (let ((processes (init-with-result-message-result message))
+	  (width (init-with-result-message-width message)))
+      (make-plugin-state 
+       processes (make-process-selection-list width processes) 1)))
+
    ((print-message? message)
-    (let ((processes (message-result-object message)))
+    (paint-selection-list
-      (make-print-object 1 1 (print-processes processes)
+     (plugin-state-selection-list
-			 '() '())))
+      (message-result-object message))))
+
    ((key-pressed-message? message)
-    (pps))
+    (let ((old-state (message-result-object message)))
+      (make-plugin-state 
+       (plugin-state-processes old-state)
+       (select-list-handle-key-press
+	(plugin-state-selection-list old-state)
+	message)
+       (plugin-state-cursor-x old-state))))
+
    ((restore-message? message)
     (values))
+
    ((selection-message? message)
     "'()")))
 

scheme/select-list.scm

@@ -0,0 +1,168 @@
+(define-record-type element :element
+  (make-element marked? value text)
+  element?
+  (marked? element-marked? set-element-marked?!)
+  (value element-value)
+  (text element-text))
+
+(define-record-discloser :element
+  (lambda (r)
+    `(element ,(element-marked? r) ,(element-text r))))
+
+(define (make-unmarked-element value text)
+  (make-element #f value text))
+
+(define-record-type select-list :select-list
+  (really-make-select-list elements view-index cursor-index cursor-y)
+  select-list?
+  (elements select-list-elements)
+  (view-index select-list-view-index)
+  (cursor-index select-list-cursor-index)
+  (cursor-y select-list-cursor-y))
+
+(define-record-discloser :select-list
+  (lambda (r)
+    `(select-list (index ,(select-list-cursor-index r))
+		  (view-index ,(select-list-view-index r))
+		  (y ,(select-list-cursor-y r)))))
+
+(define (make-select-list value/text-tuples)
+  (really-make-select-list 
+   (map (lambda (value/text)
+	  (apply make-unmarked-element value/text))
+	value/text-tuples)
+   0 0 1))
+
+(define key-m 109)
+
+(define key-u 117)
+
+(define (select-list-handle-key-press select-list key-message)
+  (let ((key (key-pressed-message-key key-message))
+	(result-buffer (key-pressed-message-result-buffer key-message)))
+    (cond 
+     ((= key key-m)
+      (mark-current-line select-list))
+     ((= key key-u)
+      (unmark-current-line select-list))
+     ((= key key-up)
+      (move-cursor-up select-list result-buffer))
+     ((= key key-down)
+     (move-cursor-down select-list result-buffer))
+     (else
+      select-list))))
+
+(define (mark/unmark-current-line-maker mark)
+  (lambda (select-list)
+    (let* ((index (select-list-cursor-index select-list))
+	   (elements (select-list-elements select-list)))
+      (really-make-select-list
+       (fold-right 
+	(lambda (element.i result)
+	  (let ((el (car element.i))
+		(i (cadr element.i)))
+	    (cons (make-element
+		   (if (= index i) mark (element-marked? el))
+		   (element-value el)
+		   (element-text el))
+		  result)))
+	'() (zip elements (iota (length elements))))
+       (select-list-view-index select-list)
+       index (select-list-cursor-y select-list)))))
+
+(define unmark-current-line
+  (mark/unmark-current-line-maker #f))
+
+(define mark-current-line
+  (mark/unmark-current-line-maker #t))
+
+;; returns: y cursor-index view-index
+(define (calculate-view index-move cursor-move 
+ 			elements view-index cursor-index
+ 			num-lines y)
+  (let ((new-index (index-move cursor-index))
+ 	(max-index (- (length elements) 1)))
+    (cond
+     ((< new-index 0) 
+      (values 0 0 view-index))
+     ((> new-index max-index)
+      (values y max-index view-index))
+     ((and (>= (- new-index view-index) num-lines)
+ 	   (> new-index cursor-index))
+      (values 1 new-index (+ view-index num-lines)))
+     ((and (< new-index cursor-index)
+	   (>= view-index cursor-index))
+      (values num-lines new-index (- view-index num-lines)))
+     (else
+      (values (cursor-move y) (index-move cursor-index) view-index)))))
+
+(define (copy-element-list elements)
+  (fold-right
+   (lambda (el result)
+     (cons 
+      (make-element (element-marked? el)
+		    (element-value el)
+		    (element-text el))
+      result))
+   '() elements))
+
+(define (move-cursor-maker index-move cursor-move)
+  (lambda (select-list result-buffer)
+    (let* ((elements (select-list-elements select-list))
+	   (old-index (select-list-cursor-index select-list)))
+      (call-with-values
+	  (lambda ()
+	    (calculate-view index-move cursor-move
+			    elements
+			    (select-list-view-index select-list)
+			    old-index
+			    (result-buffer-num-lines result-buffer)
+			    (select-list-cursor-y select-list)))
+      (lambda (y cursor-index view-index)
+	(really-make-select-list
+	 (copy-element-list elements)
+	 view-index
+	 cursor-index 
+	 y))))))
+
+(define move-cursor-up
+  (let ((sub-one (lambda (y) (- y 1))))
+    (move-cursor-maker sub-one sub-one)))
+
+(define move-cursor-down
+  (let ((add-one (lambda (y) (+ y 1))))
+    (move-cursor-maker add-one add-one)))
+
+(define (take-max lst num)
+  (if (>= num (length lst))
+      lst
+      (take lst num)))
+
+(define (select-visible-elements select-list result-buffer)
+  (let ((num-lines (result-buffer-num-lines result-buffer)))
+    (take-max (drop (select-list-elements select-list) 
+		    (select-list-view-index select-list))
+	      (+ 1 num-lines)))) ;;; wtf? why this
+
+(define (paint-selection-list select-list)
+  (lambda (win result-buffer have-focus?)
+    (let lp ((elts 
+	      (select-visible-elements select-list result-buffer))
+	     (y 0) 
+	     (i (select-list-view-index select-list)))
+      (cond
+       ((null? elts)
+	(values))
+       ((= i (select-list-cursor-index select-list))
+	(wattron win (A-REVERSE))
+	(mvwaddstr win y 0 (element-text (car elts)))
+	(wattrset win (A-NORMAL))
+	(lp (cdr elts) (+ y 1) (+ i 1)))
+       ((element-marked? (car elts))
+	(wattron win (A-BOLD))
+	(mvwaddstr win y 0 (element-text (car elts)))
+	(wattrset win (A-NORMAL))
+	(lp (cdr elts) (+ y 1) (+ i 1)))
+       (else
+	(mvwaddstr win y 0 (element-text (car elts)))
+	(lp (cdr elts) (+ y 1) (+ i 1)))))))

scheme/std-command.scm

@@ -2,7 +2,7 @@
   #f)
 
 (define (standard-command-plugin-evaluater command args)
-  (directory-files))
+  (run/strings (,command ,@args)))
 
 (define standard-command-plugin
   (make-command-plugin #f