elisp/geiser-completion.el

   1 ;;; geiser-completion.el -- tab completion
   2
   3 ;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Mon Feb 09, 2009 22:21
  11
  12 \f
  13
  14 (require 'geiser-impl)
  15 (require 'geiser-eval)
  16 (require 'geiser-log)
  17 (require 'geiser-syntax)
  18 (require 'geiser-base)
  19
  20 \f
  21 ;;; Completions window handling, heavily inspired in slime's:
  22
  23 (defvar geiser-completion--comp-buffer "*Geiser Completions*")
  24
  25 (make-variable-buffer-local
  26  (defvar geiser-completion--window-cfg nil
  27    "Window configuration before we show the *Completions* buffer.
  28 This is buffer local in the buffer where the completion is
  29 performed."))
  30
  31 (make-variable-buffer-local
  32  (defvar geiser-completion--completions-window nil
  33    "The window displaying *Completions* after saving window configuration.
  34 If this window is no longer active or displaying the completions
  35 buffer then we can ignore `geiser-completion--window-cfg'."))
  36
  37 (defun geiser-completion--save-window-cfg ()
  38   "Maybe save the current window configuration.
  39 Return true if the configuration was saved."
  40   (unless (or geiser-completion--window-cfg
  41               (get-buffer-window geiser-completion--comp-buffer))
  42     (setq geiser-completion--window-cfg
  43           (current-window-configuration))
  44     t))
  45
  46 (defun geiser-completion--delay-restoration ()
  47   (add-hook 'pre-command-hook
  48             'geiser-completion--maybe-restore-window-cfg
  49             nil t))
  50
  51 (defun geiser-completion--forget-window-cfg ()
  52   (setq geiser-completion--window-cfg nil)
  53   (setq geiser-completion--completions-window nil))
  54
  55 (defun geiser-completion--restore-window-cfg ()
  56   "Restore the window config if available."
  57   (remove-hook 'pre-command-hook
  58                'geiser-completion--maybe-restore-window-cfg)
  59   (when (and geiser-completion--window-cfg
  60              (geiser-completion--window-active-p))
  61     (save-excursion
  62       (set-window-configuration geiser-completion--window-cfg))
  63     (setq geiser-completion--window-cfg nil)
  64     (when (buffer-live-p geiser-completion--comp-buffer)
  65       (kill-buffer geiser-completion--comp-buffer))))
  66
  67 (defun geiser-completion--maybe-restore-window-cfg ()
  68   "Restore the window configuration, if the following command
  69 terminates a current completion."
  70   (remove-hook 'pre-command-hook
  71                'geiser-completion--maybe-restore-window-cfg)
  72   (condition-case err
  73       (cond ((memq last-command-event '(?( ?) ?\" ?' ?` ?, ?# ? ?\r ?\n ?:))
  74              (geiser-completion--restore-window-cfg))
  75             ((not (geiser-completion--window-active-p))
  76              (geiser-completion--forget-window-cfg))
  77             (t (geiser-completion--delay-restoration)))
  78     (error
  79      ;; Because this is called on the pre-command-hook, we mustn't let
  80      ;; errors propagate.
  81      (message "Error in geiser-completion--restore-window-cfg: %S" err))))
  82
  83 (defun geiser-completion--window-active-p ()
  84   "Is the completion window currently active?"
  85   (and (window-live-p geiser-completion--completions-window)
  86        (equal (buffer-name
  87                (window-buffer geiser-completion--completions-window))
  88               geiser-completion--comp-buffer)))
  89
  90 (defun geiser-completion--display-comp-list (completions base)
  91   (let ((savedp (geiser-completion--save-window-cfg)))
  92     (with-output-to-temp-buffer geiser-completion--comp-buffer
  93       (display-completion-list completions base)
  94       (let ((offset (- (point) 1 (length base))))
  95         (with-current-buffer standard-output
  96           (setq completion-base-position (list offset nil))
  97           (set-syntax-table scheme-mode-syntax-table))))
  98     (when savedp
  99       (setq geiser-completion--completions-window
 100             (get-buffer-window geiser-completion--comp-buffer)))))
 101
 102 (defun geiser-completion--display-or-scroll (completions base)
 103   (if (and (eq last-command this-command)
 104            (geiser-completion--window-active-p))
 105       (geiser-completion--scroll-completions)
 106     (geiser-completion--display-comp-list completions base))
 107   (geiser-completion--delay-restoration))
 108
 109 (defun geiser-completion--scroll-completions ()
 110   (let ((window geiser-completion--completions-window))
 111     (with-current-buffer (window-buffer window)
 112       (if (pos-visible-in-window-p (point-max) window)
 113           (set-window-start window (point-min))
 114         (save-selected-window
 115           (select-window window)
 116           (scroll-up))))))
 117
 118 \f
 119 ;;; Minibuffer maps:
 120
 121 (defvar geiser-completion--minibuffer-map
 122   (let ((map (make-keymap)))
 123     (set-keymap-parent map minibuffer-local-completion-map)
 124     (define-key map "?" 'self-insert-command)
 125     map))
 126
 127 (defvar geiser-completion--module-minibuffer-map
 128   (let ((map (make-keymap)))
 129     (set-keymap-parent map minibuffer-local-completion-map)
 130     (define-key map " " 'self-insert-command)
 131     (define-key map "?" 'self-insert-command)
 132     map))
 133
 134 \f
 135 ;;; Completion functionality:
 136
 137 (defvar geiser-completion--binding-forms nil)
 138 (geiser-impl--register-local-variable
 139  'geiser-completion--binding-forms 'binding-forms nil
 140  "A list of forms introducing local bindings, a la let or lambda.")
 141
 142 (defvar geiser-completion--binding-forms* nil)
 143 (geiser-impl--register-local-variable
 144  'geiser-completion--binding-forms* 'binding-forms* nil
 145  "A list of forms introducing nested local bindings, a la let*.")
 146
 147 (defsubst geiser-completion--locals ()
 148   (mapcar (lambda (s) (and (symbolp s) (symbol-name s)))
 149           (geiser-syntax--locals-around-point
 150            geiser-completion--binding-forms
 151            geiser-completion--binding-forms*)))
 152
 153 (defun geiser-completion--symbol-list (prefix)
 154   (geiser--del-dups
 155    (append (all-completions prefix (geiser-completion--locals))
 156            (geiser-eval--send/result `(:eval (:ge completions ,prefix))))))
 157
 158 (defsubst geiser-completion--module-list (prefix)
 159   (geiser-eval--send/result `(:eval (:ge module-completions ,prefix))))
 160
 161 (defvar geiser-completion--symbol-list-func
 162   (completion-table-dynamic 'geiser-completion--symbol-list))
 163
 164 (defvar geiser-completion--module-list-func
 165   (completion-table-dynamic 'geiser-completion--module-list))
 166
 167 (defun geiser-completion--complete (prefix modules)
 168   (let* ((completions (if modules (geiser-completion--module-list prefix)
 169                         (geiser-completion--symbol-list prefix)))
 170          (partial (try-completion prefix completions))
 171          (partial (if (eq partial t) prefix partial)))
 172     (cons completions partial)))
 173
 174 (defvar geiser-completion--symbol-history nil)
 175
 176 (defun geiser-completion--read-symbol (prompt &optional default history)
 177   (let ((minibuffer-local-completion-map geiser-completion--minibuffer-map))
 178     (completing-read prompt
 179                      geiser-completion--symbol-list-func
 180                      nil nil nil
 181                      (or history geiser-completion--symbol-history)
 182                      (or default (symbol-at-point)))))
 183
 184 (defvar geiser-completion--module-history nil)
 185
 186 (defun geiser-completion--read-module (&optional prompt default history)
 187   (let ((minibuffer-local-completion-map
 188          geiser-completion--module-minibuffer-map))
 189     (completing-read (or prompt "Module name: ")
 190                      geiser-completion--module-list-func
 191                      nil nil nil
 192                      (or history geiser-completion--module-history)
 193                      default)))
 194
 195 (defun geiser--respecting-message (format &rest format-args)
 196   "Display TEXT as a message, without hiding any minibuffer contents."
 197   (let ((text (format " [%s]" (apply #'format format format-args))))
 198     (if (minibuffer-window-active-p (minibuffer-window))
 199         (minibuffer-message text)
 200       (message "%s" text))))
 201
 202 (defvar geiser-completion--symbol-begin-function nil)
 203
 204 (defsubst geiser-completion--def-symbol-begin (module)
 205   (save-excursion (skip-syntax-backward "^-()>") (point)))
 206
 207 (geiser-impl--register-local-method
 208  'geiser-completion--symbol-begin-function 'find-symbol-begin
 209  'geiser-completion--def-symbol-begin
 210  "An optional function finding the position of the beginning of
 211 the identifier around point. Takes a boolean, indicating whether
 212 we're looking for a module name.")
 213
 214 (defsubst geiser-completion--symbol-begin (module)
 215   (funcall geiser-completion--symbol-begin-function module))
 216
 217 (defun geiser-completion--module-at-point ()
 218   (save-excursion
 219     (goto-char (geiser-completion--symbol-begin t))
 220     (ignore-errors (thing-at-point 'sexp))))
 221
 222 (defsubst geiser-completion--prefix (module)
 223   (buffer-substring-no-properties (geiser-completion--symbol-begin module)
 224                                   (point)))
 225
 226 (defun geiser-completion--complete-symbol (&optional arg)
 227   "Complete the symbol at point.
 228 Perform completion similar to Emacs' complete-symbol.
 229 With prefix, complete module name."
 230   (interactive "P")
 231   (unless (geiser-syntax--symbol-at-point)
 232     (error "No symbol at point"))
 233   (geiser--respecting-message "Retrieving completions...")
 234   (let* ((prefix (geiser-completion--prefix arg))
 235          (result (and prefix (geiser-completion--complete prefix arg)))
 236          (completions (car result))
 237          (partial (cdr result)))
 238     (cond ((null completions)
 239            (if (not arg)
 240                (geiser-completion--complete-symbol t)
 241              (geiser--respecting-message "Can't find completion for %S"
 242                                          prefix)
 243              (geiser-completion--restore-window-cfg)))
 244           (t (insert-and-inherit (substring partial (length prefix)))
 245              (cond ((= (length completions) 1)
 246                     (geiser--respecting-message "Sole completion")
 247                     (geiser-completion--restore-window-cfg))
 248                    (t (geiser--respecting-message "Complete but not unique")
 249                       (geiser-completion--display-or-scroll completions
 250                                                             partial)))))))
 251
 252 (defun geiser-completion--complete-module ()
 253   (interactive)
 254   (geiser-completion--complete-symbol t))
 255
 256 \f
 257 ;;; Smart tab mode:
 258
 259 (make-variable-buffer-local
 260  (defvar geiser-smart-tab-mode-string " SmartTab"
 261    "Modeline indicator for geiser-smart-tab-mode"))
 262
 263 (defun geiser-completion--maybe-complete ()
 264   "Indent if at beginning of line or after a white space or
 265 closing parenthesis, try completion otherwise."
 266   (interactive)
 267   (let ((indent (or (bolp) (memq (syntax-class (syntax-after (1- (point))))
 268                                  '(0 5)))))
 269     (if indent (indent-according-to-mode)
 270       (geiser-completion--complete-symbol))))
 271
 272 (define-minor-mode geiser-smart-tab-mode
 273   "Toggle smart tab mode.
 274 With no argument, this command toggles the mode.
 275 Non-null prefix argument turns on the mode.
 276 Null prefix argument turns off the mode.
 277
 278 When this mode is enable, TAB will indent if at point is at
 279 beginning of line or after a white space or closing parenthesis,
 280 and will try completing symbol at point otherwise."
 281   :init-value nil
 282   :lighter geiser-smart-tab-mode-string
 283   :group 'geiser-mode
 284   :keymap `((,(kbd "TAB") . geiser-completion--maybe-complete)))
 285
 286 \f
 287 (provide 'geiser-completion)