misc/fuel/fuel-completion.el

   1 ;;; fuel-completion.el -- completion utilities
   2
   3 ;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
   4 ;; See http://factorcode.org/license.txt for BSD license.
   5
   6 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
   7 ;; Keywords: languages, fuel, factor
   8 ;; Start date: Sun Dec 14, 2008 21:17
   9
  10 ;;; Comentary:
  11
  12 ;; Code completion utilities.
  13
  14 ;;; Code:
  15
  16 (require 'fuel-base)
  17 (require 'fuel-eval)
  18 (require 'fuel-log)
  19 (require 'factor-mode)
  20
  21 \f
  22 ;;; Aux:
  23
  24 (defvar fuel-completion--minibuffer-map
  25   (let ((map (make-keymap)))
  26     (set-keymap-parent map minibuffer-local-completion-map)
  27     (define-key map "?" 'self-insert-command)
  28     map))
  29
  30 \f
  31 ;;; Vocabs dictionary:
  32
  33 (defvar fuel-completion--vocabs nil)
  34
  35 (defun fuel-completion--vocabs (&optional reload)
  36   (when (or reload (not fuel-completion--vocabs))
  37     (fuel-respecting-message "Retrieving vocabs list")
  38     (let ((fuel-log--inhibit-p t))
  39       (setq fuel-completion--vocabs
  40             (fuel-eval--retort-result
  41              (fuel-eval--send/wait '(:fuel* (fuel-get-vocabs) "fuel" (:array)))))))
  42   fuel-completion--vocabs)
  43
  44 (defvar fuel-completion--vocab-history nil)
  45
  46 (defun fuel-completion--read-vocab (&optional reload init-input history)
  47   (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map)
  48         (vocabs (fuel-completion--vocabs reload)))
  49     (completing-read "Vocab name: " vocabs nil nil
  50                      init-input (or history fuel-completion--vocab-history))))
  51
  52 (defsubst fuel-completion--vocab-list (prefix)
  53   (fuel-eval--retort-result
  54    (fuel-eval--send/wait `(:fuel* (,prefix fuel-get-vocabs/prefix) t t))))
  55
  56 (defun fuel-completion--words (prefix vocabs)
  57   (let ((vs (if vocabs (cons :array vocabs) 'f))
  58         (us (or vocabs 't)))
  59     (fuel-eval--retort-result
  60      (fuel-eval--send/wait `(:fuel* (,prefix ,vs fuel-get-words) t ,us)))))
  61
  62 \f
  63 ;;; Completions window handling, heavily inspired in slime's:
  64
  65 (defvar fuel-completion--comp-buffer "*Completions*")
  66
  67 (defvar-local fuel-completion--window-cfg nil
  68    "Window configuration before we show the *Completions* buffer.
  69 This is buffer local in the buffer where the completion is
  70 performed.")
  71
  72 (defvar-local fuel-completion--completions-window nil
  73    "The window displaying *Completions* after saving window configuration.
  74 If this window is no longer active or displaying the completions
  75 buffer then we can ignore `fuel-completion--window-cfg'.")
  76
  77 (defun fuel-completion--save-window-cfg ()
  78   "Maybe save the current window configuration.
  79 Return true if the configuration was saved."
  80   (unless (or fuel-completion--window-cfg
  81               (get-buffer-window fuel-completion--comp-buffer))
  82     (setq fuel-completion--window-cfg
  83           (current-window-configuration))
  84     t))
  85
  86 (defun fuel-completion--delay-restoration ()
  87   (add-hook 'pre-command-hook
  88             'fuel-completion--maybe-restore-window-cfg
  89             nil t))
  90
  91 (defun fuel-completion--forget-window-cfg ()
  92   (setq fuel-completion--window-cfg nil)
  93   (setq fuel-completion--completions-window nil))
  94
  95 (defun fuel-completion--restore-window-cfg ()
  96   "Restore the window config if available."
  97   (remove-hook 'pre-command-hook
  98                'fuel-completion--maybe-restore-window-cfg)
  99   (when (and fuel-completion--window-cfg
 100              (fuel-completion--window-active-p))
 101     (save-excursion
 102       (set-window-configuration fuel-completion--window-cfg))
 103     (setq fuel-completion--window-cfg nil)
 104     (when (buffer-live-p fuel-completion--comp-buffer)
 105       (kill-buffer fuel-completion--comp-buffer))))
 106
 107 (defun fuel-completion--maybe-restore-window-cfg ()
 108   "Restore the window configuration, if the following command
 109 terminates a current completion."
 110   (remove-hook 'pre-command-hook
 111                'fuel-completion--maybe-restore-window-cfg)
 112   (condition-case err
 113       (cond ((cl-find last-command-event "()\"'`,# \r\n:")
 114              (fuel-completion--restore-window-cfg))
 115             ((not (fuel-completion--window-active-p))
 116              (fuel-completion--forget-window-cfg))
 117             (t (fuel-completion--delay-restoration)))
 118     (error
 119      ;; Because this is called on the pre-command-hook, we mustn't let
 120      ;; errors propagate.
 121      (message "Error in fuel-completion--restore-window-cfg: %S" err))))
 122
 123 (defun fuel-completion--window-active-p ()
 124   "Is the completion window currently active?"
 125   (and (window-live-p fuel-completion--completions-window)
 126        (equal (buffer-name (window-buffer fuel-completion--completions-window))
 127               fuel-completion--comp-buffer)))
 128
 129 (defun fuel-completion--display-comp-list (completions base)
 130   (let ((savedp (fuel-completion--save-window-cfg)))
 131     (with-output-to-temp-buffer fuel-completion--comp-buffer
 132       (display-completion-list completions base)
 133       (let ((offset (- (point) 1 (length base))))
 134         (with-current-buffer standard-output
 135           (setq completion-base-position offset)
 136           (set-syntax-table factor-mode-syntax-table))))
 137     (when savedp
 138       (setq fuel-completion--completions-window
 139             (get-buffer-window fuel-completion--comp-buffer)))))
 140
 141 (defun fuel-completion--display-or-scroll (completions base)
 142   (cond ((and (eq last-command this-command) (fuel-completion--window-active-p))
 143          (fuel-completion--scroll-completions))
 144         (t (fuel-completion--display-comp-list completions base)))
 145   (fuel-completion--delay-restoration))
 146
 147 (defun fuel-completion--scroll-completions ()
 148   (let ((window fuel-completion--completions-window))
 149     (with-current-buffer (window-buffer window)
 150       (if (pos-visible-in-window-p (point-max) window)
 151           (set-window-start window (point-min))
 152         (save-selected-window
 153           (select-window window)
 154           (scroll-up))))))
 155
 156 \f
 157 ;;; Completion functionality:
 158
 159 (defun fuel-completion--word-list (prefix)
 160   (let* ((fuel-log--inhibit-p t)
 161          (cv (factor-current-vocab))
 162          (vs (and cv `("syntax" ,cv ,@(factor-usings)))))
 163     (fuel-completion--words prefix vs)))
 164
 165 (defsubst fuel-completion--all-words-list (prefix)
 166   (fuel-completion--words prefix nil))
 167
 168 (defvar fuel-completion--word-list-func
 169   (completion-table-dynamic 'fuel-completion--word-list))
 170
 171 (defvar fuel-completion--all-words-list-func
 172   (completion-table-dynamic 'fuel-completion--all-words-list))
 173
 174 (defun fuel-completion--complete (prefix vocabs)
 175   (let* ((words (if vocabs
 176                     (fuel-completion--vocabs)
 177                     (fuel-completion--word-list prefix)))
 178          (completions (all-completions prefix words))
 179          (partial (try-completion prefix words))
 180          (partial (if (eq partial t) prefix partial)))
 181     (cons completions partial)))
 182
 183 (defun fuel-completion--read-word (prompt &optional default history all)
 184   (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map))
 185     (completing-read prompt
 186                      (if all fuel-completion--all-words-list-func
 187                        fuel-completion--word-list-func)
 188                      nil nil nil
 189                      history
 190                      (or default (factor-symbol-at-point)))))
 191
 192 (defun fuel-completion--complete-symbol ()
 193   "Complete the symbol at point.
 194 Perform completion similar to Emacs' complete-symbol."
 195   (interactive)
 196   (let* ((end (point))
 197          (beg (save-excursion (factor-beginning-of-symbol) (point)))
 198          (prefix (buffer-substring-no-properties beg end))
 199          (result (fuel-completion--complete prefix (factor-in-using)))
 200          (completions (car result))
 201          (partial (cdr result)))
 202     (cond ((null completions)
 203            (fuel-respecting-message "Can't find completion for %S" prefix)
 204            (fuel-completion--restore-window-cfg))
 205           (t (insert-and-inherit (substring partial (length prefix)))
 206              (cond ((= (length completions) 1)
 207                     (fuel-respecting-message "Sole completion")
 208                     (fuel-completion--restore-window-cfg))
 209                    (t (fuel-respecting-message "Complete but not unique")
 210                       (fuel-completion--display-or-scroll completions
 211                                                           partial)))))))
 212
 213 \f
 214 (provide 'fuel-completion)
 215 ;;; fuel-completion.el ends here