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   (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)
 120   (unless (or (eq beg (point-max))
 121               (member (char-syntax (char-after beg)) '(?\" ?\( ?\))))
 122     (let ((pos (point)))
 123       (condition-case nil
 124           (save-excursion
 125             (goto-char beg)
 126             (forward-sexp 1)
 127             (when (>= (point) pos)
 128               (point)))
 129         (scan-error pos)))))
 130
 131 (defun geiser-completion--thing-at-point (module &optional predicate)
 132   (with-syntax-table scheme-mode-syntax-table
 133     (let* ((beg (geiser-completion--symbol-begin module))
 134            (end (or (geiser-completion--prefix-end beg) beg))
 135            (prefix (and (> end beg) (buffer-substring-no-properties beg end)))
 136            (prefix (and prefix
 137                         (if (string-match "\\([^-]+\\)-" prefix)
 138                             (match-string 1 prefix)
 139                           prefix)))
 140            (cmps (and prefix (geiser-completion--complete prefix module))))
 141       (and cmps (list beg end cmps)))))
 142
 143 (defun geiser-completion--for-symbol (&optional predicate)
 144   (geiser-completion--thing-at-point nil predicate))
 145
 146 (defun geiser-completion--for-module (&optional predicate)
 147   (geiser-completion--thing-at-point t predicate))
 148
 149 (defun geiser-completion--setup (enable)
 150   (set (make-local-variable 'completion-at-point-functions)
 151        (if enable
 152            '(geiser-completion--for-symbol geiser-completion--for-module)
 153          (default-value 'completion-at-point-functions))))
 154
 155 (defun geiser-completion--complete-module ()
 156   "Complete module name at point."
 157   (interactive)
 158   (let ((completion-at-point-functions '(geiser-completion--for-module)))
 159     (call-interactively 'completion-at-point)))
 160
 161 \f
 162 ;;; Smart tab mode:
 163
 164 (make-variable-buffer-local
 165  (defvar geiser-smart-tab-mode-string " SmartTab"
 166    "Modeline indicator for geiser-smart-tab-mode"))
 167
 168 (define-minor-mode geiser-smart-tab-mode
 169   "Toggle smart tab mode.
 170 With no argument, this command toggles the mode.
 171 Non-null prefix argument turns on the mode.
 172 Null prefix argument turns off the mode.
 173
 174 When this mode is enable, TAB will indent if at point is at
 175 beginning of line or after a white space or closing parenthesis,
 176 and will try completing symbol at point otherwise."
 177   :init-value nil
 178   :lighter geiser-smart-tab-mode-string
 179   :group 'geiser-mode
 180   (set (make-local-variable 'tab-always-indent)
 181        (if geiser-smart-tab-mode
 182            'complete
 183          (default-value 'tab-always-indent))))
 184
 185 \f
 186 (provide 'geiser-completion)