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