elisp/geiser-mode.el

   1 ;; geiser-mode.el -- minor mode for scheme buffers
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 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: Sun Feb 08, 2009 15:13
  11
  12 \f
  13
  14 (require 'geiser-repl)
  15 (require 'geiser-menu)
  16 (require 'geiser-doc)
  17 (require 'geiser-compile)
  18 (require 'geiser-completion)
  19 (require 'geiser-company)
  20 (require 'geiser-xref)
  21 (require 'geiser-edit)
  22 (require 'geiser-autodoc)
  23 (require 'geiser-debug)
  24 (require 'geiser-syntax)
  25 (require 'geiser-impl)
  26 (require 'geiser-eval)
  27 (require 'geiser-popup)
  28 (require 'geiser-custom)
  29 (require 'geiser-base)
  30
  31 \f
  32 ;;; Customization:
  33
  34 (defgroup geiser-mode nil
  35   "Mode enabling Geiser abilities in Scheme buffers &co.."
  36   :group 'geiser)
  37
  38 (geiser-custom--defcustom geiser-mode-auto-p t
  39   "Whether `geiser-mode' should be active by default in all scheme buffers."
  40   :group 'geiser-mode
  41   :type 'boolean)
  42
  43 (geiser-custom--defcustom geiser-mode-start-repl-p nil
  44   "Whether a REPL should be automatically started if one is not
  45 active when `geiser-mode' is activated in a buffer."
  46   :group 'geiser-mode
  47   :type 'boolean)
  48
  49 (geiser-custom--defcustom geiser-mode-autodoc-p t
  50   "Whether `geiser-autodoc-mode' gets enabled by default in Scheme buffers."
  51   :group 'geiser-mode
  52   :group 'geiser-autodoc
  53   :type 'boolean)
  54
  55 (geiser-custom--defcustom geiser-mode-company-p t
  56   "Whether to use company-mode for completion, if available."
  57   :group 'geiser-mode
  58   :type 'boolean)
  59
  60 (geiser-custom--defcustom geiser-mode-smart-tab-p nil
  61   "Whether `geiser-smart-tab-mode' gets enabled by default in Scheme buffers."
  62   :group 'geiser-mode
  63   :type 'boolean)
  64
  65 (geiser-custom--defcustom geiser-mode-eval-last-sexp-to-buffer nil
  66   "Whether `eval-last-sexp' prints results to buffer"
  67   :group 'geiser-mode
  68   :type 'boolean)
  69
  70 (geiser-custom--defcustom geiser-mode-eval-to-buffer-prefix " "
  71   "When `geiser-mode-eval-last-sexp-to-buffer', the prefix string
  72 which will be prepended to results."
  73   :group 'geiser-mode
  74   :type 'string)
  75
  76 (geiser-custom--defcustom geiser-mode-eval-to-buffer-transformer nil
  77   "Transformer for results inserted in debug buffer.
  78
  79 When `geiser-mode-eval-last-sexp-to-buffer', the result will be
  80 transformed using this function default behavior is just prepend
  81 with `geiser-mode-eval-to-buffer-prefix' takes two arguments:
  82 `msg' and `is-error?'  `msg' is the result string going to be
  83 transformed, `is-error?' is a boolean indicating whether the
  84 result is an error msg."
  85   :group 'geiser-mode
  86   :type 'function)
  87
  88
  89 \f
  90 ;;; Evaluation commands:
  91
  92 (defun geiser--go-to-repl ()
  93   (switch-to-geiser nil nil (current-buffer))
  94   (push-mark)
  95   (goto-char (point-max)))
  96
  97 (defun geiser-eval-region (start end &optional and-go raw nomsg)
  98   "Eval the current region in the Geiser REPL.
  99
 100 With prefix, goes to the REPL buffer afterwards (as
 101 `geiser-eval-region-and-go')"
 102   (interactive "rP")
 103   (save-restriction
 104     (narrow-to-region start end)
 105     (check-parens))
 106   (geiser-debug--send-region nil
 107                              start
 108                              end
 109                              (and and-go 'geiser--go-to-repl)
 110                              (not raw)
 111                              nomsg))
 112
 113 (defun geiser-eval-region-and-go (start end)
 114   "Eval the current region in the Geiser REPL and visit it afterwads."
 115   (interactive "r")
 116   (geiser-eval-region start end t))
 117
 118 (geiser-impl--define-caller geiser-eval--bounds eval-bounds ()
 119   "A pair with the bounds of a buffer to be evaluated, defaulting
 120   to (cons (point-min) . (point-max)).")
 121
 122 (defun geiser-eval-buffer (&optional and-go raw nomsg)
 123   "Eval the current buffer in the Geiser REPL.
 124
 125 With prefix, goes to the REPL buffer afterwards (as
 126 `geiser-eval-buffer-and-go')"
 127   (interactive "P")
 128   (let* ((bounds (geiser-eval--bounds geiser-impl--implementation))
 129          (from (or (car bounds) (point-min)))
 130          (to (or (cdr bounds) (point-max))))
 131     (geiser-eval-region from to and-go raw nomsg)))
 132
 133 (defun geiser-eval-buffer-and-go ()
 134   "Eval the current buffer in the Geiser REPL and visit it afterwads."
 135   (interactive)
 136   (geiser-eval-buffer t))
 137
 138 (defun geiser-eval-definition (&optional and-go)
 139   "Eval the current definition in the Geiser REPL.
 140
 141 With prefix, goes to the REPL buffer afterwards (as
 142 `geiser-eval-definition-and-go')"
 143   (interactive "P")
 144   (save-excursion
 145     (end-of-defun)
 146     (let ((end (point)))
 147       (beginning-of-defun)
 148       (geiser-eval-region (point) end and-go t))))
 149
 150 (defun geiser-eval-definition-and-go ()
 151   "Eval the current definition in the Geiser REPL and visit it afterwads."
 152   (interactive)
 153   (geiser-eval-definition t))
 154
 155 (defun geiser-eval-last-sexp (print-to-buffer-p)
 156   "Eval the previous sexp in the Geiser REPL.
 157
 158 With a prefix, revert the effect of `geiser-mode-eval-last-sexp-to-buffer' "
 159   (interactive "P")
 160   (let* (bosexp
 161          (eosexp (save-excursion (backward-sexp)
 162                                  (setq bosexp (point))
 163                                  (forward-sexp)
 164                                  (point)))
 165          (ret-transformer (or geiser-mode-eval-to-buffer-transformer
 166                               (lambda (msg is-error?)
 167                                 (format "%s%s%s"
 168                                         geiser-mode-eval-to-buffer-prefix
 169                                         (if is-error? "ERROR" "")
 170                                         msg))))
 171          (ret (save-excursion
 172                 (geiser-eval-region bosexp ;beginning of sexp
 173                                     eosexp ;end of sexp
 174                                     nil
 175                                     t
 176                                     print-to-buffer-p)))
 177          (err (geiser-eval--retort-error ret))
 178          (will-eval-to-buffer (if print-to-buffer-p
 179                                   (not geiser-mode-eval-last-sexp-to-buffer)
 180                                 geiser-mode-eval-last-sexp-to-buffer))
 181          (str (geiser-eval--retort-result-str ret
 182                                               (when will-eval-to-buffer ""))))
 183     (cond  ((not will-eval-to-buffer) str)
 184            (err (insert (funcall ret-transformer
 185                                  (geiser-eval--error-str err) t)))
 186            ((string= "" str))
 187            (t (push-mark)
 188               (insert (funcall ret-transformer str nil))))))
 189
 190 (defun geiser-compile-definition (&optional and-go)
 191   "Compile the current definition in the Geiser REPL.
 192
 193 With prefix, goes to the REPL buffer afterwards (as
 194 `geiser-eval-definition-and-go')"
 195   (interactive "P")
 196   (save-excursion
 197     (end-of-defun)
 198     (let ((end (point)))
 199       (beginning-of-defun)
 200       (geiser-debug--send-region t
 201                                  (point)
 202                                  end
 203                                  (and and-go 'geiser--go-to-repl)
 204                                  t))))
 205
 206 (defun geiser-compile-definition-and-go ()
 207   "Compile the current definition in the Geiser REPL and visit it afterwads."
 208   (interactive)
 209   (geiser-compile-definition t))
 210
 211 (defun geiser-expand-region (start end &optional all raw)
 212   "Macro-expand the current region and display it in a buffer.
 213 With prefix, recursively macro-expand the resulting expression."
 214   (interactive "rP")
 215   (geiser-debug--expand-region start end all (not raw)))
 216
 217 (defun geiser-expand-definition (&optional all)
 218   "Macro-expand the current definition.
 219
 220 With prefix, recursively macro-expand the resulting expression."
 221   (interactive "P")
 222   (save-excursion
 223     (end-of-defun)
 224     (let ((end (point)))
 225       (beginning-of-defun)
 226       (geiser-expand-region (point) end all t))))
 227
 228 (defun geiser-expand-last-sexp (&optional all)
 229   "Macro-expand the previous sexp.
 230
 231 With prefix, recursively macro-expand the resulting expression."
 232   (interactive "P")
 233   (geiser-expand-region (save-excursion (backward-sexp) (point))
 234                         (point)
 235                         all
 236                         t))
 237
 238 (defun geiser-set-scheme ()
 239   "Associates current buffer with a given Scheme implementation."
 240   (interactive)
 241   (geiser-syntax--remove-kws)
 242   (let ((impl (geiser-impl--read-impl)))
 243     (geiser-impl--set-buffer-implementation impl)
 244     (geiser-repl--set-up-repl impl)
 245     (geiser-syntax--add-kws)
 246     (geiser-syntax--fontify)))
 247
 248 (defun geiser-mode-switch-to-repl (arg)
 249   "Switches to Geiser REPL.
 250
 251 With prefix, try to enter the current buffer's module."
 252   (interactive "P")
 253   (if arg
 254       (switch-to-geiser-module (geiser-eval--get-module) (current-buffer))
 255     (switch-to-geiser nil nil (current-buffer))))
 256
 257 (defun geiser-mode-switch-to-repl-and-enter ()
 258   "Switches to Geiser REPL and enters current buffer's module."
 259   (interactive)
 260   (geiser-mode-switch-to-repl t))
 261
 262 (defun geiser-restart-repl ()
 263   "Restarts the REPL associated with the current buffer."
 264   (interactive)
 265   (let ((b (current-buffer)))
 266     (geiser-mode-switch-to-repl nil)
 267     (comint-kill-subjob)
 268     (sit-for 0.1) ;; ugly hack; but i don't care enough to fix it
 269     (call-interactively 'run-geiser)
 270     (sit-for 0.2) ;; ditto
 271     (goto-char (point-max))
 272     (pop-to-buffer b)))
 273
 274 (defun geiser-squarify (n)
 275   "Toggle between () and [] for current form.
 276
 277 With numeric prefix, perform that many toggles, forward for
 278 positive values and backward for negative."
 279   (interactive "p")
 280   (let ((pared (and (boundp 'paredit-mode) paredit-mode))
 281         (fwd (> n 0))
 282         (steps (abs n)))
 283     (when (and pared (fboundp 'paredit-mode)) (paredit-mode -1))
 284     (unwind-protect
 285         (save-excursion
 286           (unless (looking-at-p "\\s(") (backward-up-list))
 287           (while (> steps 0)
 288             (let ((p (point))
 289                   (round (looking-at-p "(")))
 290               (forward-sexp)
 291               (backward-delete-char 1)
 292               (insert (if round "]" ")"))
 293               (goto-char p)
 294               (delete-char 1)
 295               (insert (if round "[" "("))
 296               (setq steps (1- steps))
 297               (backward-char)
 298               (condition-case nil
 299                   (progn (when fwd (forward-sexp 2))
 300                          (backward-sexp))
 301                 (error (setq steps 0))))))
 302       (when (and pared (fboundp 'paredit-mode)) (paredit-mode 1)))))
 303
 304 (defun geiser-insert-lambda (&optional full)
 305   "Insert λ at point.  With prefix, inserts (λ ())."
 306   (interactive "P")
 307   (if (not full)
 308       (insert (make-char 'greek-iso8859-7 107))
 309     (insert "(" (make-char 'greek-iso8859-7 107) " ())")
 310     (backward-char 2)))
 311
 312 \f
 313 ;;; Geiser mode:
 314
 315 (make-variable-buffer-local
 316  (defvar geiser-mode-string nil
 317    "Modeline indicator for geiser-mode"))
 318
 319 (defun geiser-mode--lighter ()
 320   (or geiser-mode-string
 321       (format " %s" (or (geiser-impl--impl-str) "G"))))
 322
 323 (defvar geiser-mode-map (make-sparse-keymap))
 324
 325 (define-minor-mode geiser-mode
 326   "Toggle Geiser's mode.
 327
 328 With no argument, this command toggles the mode.
 329 Non-null prefix argument turns on the mode.
 330 Null prefix argument turns off the mode.
 331
 332 When Geiser mode is enabled, a host of nice utilities for
 333 interacting with the Geiser REPL is at your disposal.
 334 \\{geiser-mode-map}"
 335   :init-value nil
 336   :lighter (:eval (geiser-mode--lighter))
 337   :group 'geiser-mode
 338   :keymap geiser-mode-map
 339   (when geiser-mode (geiser-impl--set-buffer-implementation nil t))
 340   (setq geiser-autodoc-mode-string "/A")
 341   (setq geiser-smart-tab-mode-string "/T")
 342   (geiser-company--setup (and geiser-mode geiser-mode-company-p))
 343   (geiser-completion--setup geiser-mode)
 344   (when geiser-mode-autodoc-p
 345     (geiser-autodoc-mode (if geiser-mode 1 -1)))
 346   (when geiser-mode-smart-tab-p
 347     (geiser-smart-tab-mode (if geiser-mode 1 -1)))
 348   (geiser-syntax--add-kws)
 349   (when (and geiser-mode
 350              geiser-mode-start-repl-p
 351              (not (geiser-syntax--font-lock-buffer-p))
 352              (not (geiser-repl--connection*)))
 353     (save-window-excursion (run-geiser geiser-impl--implementation))))
 354
 355 (defun turn-on-geiser-mode ()
 356   "Enable `geiser-mode' (in a Scheme buffer)."
 357   (interactive)
 358   (geiser-mode 1))
 359
 360 (defun turn-off-geiser-mode ()
 361   "Disable `geiser-mode' (in a Scheme buffer)."
 362   (interactive)
 363   (geiser-mode -1))
 364
 365 (defun geiser-mode--maybe-activate ()
 366   (when (and geiser-mode-auto-p (eq major-mode 'scheme-mode))
 367     (turn-on-geiser-mode)))
 368
 369 \f
 370 ;;; Keys:
 371
 372 (geiser-menu--defmenu geiserm geiser-mode-map
 373   ("Eval sexp before point" "\C-x\C-e" geiser-eval-last-sexp)
 374   ("Eval definition" ("\M-\C-x" "\C-c\C-c") geiser-eval-definition)
 375   ("Eval definition and go" ("\C-c\M-e" "\C-c\M-e")
 376    geiser-eval-definition-and-go)
 377   ("Eval region" "\C-c\C-r" geiser-eval-region :enable mark-active)
 378   ("Eval region and go" "\C-c\M-r" geiser-eval-region-and-go
 379    geiser-eval-region :enable mark-active)
 380   ("Eval buffer" "\C-c\C-b" geiser-eval-buffer)
 381   ("Eval buffer and go" "\C-c\M-b" geiser-eval-buffer-and-go)
 382   ("Load scheme file..." "\C-c\C-l" geiser-load-file)
 383   (menu "Macroexpand"
 384         ("Sexp before point" ("\C-c\C-m\C-e" "\C-c\C-me")
 385          geiser-expand-last-sexp)
 386         ("Region" ("\C-c\C-m\C-r" "\C-c\C-mr") geiser-expand-region)
 387         ("Definition" ("\C-c\C-m\C-x" "\C-c\C-mx") geiser-expand-definition))
 388   --
 389   ("Symbol documentation" ("\C-c\C-d\C-d" "\C-c\C-dd")
 390    geiser-doc-symbol-at-point :enable (geiser--symbol-at-point))
 391   ("Short symbol documentation" ("\C-c\C-d\C-s" "\C-c\C-ds")
 392    geiser-autodoc-show :enable (geiser--symbol-at-point))
 393   ("Module documentation" ("\C-c\C-d\C-m" "\C-c\C-dm") geiser-doc-module)
 394   ("Symbol manual lookup" ("\C-c\C-d\C-i" "\C-c\C-di")
 395    geiser-doc-look-up-manual :enable (geiser-doc--manual-available-p))
 396   (mode "Autodoc mode" ("\C-c\C-d\C-a" "\C-c\C-da") geiser-autodoc-mode)
 397   --
 398   ("Compile buffer" "\C-c\C-k" geiser-compile-current-buffer)
 399   ("Switch to REPL" "\C-c\C-z" geiser-mode-switch-to-repl)
 400   ("Switch to REPL and enter module" "\C-c\C-a"
 401    geiser-mode-switch-to-repl-and-enter)
 402   ("Set Scheme..." "\C-c\C-s" geiser-set-scheme)
 403   --
 404   ("Edit symbol at point" "\M-." geiser-edit-symbol-at-point
 405    :enable (geiser--symbol-at-point))
 406   ("Go to previous definition" "\M-," geiser-pop-symbol-stack)
 407   ("Complete symbol" ((kbd "M-TAB")) completion-at-point
 408    :enable (geiser--symbol-at-point))
 409   ("Complete module name" ((kbd "M-`") (kbd "C-."))
 410    geiser-completion--complete-module)
 411   ("Edit module" ("\C-c\C-e\C-m" "\C-c\C-em") geiser-edit-module)
 412   ("Add to load path..." ("\C-c\C-e\C-l" "\C-c\C-el") geiser-add-to-load-path)
 413   ("Toggle ()/[]" ("\C-c\C-e\C-[" "\C-c\C-e[") geiser-squarify)
 414   ("Insert λ" ("\C-c\\" "\C-c\C-\\") geiser-insert-lambda)
 415   --
 416   ("Callers" ((kbd "C-c <")) geiser-xref-callers
 417    :enable (and (geiser-eval--supported-p 'callers)
 418                 (geiser--symbol-at-point)))
 419   ("Callees" ((kbd "C-c >")) geiser-xref-callees
 420    :enable (and (geiser-eval--supported-p 'callees)
 421                 (geiser--symbol-at-point)))
 422   --
 423   (mode "Smart TAB mode" nil geiser-smart-tab-mode)
 424   --
 425   (custom "Customize Geiser mode" geiser-mode))
 426
 427 (define-key geiser-mode-map [menu-bar scheme] 'undefined)
 428
 429 ;; (geiser-mode--triple-chord ?x ?m 'geiser-xref-generic-methods)
 430
 431 \f
 432 ;;; Reload support:
 433
 434 (defun geiser-mode--buffers ()
 435   (let ((buffers))
 436     (dolist (buffer (buffer-list))
 437       (when (buffer-live-p buffer)
 438         (set-buffer buffer)
 439         (when geiser-mode
 440           (push (cons buffer geiser-impl--implementation) buffers))))
 441     buffers))
 442
 443 (defun geiser-mode--restore (buffers)
 444   (dolist (b buffers)
 445     (when (buffer-live-p (car b))
 446       (set-buffer (car b))
 447       (when (cdr b)
 448         (geiser-impl--set-buffer-implementation (cdr b)))
 449       (geiser-mode 1))))
 450
 451 (defun geiser-mode-unload-function ()
 452   (dolist (b (geiser-mode--buffers))
 453     (with-current-buffer (car b) (geiser-mode nil))))
 454
 455 \f
 456 (provide 'geiser-mode)