commander-s/scheme/nuit-engine.scm

;;  ,load /home/demattia/studium/studienarbeit/scsh-nuit/scheme/nuit-engine.scm

(define-syntax when
  (syntax-rules ()
    ((_ ?test ?do-this ...)
     (if ?test 
	 (begin ?do-this ... (values))
	 (values)))))

(define (with-lock lock thunk)
  (obtain-lock lock)
  (let ((val (thunk)))
    (release-lock lock)
    val))

;;This is the "heart" of NUIT.
;;In a central loop the program waits for input (with wgetch).
;;In the upper buffer simply the functionalities of scsh-ncurses:
;;input-buffer are used.
;;The lower window is meant to be used more flexible. Depending on
;;the active command the key-inputs are routed to the correct receiver,
;;where one can specify how to react.

;;*************************************************************************
;;State

(define-record-type app-window :app-window
  (make-app-window x y width height curses-win)
  app-window?
  (x app-window-x)
  (y app-window-y)
  (width app-window-width)
  (height app-window-height)
  (curses-win app-window-curses-win set-app-window-curses-win!))

(define-record-discloser :app-window
  (lambda (rec)
    `(app-window 
      (x ,(app-window-x rec)) (y ,(app-window-y rec))
      (w ,(app-window-width rec)) (h ,(app-window-height rec)))))

(define bar-1 #f)
(define active-command-window #f)

(define command-frame-window #f)
(define command-window #f)

(define result-window #f)
(define result-frame-window #f)

(define executable-completions-lock (make-lock))
(define executable-completions #f)

(define key-control-x 24)
(define key-o 111)
(define key-tab 9)
		    
;;state of the upper window (Command-Window)
(define command-buffer 
  (make-buffer '("Welcome to the scsh-ncurses-ui!" "")
	       2 2 2 1 1
	       0 0
	       #t 1))

;;state of the lower window (Result-Window)
;;----------------------------
;;Text

(define result-buffer
  (make-result-buffer 0 0 0 0
		      #f #f ; set in INIT-WINDOWS
		      '() '()))

;;miscelaneous state
;;-------------------

(define *focus-buffer* 'command-buffer)

(define (focus-on-command-buffer?)
  (eq? *focus-buffer* 'command-buffer))

(define (focus-command-buffer!)
  (set! *focus-buffer* 'command-buffer))

(define (focus-on-result-buffer?)
  (eq? *focus-buffer* 'result-buffer))

(define (focus-result-buffer!)
  (set! *focus-buffer* 'result-buffer))

;; mode of the command buffer
(define *command-buffer-mode* 'scheme)

(define (command-buffer-in-scheme-mode?)
  (eq? *command-buffer-mode* 'scheme))

(define (command-buffer-in-command-mode?)
  (eq? *command-buffer-mode* 'command))

(define (enter-scheme-mode!)
  (set! *command-buffer-mode* 'scheme))

(define (enter-command-mode!)
  (set! *command-buffer-mode* 'command))

;; History

(define history-pos 0)
(define the-history (make-empty-history))

(define (history) the-history)

(define *current-history-item* #f)

(define (current-history-item)
  *current-history-item*)

(define-record-type history-entry :history-entry
  (make-history-entry command args viewer)
  history-entry?
  (command history-entry-command)
  (args history-entry-args)
  (viewer history-entry-viewer set-history-entry-viewer!))

(define (current-history-entry-selector-maker selector)
  (lambda ()
    (cond
     ((current-history-item)
      => (lambda (entry)
	   (selector (entry-data entry))))
     (else #f))))

(define active-command
  (current-history-entry-selector-maker history-entry-command))

(define active-command-arguments
  (current-history-entry-selector-maker history-entry-args))

(define current-viewer
  (current-history-entry-selector-maker history-entry-viewer))

(define (update-current-viewer! new-viewer)
  (cond
   ((current-history-item)
    => (lambda (entry)
	 (set-history-entry-viewer! (entry-data entry) new-viewer)))
   (else (values))))

(define (append-to-history! history-entry)
  (append-history-item! the-history history-entry)
  (set! *current-history-item* 
	(history-last-entry the-history)))

;;  one step back in the history
(define (history-back!)
  (cond
   ((and (current-history-item)
	 (history-prev-entry (current-history-item)))
    => (lambda (prev)
	 (set! *current-history-item* prev)))
   (else (values))))

;; one step forward
(define (history-forward!)
  (cond
   ((and *current-history-item*
	 (history-next-entry *current-history-item*))
    => (lambda (next)
	 (set! *current-history-item* next)))
   (else (values))))

;;active keyboard-interrupt:
;;after each input this is set to #f.
;;If a keyboard-interrupt occurs this can be checked by looking-up this box
(define active-keyboard-interrupt #f)

   
;;The "user" (who extends the functionality of NUIT) has to inform NUIT
;;about which function is meant to be the receiver, when a certain
;;command is active

;;*************************************************************************
;;Actions
      
;;start the whole thing
(define (nuit)
  (let ((tty-name (init-tty-debug-output!)))
    (display "Debug messages will be on ")
    (display tty-name)
    (newline))
  (with-inspecting-handler
   8888
   (lambda (condition)
     (with-current-output-port*
      (error-output-port)
      (lambda ()
	(display "starting remote handler for condition") 
	(display condition)
	(newline)
	(display "Please connect to port 8888")
	(newline)
	#t)))
   run))

(define (toggle-buffer-focus)
  (cond
   ((focus-on-command-buffer?)
    (focus-result-buffer!)
    (refresh-result-window))
   (else
    (focus-command-buffer!)
    (move-cursor command-buffer result-buffer)
    (refresh-command-window))))

(define (toggle-command/scheme-mode)
  (cond 
   ((command-buffer-in-command-mode?)
    (enter-scheme-mode!))
   ((command-buffer-in-scheme-mode?)
    (enter-command-mode!)))
  (paint-command-frame-window)
  (paint-command-window-contents)
  (move-cursor command-buffer result-buffer)
  (refresh-command-window))

(define (handle-return-key)
  (let ((command-line (cadr (reverse (buffer-text command-buffer)))))
    (debug-message "command-line " command-line)
    (cond
     ((string=? command-line "")
      (values))
     ((command-buffer-in-scheme-mode?)
      (eval-command-in-scheme-mode command-line))
     ((command-buffer-in-command-mode?)
      (eval-command-in-command-mode command-line))
     (else
      (error "Cannot handle return key" command-line)))))

(define (find-command-plugin command)
  (or (find (lambda (p)
	      (string=? (command-plugin-command p) command))
	    (command-plugin-list))
      standard-command-plugin))

(define (eval-command-in-command-mode command-line)
  (let* ((tokens (split-command-line command-line))
	 (command (car tokens))
	 (args (cdr tokens))
	 (command-plugin (find-command-plugin command))
	 (viewer
	  (find/init-plugin-for-result
	   (with-errno-handler
	    ((errno data)
	     (else data))
	    ((command-plugin-evaluater command-plugin) command args))))
	 (new-entry
	  (make-history-entry command args viewer)))
    ;; FIXME, use insert here
    (append-to-history! new-entry)
    (paint-result-window new-entry)
    (refresh-result-window)
    (move-cursor command-buffer result-buffer)
    (refresh-command-window)))

(define (eval-command-in-scheme-mode command-line)
  (let ((viewer
	 (find/init-plugin-for-result
	  (eval-expression command-line))))
    (let* ((tokens (split-command-line command-line))
	   (command (car tokens))
	   (args (cdr tokens))
	   (new-entry
	    (make-history-entry command args viewer)))
      ;; #### shouldn't we use some kind of insertion here?
      (append-to-history! new-entry)
      (paint-result-window new-entry)
      (refresh-result-window))))

;; #### crufty
(define split-command-line string-tokenize)

;; handle input
(define (run)

  (init-windows!)
  (init-executables-completion-set!)

  (set-process-group (pid) (pid))
  (set-tty-process-group (current-input-port) (pid))
  (set-interrupt-handler interrupt/tstp
			 (lambda a
			   (debug-message "SIGTSTP")))

  '(set-interrupt-handler interrupt/keyboard 
			  (lambda a 
			    (set! active-keyboard-interrupt a)))
      
  ;;Loop
  (paint)
  (let loop ((ch (wait-for-input)) (c-x-pressed? #f)
	     (completion-selector #f))

    (cond

     ;; Ctrl-x -> wait for next input
     ((= ch key-control-x)
      (loop (wait-for-input) #t completion-selector))

     ((and (focus-on-result-buffer?) completion-selector)
      (let ((new-selector (completion-selector ch)))
	(loop (wait-for-input) c-x-pressed? new-selector)))

     ;; tab pressed twice, select completion using select-list
     ((and (focus-on-command-buffer?)
	   completion-selector
	   (= ch key-tab))
      (focus-result-buffer!)
      (loop (wait-for-input) #f completion-selector))

     ;; tab is pressed in the first place, offer completions
     ((and (focus-on-command-buffer?)
	   (= ch key-tab))
      (let ((maybe-selector
	     (offer-completions (last (buffer-text command-buffer)))))
	(loop (wait-for-input) #f maybe-selector)))

     ;; F7 toggle scheme-mode / command-mode (FIXME: find a better key)
     ((= ch key-f7)
      (toggle-command/scheme-mode)
      (loop (wait-for-input) #f #f))

     ((= ch key-f8)
      (show-shell-screen)
      (paint)
      (loop (wait-for-input) #f #f))

     ;; C-x o --- toggle buffer focus
     ((and c-x-pressed? (= ch key-o))
      (toggle-buffer-focus)
      (loop (wait-for-input) #f #f))

     ;; C-x p --- insert selection
     ((and c-x-pressed? 
	   (focus-on-command-buffer?)
	   (current-history-item)
	   (= ch 112))
      (add-string-to-command-buffer
       (send (current-viewer) 'get-selection))
      (loop (wait-for-input) #f #f))

     ((and c-x-pressed? (focus-on-result-buffer?))
      (update-current-viewer!
       (send (current-viewer) 
	     'key-press ch key-control-x))
	(loop (wait-for-input) #f #f))

     ;; C-x r --- redo
     ((and c-x-pressed? (focus-on-command-buffer?)
	   (= ch 114))
      (debug-message "Eric should re-implement redo..."))

     ((= ch key-f1)
      (endwin))
     
     ((= ch key-f2)
      (paint)
      (loop (wait-for-input) c-x-pressed? #f))

     ;; forward in result history
     ((= ch key-npage)
      (history-forward!)
      (when (current-history-item)
	(paint-active-command-window)
	(paint-result-window (entry-data (current-history-item))))
      (refresh-result-window)
      (loop (wait-for-input) c-x-pressed? #f))
     
     ;; back in result history
     ((= ch key-ppage)
      (history-back!)
      (when (current-history-item)
	(paint-active-command-window)
	(paint-result-window (entry-data (current-history-item))))
      (refresh-result-window)
      (loop (wait-for-input) c-x-pressed? #f))

     ((and (focus-on-command-buffer?) (= ch 10))
      (input command-buffer ch)
      (werase (app-window-curses-win command-window))
      (print-command-buffer (app-window-curses-win command-window) 
			    command-buffer)
      (move-cursor command-buffer result-buffer)
      (refresh-command-window)
      (handle-return-key)
      (loop (wait-for-input) c-x-pressed? #f))

     (else 
      (cond
       ((focus-on-result-buffer?)
	(when (current-history-item)
	  (update-current-viewer!
	   (send (current-viewer)
		 'key-press 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 #f))
       (else
	(input command-buffer ch)
	(werase (app-window-curses-win command-window))
	(print-command-buffer (app-window-curses-win command-window) 
			      command-buffer)
	(move-cursor command-buffer result-buffer)
	(refresh-command-window)
	(loop (wait-for-input) c-x-pressed? #f)))))))

(define (window-init-curses-win! window)
  (set-app-window-curses-win!
   window
   (newwin (app-window-height window) (app-window-width window)
	   (app-window-y window) (app-window-x window))))

(define (make-inlying-app-window outer-window)
  (make-app-window (+ (app-window-x outer-window) 1)
		   (+ (app-window-y outer-window) 1)
		   (- (app-window-width outer-window) 2)
		   (- (app-window-height outer-window) 2)
		   #f))

(define (init-windows!)
  (init-screen)
  (set! bar-1
	(make-app-window 1 1 
			 (- (COLS) 2) 2 
			 #f))
  (set! active-command-window
	(make-app-window 1 (+ (round (/ (LINES) 3)) 2)
			 (- (COLS) 2) 3
			 #f))
  (set! command-frame-window
	(make-app-window 1 2
			 (- (COLS) 2) (- (app-window-y active-command-window) 2)
			 #f))
  (set! command-window 
	(make-inlying-app-window command-frame-window))
  (set! result-frame-window
	(make-app-window 1 (+ (app-window-y active-command-window) 3)
			 (- (COLS) 2)
			 (- (- (LINES) 6) (app-window-height command-frame-window))
			 #f))
  (set! result-window
	(make-inlying-app-window result-frame-window))

  (let ((all-windows (list bar-1 active-command-window
			   command-frame-window command-window
			   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
		   " command-window " command-window
		   " result-frame-window " result-frame-window
		   " result-window " result-window)
    (for-each wclear 
	      (map app-window-curses-win all-windows))
    (clear)))

(define (get-path-list)
  (cond
   ((getenv "PATH")
    => (lambda (str)
	 (string-tokenize 
	  str (char-set-difference char-set:full (char-set #\:)))))
   (else
    '("/usr/bin" "/bin" "/usr/sbin" "/sbin"))))

(define (init-executables-completion-set!)
  (spawn
   (lambda ()
     (with-lock executable-completions-lock
       (lambda()
	 (set! executable-completions 
	       (make-completion-set-for-executables (get-path-list)))
	 (debug-message "finished scanning executable-completions-set"))))))

(define (paint-bar-1)
  (mvwaddstr (app-window-curses-win bar-1) 0 1 "SCSH-NUIT")
  (wrefresh (app-window-curses-win bar-1)))

(define (paint-command-buffer-mode-indicator)
  (let ((mode-string 
	 (string-append
	  "[ "
	  (if (command-buffer-in-command-mode?)
	      "Command"
	      "Scheme")
	  " ]")))
    (mvwaddstr 
     (app-window-curses-win command-frame-window)
     0 
     (- (- (app-window-width command-frame-window)
	   (string-length mode-string)) 
	2)
     mode-string)))
  
(define (paint-command-frame-window)
  (box (app-window-curses-win command-frame-window)
       (ascii->char 0) (ascii->char 0))
  (paint-command-buffer-mode-indicator)
  (wrefresh (app-window-curses-win command-frame-window)))

(define (paint-command-window-contents)
  (set-buffer-num-lines! command-buffer
 			 (- (app-window-height command-window) 2))
  (set-buffer-num-cols! command-buffer
 			(- (app-window-width command-window) 3))
  (werase (app-window-curses-win command-window))
  (print-command-buffer (app-window-curses-win command-window)
			command-buffer))

(define (refresh-command-window)
  (wrefresh (app-window-curses-win command-window)))

(define (paint-result-frame-window)
  (let ((win (app-window-curses-win result-frame-window)))
    (wclear win)
    (box win (ascii->char 0) (ascii->char 0))
    (wrefresh win)))

(define (paint-result-window entry)
  (let ((win (app-window-curses-win result-window)))
    (wclear win)
    (send (history-entry-viewer entry)
	  'paint win result-buffer (focus-on-result-buffer?))))

(define (refresh-result-window)
  (wrefresh (app-window-curses-win result-window)))

(define (paint-result/command-buffer history-entry)
  (paint-result-window history-entry)
  (paint-active-command-window)
  (scroll-command-buffer)
  (paint-command-window-contents)
  (move-cursor command-buffer result-buffer)
  (refresh-result-window)
  (refresh-command-window))

(define (paint)
  (paint-bar-1)
  (paint-command-frame-window)
  (paint-command-window-contents)
  (paint-active-command-window)
  (paint-result-frame-window)
  ;(paint-result-window)
  (move-cursor command-buffer result-buffer)
  (refresh-command-window)
  (refresh-result-window))

(define (wait-for-input)
  (noecho)
  (keypad (app-window-curses-win bar-1) #t)
  (set! active-keyboard-interrupt #f)
  (let ((ch (wgetch (app-window-curses-win bar-1))))
    (echo)
    ch))

(define (find/init-plugin-for-result result)
  (cond
   ((determine-plugin-by-type result)
    => (lambda (view-plugin)
	 ((view-plugin-constructor view-plugin)
	   result result-buffer)))
   (else 
    (make-standard-viewer result result-buffer))))

;;scroll buffer after one command was entered
(define (scroll-command-buffer)
  (set-buffer-pos-line! command-buffer 
			(+ (buffer-pos-line command-buffer) 1))
  (set-buffer-pos-col! command-buffer 2))

(define (init-evaluation-environment package)
  (let ((structure (reify-structure package)))
    (load-structure structure)
    (rt-structure->environment structure)))

(define (read-sexp-from-string string)
  (let ((string-port (open-input-string string)))
    (read string-port)))

(define eval-expression
  (let ((env (init-evaluation-environment 'nuit-eval)))
    (lambda (exp)
      (with-fatal-and-capturing-error-handler
       (lambda (condition raw-continuation continuation decline)
         raw-continuation)
       (lambda ()
         (eval (read-sexp-from-string exp) env))))))

(define (determine-plugin-by-type result)
  (find (lambda (r)
	  ((view-plugin-type-predicate r) result))
	(view-plugin-list)))
  
;;Management of the upper buffer
;;add a char to the buffer
(define (add-to-command-buffer ch)
  (let* ((text (buffer-text command-buffer))
	 (last-pos (- (length text) 1))
	 (old-last-el (list-ref text last-pos))
	 (old-rest (sublist text 0 last-pos))
	 (before-ch (substring old-last-el 0 
			       (max 0 (- (buffer-pos-col command-buffer) 2))))
	 (after-ch (substring old-last-el 
			      (max 0 (- (buffer-pos-col command-buffer) 2))
			      (string-length old-last-el)))
	 (new-last-el (string-append  before-ch
				      (string (ascii->char ch))
				      after-ch)))
    (set-buffer-text! command-buffer
		     (append old-rest (list new-last-el)))
    (set-buffer-pos-col! command-buffer
			 (+ (buffer-pos-col command-buffer) 1))))

;;add a string to the buffer
(define (add-string-to-command-buffer string)
  (let loop ((str string))
    (if (string=? str "")
	(values)
	(let ((first-ch (string-ref str 0)))
	  (add-to-command-buffer (char->ascii first-ch))
	  (loop (substring str 1 (string-length str)))))))

;;; FIXME: I guess s48 knows a better way to do this (see ,inspect)
(define (maybe-shorten-string string width)
  (if (> (string-length string) width)
      (string-append (substring string 0 (- width 3))
		     "...")
      string))

(define (paint-active-command-window) 
  (let ((win (app-window-curses-win active-command-window))
	(width (app-window-width active-command-window)))
    (wclear win)
    (box win (ascii->char 0) (ascii->char 0))
    (cond
     ((current-history-item)
      => (lambda (entry)
	   (mvwaddstr win 1 2 
		      (maybe-shorten-string 
		       (history-entry-command (entry-data entry)) width)))))
    (wrefresh win)))

;;Cursor
;;move cursor to the corrct position
(define (move-cursor command-buffer result-buffer)
  (cond
   ((focus-on-command-buffer?)
    (cursor-right-pos 
     (app-window-curses-win command-window)
     command-buffer))
   (else
    (compute-y-x result-buffer)
    (wmove (app-window-curses-win result-window) 
	   (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 result-buffer)
  (let ((pos-result (result-buffer-line result-buffer))
	(pos-result-col (result-buffer-column result-buffer))
	(result-lines (result-buffer-num-lines result-buffer)))
    (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)))
    (reverse (list-tail (reverse tmp) 
			(- (length tmp) k)))))

;;When NUIT is closed the state has to be restored, in order to let the
;;user start again from scratch 
(define (restore-state)
  (set! history '())
  (set! history-pos 0)
  (set! active-keyboard-interrupt #f))

(define (get-param-as-str param-lst)
  (let loop ((lst param-lst)
	     (str ""))
    (if (null? lst)
	str
	(loop (cdr lst)
	      (string-append str " " (car lst))))))

(define (completions->select-list completions num-lines)
  (debug-message "possible completions " completions)
  (make-select-list
   (map (lambda (s) (make-unmarked-element s #f s))
	completions)
   num-lines))

(define (command-contains-path? command)
  (or (string-contains command "/")
      (string-contains command "~")
      (string-contains command "..")))

(define (files-in-dir file-filter dir)
  (with-cwd dir
    (filter-map 
     (lambda (file)
       (and (file-filter file)
	    (absolute-file-name file dir)))
     (directory-files))))

(define (complete-path path)
  (let ((dir (file-name-directory path)))
    (map (lambda (p) 
	   (if (string-prefix? "/" p)
	       p
	       (string-append dir p)))
	 (glob (string-append path "*")))))

(define (complete-with-filesystem-objects filter partial-name)
  (if (and (file-exists? partial-name) (file-directory? partial-name))
      (files-in-dir filter partial-name)
      (complete-path partial-name)))

(define (complete-executables/path partial-name)
  (complete-with-filesystem-objects
   (lambda (file) 
     (or (file-executable? file) (file-directory? file)))
   partial-name))

(define (complete-files/path partial-name)
  (complete-with-filesystem-objects
   (lambda (file) #t) partial-name))

(define (command-mode-completer command prefix args args-pos)
  (debug-message "command-mode-completer" prefix "|" args "|" args-pos)
  (cond
   ((command-contains-path? prefix)
    ;; #### FIXME ignore errors here?
    ((if (zero? args-pos)
	 complete-executables/path 
	 complete-files/path)
     (expand-file-name prefix (cwd))))
   (else
    (append
     (completions-for (command-completions) prefix)
     (with-lock executable-completions-lock
       (lambda ()
	 (completions-for-executables executable-completions prefix)))))))

(define (assemble-line-with-completion command arg arg-pos completion)
  (debug-message "assemble-line-with-completion "
		 command "," arg "," arg-pos "," completion)
  (let ((string-append* (lambda (s t)
			  (if (string=? s "") 
			      t
			      (string-append s " " t)))))
    (let lp ((tokens (cons command arg)) 
	     (arg-count 0)
	     (cursor-pos 0)
	     (line ""))
      (cond
       ((null? tokens)
	(values line (+ 2 cursor-pos)))
       ((= arg-count arg-pos)
	(lp (cdr tokens) 
	    (+ arg-count 1)
	    (+ cursor-pos (string-length completion))
	    (string-append* line completion)))
       (else
	(lp (cdr tokens) 
	    (+ arg-count 1)
	    (+ 1 (+ cursor-pos (string-length (car tokens))))
	    (string-append* line (car tokens))))))))

(define (display-completed-line line cursor-pos)
  (debug-message "display-completed-line " line "," cursor-pos)
  (set-buffer-pos-col! command-buffer cursor-pos)
  (set-buffer-text! command-buffer
		    (append
		     (drop-right (buffer-text command-buffer) 1)
		     (list line)))
  (wclrtoeol (app-window-curses-win command-window))
  (print-command-buffer (app-window-curses-win command-window)
			command-buffer)
  (move-cursor command-buffer result-buffer)
  (refresh-command-window))

(define (paint-completion-select-list select-list command)
  (let ((win (app-window-curses-win result-window)))
    (wclear win)
    (wattron win (A-BOLD))
    (mvwaddstr win 0 0 
	       (string-append "Possible completions for " command))
    (wattrset win (A-NORMAL))
    ((paint-selection-list-at select-list 0 2)
     win result-buffer (focus-on-result-buffer?))
    (refresh-result-window)))

;; #### implement me
(define (completer-function-for-command command)
  #f)

(define (call-completer command args prefix arg-pos)
  (cond
   ((= 0 arg-pos)
    (command-mode-completer command prefix args arg-pos))
   ((completer-function-for-command command)
    => (lambda (completer)
	 (completer command prefix args arg-pos)))
   (else 
    (command-mode-completer command prefix args arg-pos))))

(define (offer-completions command)
  (let* ((tokens/cursor-list (tokenize-command command))
	 (args (map car (cdr tokens/cursor-list)))
	 (command (caar tokens/cursor-list)))
    (call-with-values
	(lambda ()
	  (find-token-with-cursor tokens/cursor-list))
      (lambda (prefix arg-pos)
	;; #### FIXME
	(if (not prefix)
	    (error "could not determine token with cursor position"
		   tokens/cursor-list command 
		   (- (buffer-pos-col command-buffer) 2)))
	(let ((completions 
	       (call-completer command args
			       prefix arg-pos)))
	  (if (= (length completions) 1)
	      (begin
		(call-with-values
		    (lambda ()
		      (assemble-line-with-completion 
		       command args arg-pos (car completions)))
		  display-completed-line)
		#f)
	      (let* ((select-list
		      (completions->select-list 
		       completions 
		       (- (result-buffer-num-lines result-buffer) 3)))
		     (selector
		      (make-completion-selector 
		       select-list completions
		       command args arg-pos)))
		(paint-completion-select-list select-list command)
		(move-cursor command-buffer result-buffer)
		(refresh-command-window)
		selector)))))))

(define (make-completion-selector select-list completions
				  command arg arg-pos)
  (lambda (key)
    (cond
     ((= key 10)
      (focus-command-buffer!) 
      (call-with-values
	  (lambda ()
	    (assemble-line-with-completion
	     command arg arg-pos
	     (select-list-selected-entry select-list)))
	display-completed-line)
      #f)
      ((or (select-list-navigation-key? key)
	   (select-list-marking-key? key))
       (let ((new-select-list
	      (select-list-handle-key-press select-list key)))
	 (paint-completion-select-list
	  new-select-list (last (buffer-text command-buffer)))
	 (make-completion-selector 
	  new-select-list completions command arg arg-pos)))
      (else 
       ;; #### FIXME we loose a character this way
       (focus-command-buffer!)
       #f))))

(define (find-token-with-cursor tokens/cursor-list)
  (debug-message "find-token-with-cursor " tokens/cursor-list)
  (let lp ((lst tokens/cursor-list) (i 0))
    (cond
     ((null? lst)
      (values #f i))
     ((cdar lst)
      (values (caar lst) i))
     (else
      (lp (cdr lst) (+ i 1))))))

(define (command-token-delimiter? c)
  (char-set-contains? char-set:whitespace c))

(define (skip-delimters delimiter? chars)
  (let lp ((chars chars) (i 0))
    (cond
     ((null? chars) (values '() i))
     ((delimiter? (car chars))
      (lp (cdr chars) (+ i 1)))
     (else (values chars i)))))

(define (tokenize-command command)
  (let ((cursor-pos (- (buffer-pos-col command-buffer) 2))) ;; don't ask
    (let lp ((chars (string->list command))
	     (token "")
	     (tokens '())
	     (i 0))
      (cond 
       ((null? chars)
	(reverse (cons (cons token (= i cursor-pos)) tokens)))
       ((command-token-delimiter? (car chars))
	(call-with-values
	    (lambda ()
	      (skip-delimters command-token-delimiter? chars))
	  (lambda (rest skipped)
	    (lp rest "" (cons (cons token (= i cursor-pos)) tokens)
		(+ i skipped)))))
       (else
	(lp (cdr chars) (string-append token (string (car chars)))
	    tokens (+ i 1)))))))