elisp/geiser-completion.el

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