misc/fuel/fuel-completion.el

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