commander-s/scheme/nuit-engine.scm

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

(define-syntax with-lock
  (syntax-rules ()
    ((_ lock exp ...)
     (begin
       (obtain-lock lock)
       (let ((val (begin exp ...)))
	 (release-lock lock)
	 val)))))

;; configurable options

(define-option 'main 'switch-command-buffer-mode-key key-f7)
(define-option 'main 'help-key (char->ascii #\?))
(define-option 'main 'quit-help-key (char->ascii #\q))
(define-option 'main 'show-shell-key key-end)

;; mode of the command buffer
(define-option 'main 'initial-command-mode 'command)

(define *command-buffer-mode*)

(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))

(define key-control-x 24)
(define key-o 111)
(define key-tab 9)

;; 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)
	 (if (not (eq? (history-entry-viewer (entry-data entry))
		       new-viewer))
	     (append-to-history!
	      (make-history-entry #f '() 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!)))
    (if tty-name
	(begin
	  (display "Debug messages will be on ")
	  (display tty-name)
	  (newline)
          (display "Please (re-)open this device for reading now and then press RET to continue")
          (newline)
          (read-char)
          )))
  (set! nuit-engine-thread (current-thread))
  (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!)
    (refresh-command-window))))

(define (current-command-line)
  (let ((entered (buffer-text (command-buffer))))
    (if (string=? entered "")
	#f
	entered)))

(define (replace-current-command-line! text)
  (set-buffer-text! (command-buffer) text))

(define (toggle-command/scheme-mode)
  (cond 
   ((command-buffer-in-command-mode?)
    (enter-scheme-mode!)
    (change-command-buffer-prompt!
     (command-buffer)
     (lambda ()
       (string-append
        (symbol->string (evaluation-environment-name))
        "> "))))
   ((command-buffer-in-scheme-mode?)
    (enter-command-mode!)
    (change-command-buffer-prompt! (command-buffer) (lambda ()
						      (string-append (cwd)
								     "> ")))))
  (paint-command-frame-window)
  (paint-command-window-contents)
  (refresh-command-window))

;; assumes we are in command mode
(define (toggle-command/scheme-mode-with-conversion)
  (cond
   ((current-command-line)
    => (lambda (cmdln)
	 (cond
	  ((lex/parse-partial-command-line cmdln #f)
	   => (lambda (parsed)
		(let ((scheme-str
		      (write-to-string
		       (compile-command-line parsed))))
		  (replace-current-command-line! scheme-str)
		  (enter-scheme-mode!)
		  (paint-command-frame-window)
		  (paint-command-window-contents)
		  (refresh-command-window))))
	  (else (values)))))
   (else (values))))

(define (balanced? str)
  (let ((len (string-length str)))
    (let lp ((i 0) 
	     (open 0)
	     (in-comment? #f)
	     (in-string? #f)
	     (next-is-escaped? #f))
      (if (= i len)
          (= open 0)
          (let ((ch (string-ref str i)))
	    (cond ((char=? ch #\newline) (lp (+ i 1)
					     open
					     #f
					     in-string?
					     #f))
		  (in-comment? (lp (+ i 1)
				   open
				   in-comment?
				   in-string?
				   #f))
		  (next-is-escaped? (lp (+ i 1)
					open
					in-comment?
					in-string?
					#f))
		  (in-string? (case ch
				((#\") (lp (+ i 1)
					   open
					   in-comment?
					   #f
					   #f))
				((#\\) (lp (+ i 1)
					   open
					   in-comment?
					   in-string?
					   #t))
				(else (lp (+ i 1)
					  open
					  in-comment?
					  in-string?
					  #f))))
		  (else 
		   (case ch
		     ((#\") (lp (+ i 1)
				open
				#f
				#t
				#f))
		     ((#\;) (lp (+ i 1)
				open
				#t
				#f
				#f))
		     ((#\\) (lp (+ i 1)
				open
				#f
				#f
				#t))
		     ((#\() (lp (+ i 1)
				(+ open 1)
				in-comment?
				in-string?
				next-is-escaped?))
		     ((#\)) (if (= open 0)
				#f ;; actually a syntax error
				(lp (+ i 1)
				    (- open 1)
				    in-comment?
				    in-string?
				    next-is-escaped?)))
		     ;; TODO: handle strings and chars
		     (else (lp (+ i 1)
			       open
			       in-comment?
			       in-string?
			       next-is-escaped?))))))))))


(define (handle-return-key)
  (let ((command-line (buffer-text (command-buffer))))
    (debug-message "command-line " command-line)
    (cond
     ((string=? command-line "")
      (input (command-buffer) 'input-end)
      (values))
     ((command-buffer-in-scheme-mode?)
      (if (balanced? command-line)
          (begin
	    (eval-command-in-scheme-mode command-line)
	    (input (command-buffer) 'input-end))
	  (input (command-buffer) 10)))
     ((command-buffer-in-command-mode?)
      (eval-command-in-command-mode command-line)
      (input (command-buffer) 'input-end))
     (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)
  (with-fatal-error-handler*
   display-error-and-continue
   (lambda ()
     (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-inspector-handler
               (lambda ()
                 ((command-plugin-evaluater command-plugin)
                  command args)))))
	    (new-entry
	     (make-history-entry command args viewer)))
       ;; FIXME, use insert here
       (append-to-history! new-entry)
       (signal-result-buffer-object-change)
       (obtain-lock paint-lock)
       (paint)
       (paint-result-window (entry-data (current-history-item)))
       (refresh-result-window)
       (release-lock paint-lock)))))

(define (display-error-and-continue condition more)
  (let ((win (app-window-curses-win (result-window))))
    (wclear win)
    (wattron win (A-BOLD))
    (mvwaddstr win 0 0
	       (string-append "I'm sorry " (user-login-name) ", "
			      "I'm afraid I can't do that. "
			      "The following error occured:"))
    (wattrset win (A-NORMAL))
    (let ((string-port (open-output-string)))
      (display condition string-port)
      (display " " string-port)
      (display more)
      (mvwaddstr win 5 0 (get-output-string string-port)))
    (refresh-result-window)))

(define (process-scheme-command command-line)
  (receive (command args) (split-scheme-command-line command-line)
    (let* ((viewer
            (find/init-plugin-for-result
             (with-inspector-handler
              (lambda ()
                (eval-scheme-command command args)))))
           (new-entry
            (make-history-entry command args viewer)))
      (append-to-history! new-entry)
      (signal-result-buffer-object-change)
      (obtain-lock paint-lock)
      (paint-active-command-window)
      (paint-result-window new-entry)
      (refresh-result-window)
      (refresh-command-window)
      (release-lock paint-lock))))

(define (eval-command-in-scheme-mode command-line)
  (if (scheme-command-line? command-line)
      (process-scheme-command command-line)
      (let* ((viewer
              (find/init-plugin-for-result
               (with-inspector-handler
                (lambda ()
                  (eval-string command-line)))))
             (new-entry
              (make-history-entry command-line '() viewer)))
        ;; #### shouldn't we use some kind of insertion here?
        (append-to-history! new-entry)
        (signal-result-buffer-object-change)
        (obtain-lock paint-lock)
        (paint-active-command-window)
        (paint-result-window new-entry)
        (refresh-result-window)
        (refresh-command-window)
        (release-lock paint-lock))))

;; #### crufty, and a very dumb idea
(define split-command-line string-tokenize)

(define (paste-selection/refresh viewer)
  (add-string-to-command-buffer
   (send (current-viewer) 
	 'get-selection-as-text
	 (command-buffer-in-scheme-mode?) (focus-table)))
  (print-command-buffer (command-buffer))
  (refresh-command-window)
  (refresh-result-window))

(define (paste-focus-object/refresh viewer)
  (add-string-to-command-buffer
   (if (command-buffer-in-command-mode?)
       (send (current-viewer) 
	     'get-selection-as-text
	     (command-buffer-in-scheme-mode?)
	     (focus-table))
       (send (current-viewer) 'get-selection-as-ref (focus-table))))
  (print-command-buffer (command-buffer))
  (refresh-command-window)
  (refresh-result-window))

;; #### implement me
(define terminal-input-handler
  (lambda ignore
    'terminal-input))

;; #### implement me
(define terminal-output-handler
  (lambda ignore
    'terminal-output))

(define nuit-engine-thread #f)
(define keyboard-handler
  (lambda ignore
    (if (command-buffer-in-command-mode?)
        23
        (schedule-event
         nuit-engine-thread
         (enum  
          event-type
          interrupt)
         (enum interrupt keyboard)))))
    

(define (install-signal-handlers)
;  (for-each 
;   (lambda (signal)
;     (set-interrupt-handler signal #f))
;   (list interrupt/int 
;	 ;interrupt/quit 
;	 interrupt/tstp))
  ;(set-interrupt-handler signal/ttin terminal-input-handler)
  ;(set-interrupt-handler signal/ttou terminal-output-handler)
  (set-interrupt-handler interrupt/keyboard keyboard-handler))

(define (enable-tty-output-control! port)
  (let ((info (copy-tty-info (tty-info port))))
    (set-tty-info:local-flags
     info
     (bitwise-ior (tty-info:local-flags info)
		  ttyl/ttou-signal))
    (set-tty-info/now port info)))

(define (process-group-leader?)
  (= (process-group) (pid)))

;; config needs this to be initialized
(init-evaluation-environment! 'nuit-eval)

;; there are top-level expressions accessing the configuration...
(read-config-file!)

;; handle input
(define (run)
  (ignore-signal signal/ttou)
  (install-signal-handlers)
  (save-initial-tty-info! (current-input-port))
  (init-screen)
  (init-windows!)
  (noecho)
  (keypad (app-window-curses-win (bar-1)) #t)

  (set! *command-buffer-mode* (config 'main 'initial-command-mode))
  
  (clear)
  (if (not (process-group-leader?))
      (become-session-leader))

  (set-tty-process-group (current-input-port) (pid))

  (init-executables-completion-set!)
  (enable-tty-output-control! (current-output-port))

  ;; init joblist
  (let ((statistics-channel (spawn-joblist-surveillant)))
    (spawn
     (lambda ()
       (let lp ((stats (cml-receive statistics-channel)))
	 (debug-message "statistics update " stats)
	 (obtain-lock paint-lock)
	 (paint-command-frame-window)
	 (paint-job-status-list stats)
	 (paint-command-window-contents)
	 (wrefresh (app-window-curses-win (command-frame-window)))
	 (refresh-command-window)
	 (release-lock paint-lock)
	 (lp (cml-receive statistics-channel))))))
  (paint)
  (dispatch-input))


(define (dispatch-input)
  (let loop ((ch (wait-for-input))
             (i 0))
;     (if (= 0 (remainder i 4))
;         (repaint-command-winow!))
    (cond
     (maybe-modal-window
      (if (maybe-modal-window ch)
          (begin 
            (close-modal-window!)
            (paint)
            (when (current-history-item)
              (paint-result-window 
               (entry-data (current-history-item)))
              (refresh-result-window)
              (if focus-on-command-buffer?
                  (refresh-command-window)))))
      (loop (wait-for-input) (+ i 1)))
     (else
      ((vector-ref *key-map* ch) ch)
      (loop (wait-for-input) (+ i 1))))))

(define (result-buffer-handle-key ch)
  (when (current-history-item)
      (update-current-viewer!
       (send (current-viewer)
             'key-press ch #f))
      (obtain-lock paint-lock)

	  ;;; only necessary when continueing a background job in fg
      (if (redisplay-everything?)
          (begin
            (paint-result-frame-window)
            (paint-active-command-window)
            (unset-redisplay-everything)))

      (paint-result-window (entry-data (current-history-item)))
      (refresh-result-window)
      (release-lock paint-lock)))

(define (default-key-handler ch)
  (cond
   ((focus-on-result-buffer?)
    (result-buffer-handle-key ch))
   (else
    (input (command-buffer) ch)
    (repaint-command-winow!))))

(define (repaint-command-winow!)
  (obtain-lock paint-lock)
  (werase (app-window-curses-win (command-window)))
  (print-command-buffer (command-buffer))
  (refresh-command-window)
  (release-lock paint-lock))

(define *key-map* (make-vector 777 default-key-handler))

(define (define-key! key handler)
  (vector-set! *key-map* key handler))


(define-key! (config 'main 'show-shell-key)
          (lambda (ch) (show-shell-screen) (paint)))

(define-key! key-f2 (lambda (ch) (paint)))

(define-key! key-npage
  (lambda (ch)
    (history-forward!)
    (obtain-lock paint-lock)
    (when (current-history-item)
      (signal-result-buffer-object-change)
      (paint-active-command-window)
      (paint-result-window (entry-data (current-history-item))))
    (refresh-result-window)
    (release-lock paint-lock)))

(define-key! key-ppage
  (lambda (ch)
    ;; back in result history
    (history-back!)
    (obtain-lock paint-lock)
    (when (current-history-item)
      (signal-result-buffer-object-change)
      (paint-active-command-window)
      (paint-result-window (entry-data (current-history-item))))
    (refresh-result-window)
    (release-lock paint-lock)))

(define (dispatch-ctrl-x ch)
  (let ((ch (wait-for-input)))
    (cond	
     ;; C-x o --- toggle buffer focus
     ((= ch key-o)
      (toggle-buffer-focus))
           
     ;; C-x p --- insert selection
     ((and (current-history-item)
           (= ch 112))
      (paste-selection/refresh (current-viewer)))

     ;; C-x P --- insert focus object(s)
     ((and (current-history-item)
           (= ch 80))
      (paste-focus-object/refresh (current-viewer)))
     
     ((and (focus-on-command-buffer?)
	   (command-buffer-in-command-mode?)
	   (= ch (config 'main 'switch-command-buffer-mode-key)))
      (toggle-command/scheme-mode-with-conversion))

     ((focus-on-result-buffer?)
      (update-current-viewer!
       (send (current-viewer) 
             'key-press ch key-control-x)))

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

(define-key! key-control-x dispatch-ctrl-x)

(define-key! (config 'main 'switch-command-buffer-mode-key)
  (lambda (ch)
    (debug-message "switching command mode")
    (toggle-command/scheme-mode)))

(define-key! 10
  (lambda (ch)
    (if (focus-on-command-buffer?)
        (begin
          (handle-return-key)
          (repaint-command-winow!)))))

(define-key! key-tab
  (lambda (ch)
    (if (and (focus-on-command-buffer?)
             (command-buffer-in-command-mode?))
        (offer-completions (buffer-text (command-buffer))))))

(define (paint-bar-1)
  (mvwaddstr (app-window-curses-win (bar-1)) 0 1 "Commander S")
  (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)
  (paint-job-status-list)
  (wrefresh (app-window-curses-win (command-frame-window))))

(define paint-job-status-list
  (let ((latest-statistics (initial-job-statistics)))
    (lambda args
      (let-optionals args
	  ((statistics latest-statistics))
	(let* ((stat-item (lambda (text number)
			    (string-append text (number->string number))))
	       (stat
		(string-join
		 (map 
		  (lambda (status.count)
		    (case (car status.count)
		      ((running) (stat-item "run:" (cdr status.count)))
		      ((ready) (stat-item "ready:" (cdr status.count)))
		      ((stopped) (stat-item "stop:" (cdr status.count)))
		      ((new-output) (stat-item "out:" (cdr status.count)))
		      ((waiting-for-input) (stat-item "in:" (cdr status.count)))))
		  statistics)))
	       (line (string-append "[ " stat " ]")))
	  (set! latest-statistics statistics)
	  (mvwaddstr
	   (app-window-curses-win (command-frame-window))
	   (- (app-window-height (command-frame-window)) 1)
	   (- (- (app-window-width (command-frame-window))
		 (string-length line))
	      2)
	   line))))))

(define (paint-command-window-contents)
  (print-command-buffer (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))))
    (werase win)
    (box win (ascii->char 0) (ascii->char 0))
    (wrefresh win)))

(define (paint-result-window entry)
  (let ((win (app-window-curses-win (result-window))))
    (werase 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)
  (paint-command-window-contents)
  (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)
  (if (focus-on-command-buffer?)
      (begin (refresh-result-window)
	     (refresh-command-window))
      (begin (refresh-command-window)
	     (refresh-result-window))))

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

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


(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)
  (input (command-buffer) ch))

;;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 6)) ;;was too long (was 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 
		       (if (history-entry-command (entry-data entry))
			   (replace-in-string 
			    (history-entry-command (entry-data entry)) 
			    #\newline #\space)
			   "user interaction")
		       width)))))
     (wrefresh win)))

;;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-text-element s #f s))
	completions)
   num-lines))

(define (display-completed-line line)
  (debug-message "display-completed-line " line)
  (set-buffer-text! (command-buffer) line)
  (wclrtoeol (app-window-curses-win (command-window)))
  (print-command-buffer (command-buffer))
  (refresh-command-window))

(define (current-cursor-index)
  ;; #### No, I will not comment on this.
  (buffer-pos-col (command-buffer))) ;; - 2

(define (offer-completions command)
  (debug-message "offer-completions '" command "' " (current-cursor-index))
  (let ((completion-info (complete command (current-cursor-index))))
    (if (not completion-info)
	(begin
	  ;; #### the completion mechanism was too confused to do anything
	  ;; #### beep or so
	  #f)
	(destructure 
         (((maybe-completed-line completions cursor-index to-complete cmdln) completion-info))

         (if maybe-completed-line 
             ;; #### don't ask about the 2...
             (display-completed-line maybe-completed-line))

         (cond
          ((null? completions)
           #f)
          ((list? completions)
           (set-modal-window! 
            (make-completions-window command completions cmdln to-complete)))
          (else
           (error "COMPLETE returned an unexpected value" 
                  completions)))))))

(define (make-completions-window command completions 
                                 cmdln to-complete)
  (define header-line "Select completion")
  (define header-length (string-length header-line))

  (let* ((lines (+ 2 (min (- (LINES) 5)
                          (length completions))))
         (inner-width
          (min (apply max header-length
                      (map string-length completions))
               (COLS)))
         (dialog (make-app-window (- (quotient (COLS) 2)
                                     (quotient inner-width 2))
                                  5
                                  (+ 4 inner-width)
                                  lines)))
    (app-window-init-curses-win! dialog)
    (let* ((dialog-win (app-window-curses-win dialog))
           (select-list
            (completions->select-list 
             completions 
             (- lines 3))))
      
      (define (paint)
        (werase dialog-win)
        (box dialog-win
             (ascii->char 0) (ascii->char 0))
        (mvwaddstr dialog-win 
                   0
                   (+ 1 (quotient (- inner-width header-length) 2))
                   header-line)
        (paint-selection-list-at select-list 1 1
                                 dialog-win inner-width #t)
        (wrefresh dialog-win))
      (paint)
      (lambda (key)
        (cond
         ((= key 27)
          (delete-app-window! dialog)
          (close-modal-window!)
          #t)
         ((= key 10)
          (let ((completion
                 (select-list-selected-entry select-list)))
            ;; #### No, I will not comment on this.
            (call-with-values
                (lambda ()
                  (unparse-command-line cmdln
                                        (lambda (to-complete)
                                          (display completion))))
              (lambda (completed-line new-cursor-pos)
                (display-completed-line completed-line)))
            (delete-app-window! dialog)
            #t))
         ((select-list-key? key)
          (set! select-list
                (select-list-handle-key-press select-list key))
          (paint)
          #f)
         (else
          #f))))))