elisp/geiser-completion.el

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