elisp/geiser-completion.el

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