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 (require 'minibuffer)
  21
  22 \f
  23 ;;; Minibuffer maps:
  24
  25 (defvar geiser-completion--minibuffer-map
  26   (let ((map (make-keymap)))
  27     (set-keymap-parent map minibuffer-local-completion-map)
  28     (define-key map "?" 'self-insert-command)
  29     map))
  30
  31 (defvar geiser-completion--module-minibuffer-map
  32   (let ((map (make-keymap)))
  33     (set-keymap-parent map minibuffer-local-completion-map)
  34     (define-key map " " 'self-insert-command)
  35     (define-key map "?" 'self-insert-command)
  36     map))
  37
  38 \f
  39 ;;; Completion functionality:
  40
  41 (defvar geiser-completion--binding-forms nil)
  42 (geiser-impl--register-local-variable
  43  'geiser-completion--binding-forms 'binding-forms nil
  44  "A list of forms introducing local bindings, a la let or lambda.")
  45
  46 (defvar geiser-completion--binding-forms* nil)
  47 (geiser-impl--register-local-variable
  48  'geiser-completion--binding-forms* 'binding-forms* nil
  49  "A list of forms introducing nested local bindings, a la let*.")
  50
  51 (defsubst geiser-completion--locals ()
  52   (mapcar (lambda (s) (and (symbolp s) (symbol-name s)))
  53           (geiser-syntax--locals-around-point
  54            geiser-completion--binding-forms
  55            geiser-completion--binding-forms*)))
  56
  57 (defun geiser-completion--symbol-list (prefix)
  58   (geiser--del-dups
  59    (append (all-completions prefix (geiser-completion--locals))
  60            (geiser-eval--send/result `(:eval (:ge completions ,prefix))))))
  61
  62 (defsubst geiser-completion--module-list (prefix)
  63   (geiser-eval--send/result `(:eval (:ge module-completions ,prefix))))
  64
  65 (defvar geiser-completion--symbol-list-func
  66   (completion-table-dynamic 'geiser-completion--symbol-list))
  67
  68 (defvar geiser-completion--module-list-func
  69   (completion-table-dynamic 'geiser-completion--module-list))
  70
  71 (defun geiser-completion--complete (prefix modules)
  72   (if modules (geiser-completion--module-list prefix)
  73     (geiser-completion--symbol-list prefix)))
  74
  75 (defvar geiser-completion--symbol-history nil)
  76
  77 (defun geiser-completion--read-symbol (prompt &optional default history)
  78   (let ((minibuffer-local-completion-map geiser-completion--minibuffer-map))
  79     (make-symbol (completing-read prompt
  80                                   geiser-completion--symbol-list-func
  81                                   nil nil nil
  82                                   (or history
  83                                       geiser-completion--symbol-history)
  84                                   (or default (geiser--symbol-at-point))))))
  85
  86 (defvar geiser-completion--module-history nil)
  87
  88 (defun geiser-completion--read-module (&optional prompt default history)
  89   (let ((minibuffer-local-completion-map
  90          geiser-completion--module-minibuffer-map))
  91     (completing-read (or prompt "Module name: ")
  92                      geiser-completion--module-list-func
  93                      nil nil nil
  94                      (or history geiser-completion--module-history)
  95                      default)))
  96
  97 (defvar geiser-completion--symbol-begin-function nil)
  98
  99 (defun geiser-completion--def-symbol-begin (module)
 100   (save-excursion (skip-syntax-backward "^-()>") (point)))
 101
 102 (geiser-impl--register-local-method
 103  'geiser-completion--symbol-begin-function 'find-symbol-begin
 104  'geiser-completion--def-symbol-begin
 105  "An optional function finding the position of the beginning of
 106 the identifier around point. Takes a boolean, indicating whether
 107 we're looking for a module name.")
 108
 109 (defun geiser-completion--symbol-begin (module)
 110   (funcall geiser-completion--symbol-begin-function module))
 111
 112 (defun geiser-completion--module-at-point ()
 113   (save-excursion
 114     (goto-char (geiser-completion--symbol-begin t))
 115     (ignore-errors (thing-at-point 'sexp))))
 116
 117 (defsubst geiser-completion--prefix (module)
 118   (buffer-substring-no-properties (geiser-completion--symbol-begin module)
 119                                   (point)))
 120
 121 (defsubst geiser-completion--prefix-end (beg)
 122   (unless (or (eq beg (point-max))
 123               (member (char-syntax (char-after beg)) '(?\" ?\( ?\))))
 124     (let ((pos (point)))
 125       (condition-case nil
 126           (save-excursion
 127             (goto-char beg)
 128             (forward-sexp 1)
 129             (when (>= (point) pos)
 130               (point)))
 131         (scan-error pos)))))
 132
 133 (defun geiser-completion--thing-at-point (module &optional predicate)
 134   (with-syntax-table scheme-mode-syntax-table
 135     (let* ((beg (geiser-completion--symbol-begin module))
 136            (end (or (geiser-completion--prefix-end beg) beg))
 137            (prefix (and (> end beg) (buffer-substring-no-properties beg end)))
 138            (prefix (and prefix
 139                         (if (string-match "\\([^-]+\\)-" prefix)
 140                             (match-string 1 prefix)
 141                           prefix)))
 142            (cmps (and prefix (geiser-completion--complete prefix module))))
 143       (and cmps (list beg end cmps)))))
 144
 145 (defun geiser-completion--for-symbol (&optional predicate)
 146   (geiser-completion--thing-at-point nil predicate))
 147
 148 (defun geiser-completion--for-module (&optional predicate)
 149   (geiser-completion--thing-at-point t predicate))
 150
 151 (defun geiser-completion--setup (enable)
 152   (set (make-local-variable 'completion-at-point-functions)
 153        (if enable
 154            '(geiser-completion--for-symbol geiser-completion--for-module)
 155          (default-value 'completion-at-point-functions))))
 156
 157 (defun geiser-completion--complete-module ()
 158   "Complete module name at point."
 159   (interactive)
 160   (let ((completion-at-point-functions '(geiser-completion--for-module)))
 161     (call-interactively 'completion-at-point)))
 162
 163 \f
 164 ;;; Smart tab mode:
 165
 166 (make-variable-buffer-local
 167  (defvar geiser-smart-tab-mode-string " SmartTab"
 168    "Modeline indicator for geiser-smart-tab-mode"))
 169
 170 (define-minor-mode geiser-smart-tab-mode
 171   "Toggle smart tab mode.
 172 With no argument, this command toggles the mode.
 173 Non-null prefix argument turns on the mode.
 174 Null prefix argument turns off the mode.
 175
 176 When this mode is enable, TAB will indent if at point is at
 177 beginning of line or after a white space or closing parenthesis,
 178 and will try completing symbol at point otherwise."
 179   :init-value nil
 180   :lighter geiser-smart-tab-mode-string
 181   :group 'geiser-mode
 182   (set (make-local-variable 'tab-always-indent)
 183        (if geiser-smart-tab-mode
 184            'complete
 185          (default-value 'tab-always-indent))))
 186
 187 \f
 188 (provide 'geiser-completion)