elisp/geiser-repl.el

   1 ;;; geiser-repl.el --- Geiser's REPL
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2015, 2016, 2018, 2019 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 \f
  11
  12 (require 'geiser-company)
  13 (require 'geiser-doc)
  14 (require 'geiser-autodoc)
  15 (require 'geiser-edit)
  16 (require 'geiser-completion)
  17 (require 'geiser-syntax)
  18 (require 'geiser-impl)
  19 (require 'geiser-eval)
  20 (require 'geiser-connection)
  21 (require 'geiser-menu)
  22 (require 'geiser-image)
  23 (require 'geiser-custom)
  24 (require 'geiser-base)
  25
  26 (require 'comint)
  27 (require 'compile)
  28 (require 'scheme)
  29 (require 'font-lock)
  30
  31 \f
  32 ;;; Customization:
  33
  34 (defgroup geiser-repl nil
  35   "Interacting with the Geiser REPL."
  36   :group 'geiser)
  37
  38 (geiser-custom--defcustom geiser-repl-buffer-name-function
  39     'geiser-repl-buffer-name
  40   "Function used to define the name of a REPL buffer.
  41 The function is called with a single argument - an implementation
  42 symbol (e.g., `guile', `chicken', etc.)."
  43   :type '(choice (function-item geiser-repl-buffer-name)
  44                  (function :tag "Other function"))
  45   :group 'geiser-repl)
  46
  47 (geiser-custom--defcustom geiser-repl-use-other-window t
  48   "Whether to Use a window other than the current buffer's when
  49 switching to the Geiser REPL buffer."
  50   :type 'boolean
  51   :group 'geiser-repl)
  52
  53 (geiser-custom--defcustom geiser-repl-window-allow-split t
  54   "Whether to allow window splitting when switching to the Geiser
  55 REPL buffer."
  56   :type 'boolean
  57   :group 'geiser-repl)
  58
  59 (geiser-custom--defcustom geiser-repl-history-filename
  60     (expand-file-name "~/.geiser_history")
  61   "File where REPL input history is saved, so that it persists between sessions.
  62
  63 This is actually the base name: the concrete Scheme
  64 implementation name gets appended to it."
  65   :type 'file
  66   :group 'geiser-repl)
  67
  68 (geiser-custom--defcustom geiser-repl-history-size comint-input-ring-size
  69   "Maximum size of the saved REPL input history."
  70   :type 'integer
  71   :group 'geiser-repl)
  72
  73 (geiser-custom--defcustom geiser-repl-history-no-dups-p t
  74   "Whether to skip duplicates when recording history."
  75   :type 'boolean
  76   :group 'geiser-repl)
  77
  78 (geiser-custom--defcustom geiser-repl-save-debugging-history-p nil
  79   "Whether to skip debugging input in REPL history.
  80
  81 By default, REPL interactions while scheme is in the debugger are
  82 not added to the REPL command history.  Set this variable to t to
  83 change that."
  84   :type 'boolean
  85   :group 'geiser-repl)
  86
  87 (geiser-custom--defcustom geiser-repl-autodoc-p t
  88   "Whether to enable `geiser-autodoc-mode' in the REPL by default."
  89   :type 'boolean
  90   :group 'geiser-repl)
  91
  92 (geiser-custom--defcustom geiser-repl-company-p t
  93   "Whether to use company-mode for completion, if available."
  94   :group 'geiser-mode
  95   :type 'boolean)
  96
  97 (geiser-custom--defcustom geiser-repl-read-only-prompt-p t
  98   "Whether the REPL's prompt should be read-only."
  99   :type 'boolean
 100   :group 'geiser-repl)
 101
 102 (geiser-custom--defcustom geiser-repl-read-only-output-p t
 103   "Whether the REPL's output should be read-only."
 104   :type 'boolean
 105   :group 'geiser-repl)
 106
 107 (geiser-custom--defcustom geiser-repl-highlight-output-p nil
 108   "Whether to syntax highlight REPL output."
 109   :type 'boolean
 110   :group 'geiser-repl)
 111
 112 (geiser-custom--defcustom geiser-repl-auto-indent-p t
 113   "Whether newlines for incomplete sexps are autoindented."
 114   :type 'boolean
 115   :group 'geiser-repl)
 116
 117 (geiser-custom--defcustom geiser-repl-send-on-return-p t
 118   "Sends input to REPL when ENTER is pressed in a balanced S-expression,
 119 regardless of cursor positioning.
 120
 121 When off, pressing ENTER inside a balance S-expression will
 122 introduce a new line without sending input to the inferior
 123 Scheme process. This option is useful when using minor modes
 124 which might do parentheses balancing, or when entering additional
 125 arguments inside an existing expression.
 126
 127 When on (the default), pressing ENTER inside a balanced S-expression
 128 will send the input to the inferior Scheme process regardless of the
 129 cursor placement."
 130   :type 'boolean
 131   :group 'geiser-repl)
 132
 133 (geiser-custom--defcustom geiser-repl-forget-old-errors-p t
 134   "Whether to forget old errors upon entering a new expression.
 135
 136 When on (the default), every time a new expression is entered in
 137 the REPL old error messages are flushed, and using \\[next-error]
 138 afterwards will jump only to error locations produced by the new
 139 expression, if any."
 140   :type 'boolean
 141   :group 'geiser-repl)
 142
 143 (geiser-custom--defcustom geiser-repl-skip-version-check-p nil
 144   "Whether to skip version checks for the Scheme executable.
 145
 146 When set, Geiser won't check the version of the Scheme
 147 interpreter when starting a REPL, saving a few tenths of a
 148 second.
 149 "
 150   :type 'boolean
 151   :group 'geiser-repl)
 152
 153 (geiser-custom--defcustom geiser-repl-query-on-exit-p nil
 154   "Whether to prompt for confirmation on \\[geiser-repl-exit]."
 155   :type 'boolean
 156   :group 'geiser-repl)
 157
 158 (geiser-custom--defcustom geiser-repl-delete-last-output-on-exit-p nil
 159   "Whether to delete partial outputs when the REPL's process exits."
 160   :type 'boolean
 161   :group 'geiser-repl)
 162
 163 (geiser-custom--defcustom geiser-repl-query-on-kill-p t
 164   "Whether to prompt for confirmation when killing a REPL buffer with
 165 a life process."
 166   :type 'boolean
 167   :group 'geiser-repl)
 168
 169 (geiser-custom--defcustom geiser-repl-default-host "localhost"
 170   "Default host when connecting to remote REPLs."
 171   :type 'string
 172   :group 'geiser-repl)
 173
 174 (geiser-custom--defcustom geiser-repl-default-port 37146
 175   "Default port for connecting to remote REPLs."
 176   :type 'integer
 177   :group 'geiser-repl)
 178
 179 (geiser-custom--defcustom geiser-repl-startup-time 10000
 180   "Time, in milliseconds, to wait for Racket to startup.
 181 If you have a slow system, try to increase this time."
 182   :type 'integer
 183   :group 'geiser-repl)
 184
 185 (geiser-custom--defcustom geiser-repl-inline-images-p t
 186   "Whether to display inline images in the REPL."
 187   :type 'boolean
 188   :group 'geiser-repl)
 189
 190 (geiser-custom--defcustom geiser-repl-auto-display-images-p t
 191   "Whether to automatically invoke the external viewer to display
 192 images popping up in the REPL.
 193
 194 See also `geiser-debug-auto-display-images-p'."
 195   :type 'boolean
 196   :group 'geiser-repl)
 197
 198 (geiser-custom--defface repl-input
 199   'comint-highlight-input geiser-repl "evaluated input highlighting")
 200
 201 (geiser-custom--defface repl-output
 202   'font-lock-string-face geiser-repl "REPL output")
 203
 204 (geiser-custom--defface repl-prompt
 205   'comint-highlight-prompt geiser-repl "REPL prompt")
 206
 207
 208 \f
 209 ;;; Implementation-dependent parameters
 210
 211 (geiser-impl--define-caller geiser-repl--binary binary ()
 212   "A variable or function returning the path to the scheme binary
 213 for this implementation.")
 214
 215 (geiser-impl--define-caller geiser-repl--arglist arglist ()
 216   "A function taking no arguments and returning a list of
 217 arguments to be used when invoking the scheme binary.")
 218
 219 (geiser-impl--define-caller geiser-repl--prompt-regexp prompt-regexp ()
 220   "A variable (or thunk returning a value) giving the regular
 221 expression for this implementation's geiser scheme prompt.")
 222
 223 (geiser-impl--define-caller
 224     geiser-repl--debugger-prompt-regexp debugger-prompt-regexp ()
 225   "A variable (or thunk returning a value) giving the regular
 226 expression for this implementation's debugging prompt.")
 227
 228 (geiser-impl--define-caller geiser-repl--startup repl-startup (remote)
 229   "Function taking no parameters that is called after the REPL
 230 has been initialised. All Geiser functionality is available to
 231 you at that point.")
 232
 233 (geiser-impl--define-caller geiser-repl--enter-cmd enter-command (module)
 234   "Function taking a module designator and returning a REPL enter
 235 module command as a string")
 236
 237 (geiser-impl--define-caller geiser-repl--import-cmd import-command (module)
 238   "Function taking a module designator and returning a REPL import
 239 module command as a string")
 240
 241 (geiser-impl--define-caller geiser-repl--exit-cmd exit-command ()
 242   "Function returning the REPL exit command as a string")
 243
 244 (geiser-impl--define-caller geiser-repl--version version-command (binary)
 245   "Function returning the version of the corresponding scheme process,
 246    given its full path.")
 247
 248 (geiser-impl--define-caller geiser-repl--min-version minimum-version ()
 249   "A variable providing the minimum required scheme version, as a string.")
 250
 251 \f
 252 ;;; Geiser REPL buffers and processes:
 253
 254 (defvar geiser-repl--repls nil)
 255 (defvar geiser-repl--closed-repls nil)
 256
 257 (defvar geiser-repl--last-output-start nil)
 258 (defvar geiser-repl--last-output-end nil)
 259
 260 (make-variable-buffer-local
 261  (defvar geiser-repl--repl nil))
 262
 263 (defsubst geiser-repl--set-this-buffer-repl (r)
 264   (setq geiser-repl--repl r))
 265
 266 (defun geiser-repl--live-p ()
 267   (and geiser-repl--repl
 268        (get-buffer-process geiser-repl--repl)))
 269
 270 (defun geiser-repl--repl/impl (impl &optional repls)
 271   (catch 'repl
 272     (dolist (repl (or repls geiser-repl--repls))
 273       (when (buffer-live-p repl)
 274         (with-current-buffer repl
 275           (when (eq geiser-impl--implementation impl)
 276             (throw 'repl repl)))))))
 277
 278 (defun geiser-repl--set-up-repl (impl)
 279   (or (and (not impl) geiser-repl--repl)
 280       (setq geiser-repl--repl
 281             (let ((impl (or impl
 282                             geiser-impl--implementation
 283                             (geiser-impl--guess))))
 284               (when impl (geiser-repl--repl/impl impl))))))
 285
 286 (defun geiser-repl--active-impls ()
 287   (let ((act))
 288     (dolist (repl geiser-repl--repls act)
 289       (with-current-buffer repl
 290         (add-to-list 'act geiser-impl--implementation)))))
 291
 292 (defsubst geiser-repl--repl-name (impl)
 293   (format "%s REPL" (geiser-impl--impl-str impl)))
 294
 295 (defsubst geiser-repl--buffer-name (impl)
 296   (funcall geiser-repl-buffer-name-function impl))
 297
 298 (defun geiser-repl-buffer-name (impl)
 299   "Return default name of the REPL buffer for implementation IMPL."
 300   (format "* %s *" (geiser-repl--repl-name impl)))
 301
 302 (defun geiser-repl--switch-to-buffer (buffer)
 303   (unless (eq buffer (current-buffer))
 304     (let ((pop-up-windows geiser-repl-window-allow-split))
 305       (if geiser-repl-use-other-window
 306           (switch-to-buffer-other-window buffer)
 307         (switch-to-buffer buffer)))))
 308
 309 (defun geiser-repl--to-repl-buffer (impl)
 310   (unless (and (eq major-mode 'geiser-repl-mode)
 311                (eq geiser-impl--implementation impl)
 312                (not (get-buffer-process (current-buffer))))
 313     (let* ((old (geiser-repl--repl/impl impl geiser-repl--closed-repls))
 314            (old (and (buffer-live-p old)
 315                      (not (get-buffer-process old))
 316                      old)))
 317       (geiser-repl--switch-to-buffer
 318        (or old (generate-new-buffer (geiser-repl--buffer-name impl))))
 319       (unless old
 320         (geiser-repl-mode)
 321         (geiser-impl--set-buffer-implementation impl)
 322         (geiser-syntax--add-kws t)))))
 323
 324 (defun geiser-repl--read-impl (prompt &optional active)
 325   (geiser-impl--read-impl prompt (and active (geiser-repl--active-impls))))
 326
 327 (defsubst geiser-repl--only-impl-p ()
 328   (and (null (cdr geiser-active-implementations))
 329        (car geiser-active-implementations)))
 330
 331 (defun geiser-repl--get-impl (prompt)
 332   (or (geiser-repl--only-impl-p)
 333       (and (eq major-mode 'geiser-repl-mode) geiser-impl--implementation)
 334       (geiser-repl--read-impl prompt)))
 335
 336 \f
 337 ;;; Prompt &co.
 338
 339 (defun geiser-repl--last-prompt-end ()
 340   (cond ((and (boundp 'comint-last-prompt) (markerp (cdr comint-last-prompt)))
 341          (marker-position (cdr comint-last-prompt)))
 342         ((and (boundp 'comint-last-prompt-overlay) comint-last-prompt-overlay)
 343          (overlay-end comint-last-prompt-overlay))
 344         (t (save-excursion
 345              (geiser-repl--bol)
 346              (min (+ 1 (point)) (point-max))))))
 347
 348 (defun geiser-repl--last-prompt-start ()
 349   (cond ((and (boundp 'comint-last-prompt) (markerp (car comint-last-prompt)))
 350          (marker-position (car comint-last-prompt)))
 351         ((and (boundp 'comint-last-prompt-overlay) comint-last-prompt-overlay)
 352          (overlay-start comint-last-prompt-overlay))
 353         (t (save-excursion (geiser-repl--bol) (point)))))
 354
 355 \f
 356 ;;; REPL connections
 357
 358 (make-variable-buffer-local
 359  (defvar geiser-repl--address nil))
 360
 361 (make-variable-buffer-local
 362  (defvar geiser-repl--connection nil))
 363
 364 (defun geiser-repl--local-p ()
 365   "Return non-nil, if current REPL is local (connected to socket)."
 366   (stringp geiser-repl--address))
 367
 368 (defun geiser-repl--remote-p ()
 369   "Return non-nil, if current REPL is remote (connected to host:port)."
 370   (consp geiser-repl--address))
 371
 372 (defsubst geiser-repl--host () (car geiser-repl--address))
 373 (defsubst geiser-repl--port () (cdr geiser-repl--address))
 374
 375 (defun geiser-repl--read-address (&optional host port)
 376   (let ((defhost (or (geiser-repl--host) geiser-repl-default-host))
 377         (defport (or (geiser-repl--port) geiser-repl-default-port)))
 378     (cons (or host
 379               (read-string (format "Host (default %s): " defhost)
 380                            nil nil defhost))
 381           (or port (read-number "Port: " defport)))))
 382
 383 (defun geiser-repl--autodoc-mode (n)
 384   (when (or geiser-repl-autodoc-p (< n 0))
 385     (geiser--save-msg (geiser-autodoc-mode n))))
 386
 387 (defun geiser-repl--save-remote-data (address)
 388   (setq geiser-repl--address address)
 389   (cond ((consp address)
 390          (setq header-line-format
 391                (format "Host: %s   Port: %s"
 392                        (geiser-repl--host)
 393                        (geiser-repl--port))))
 394         ((stringp address)
 395          (setq header-line-format
 396                (format "Socket: %s" address)))))
 397
 398 (defun geiser-repl--fontify-output-region (beg end)
 399   "Apply highlighting to a REPL output region."
 400   (remove-text-properties beg end '(font-lock-face nil face nil))
 401   (if geiser-repl-highlight-output-p
 402       (geiser-syntax--fontify-syntax-region beg end)
 403     (geiser-repl--fontify-plaintext beg end)))
 404
 405 (defun geiser-repl--fontify-plaintext (start end)
 406   "Fontify REPL output plainly."
 407   (add-text-properties
 408    start end
 409    '(font-lock-fontified t
 410      fontified t
 411      font-lock-multiline t
 412      font-lock-face geiser-font-lock-repl-output)))
 413
 414 (defun geiser-repl--narrow-to-prompt ()
 415   "Narrow to active prompt region and return t, otherwise returns nil."
 416   (let* ((proc (get-buffer-process (current-buffer)))
 417          (pmark (and proc (process-mark proc)))
 418          (intxt (when (>= (point) (marker-position pmark))
 419                   (save-excursion
 420                     (if comint-eol-on-send
 421                         (if comint-use-prompt-regexp
 422                             (end-of-line)
 423                           (goto-char (field-end))))
 424                     (buffer-substring pmark (point)))))
 425          (prompt-beg (marker-position pmark))
 426          (prompt-end (+ prompt-beg (length intxt))))
 427     (when (> (length intxt) 0)
 428       (narrow-to-region prompt-beg prompt-end)
 429       t)))
 430
 431 (defun geiser-repl--wrap-fontify-region-function (beg end &optional loudly)
 432   (save-restriction
 433     (when (geiser-repl--narrow-to-prompt)
 434       (let ((font-lock-dont-widen t))
 435         (font-lock-default-fontify-region (point-min) (point-max) nil)))))
 436
 437 (defun geiser-repl--wrap-unfontify-region-function (beg end &optional loudly)
 438   (save-restriction
 439     (when (geiser-repl--narrow-to-prompt)
 440       (let ((font-lock-dont-widen t))
 441         (font-lock-default-unfontify-region (point-min) (point-max))))))
 442
 443 (defun geiser-repl--output-filter (txt)
 444   (let ((mark-output nil))
 445     (save-excursion
 446       (goto-char (point-max))
 447       (re-search-backward comint-prompt-regexp)
 448       ;; move to start of line to prevent accidentally marking a REPL prompt
 449       (move-to-column 0)
 450       ;; Only mark output which:
 451       ;; a) is not on the REPL output line
 452       ;; b) has at least one character
 453       ;;
 454       ;; This makes the magic number for distance 3 -- as the newline
 455       ;; after executing expression is also counted. This is due to the point
 456       ;; being set before comint-send-input.
 457       ;;
 458       ;; Restriction a) applies due to our inability to distinguish between
 459       ;; output from the REPL, and the REPL prompt output.
 460       (let ((distance (- (point) geiser-repl--last-output-start)))
 461         (when (> distance 2)
 462           (setq mark-output t)
 463           (set-marker geiser-repl--last-output-end (point)))))
 464     (when mark-output
 465       (with-silent-modifications
 466         (add-text-properties (1+ geiser-repl--last-output-start)
 467                              geiser-repl--last-output-end
 468                              `(read-only ,geiser-repl-read-only-output-p))
 469         (geiser-repl--fontify-output-region geiser-repl--last-output-start
 470                                             geiser-repl--last-output-end)
 471         (geiser--font-lock-ensure geiser-repl--last-output-start
 472                                   geiser-repl--last-output-end))))
 473
 474   (geiser-con--connection-update-debugging geiser-repl--connection txt)
 475   (geiser-image--replace-images geiser-repl-inline-images-p
 476                                 geiser-repl-auto-display-images-p)
 477   (when (string-match-p (geiser-con--connection-prompt geiser-repl--connection)
 478                         txt)
 479     (geiser-autodoc--disinhibit-autodoc)))
 480
 481 (defun geiser-repl--check-version (impl)
 482   (when (not geiser-repl-skip-version-check-p)
 483     (let ((v (geiser-repl--version impl (geiser-repl--binary impl)))
 484           (r (geiser-repl--min-version impl)))
 485       (when (and v r (geiser--version< v r))
 486         (error "Geiser requires %s version %s but detected %s" impl r v)))))
 487
 488 (defun geiser-repl--start-repl (impl address)
 489   (message "Starting Geiser REPL ...")
 490   (when (not address) (geiser-repl--check-version impl))
 491   (geiser-repl--to-repl-buffer impl)
 492   (sit-for 0)
 493   (goto-char (point-max))
 494   (geiser-repl--autodoc-mode -1)
 495   (let* ((prompt-rx (geiser-repl--prompt-regexp impl))
 496          (deb-prompt-rx (geiser-repl--debugger-prompt-regexp impl))
 497          (prompt (geiser-con--combined-prompt prompt-rx deb-prompt-rx)))
 498     (unless prompt-rx
 499       (error "Sorry, I don't know how to start a REPL for %s" impl))
 500     (geiser-repl--save-remote-data address)
 501     (geiser-repl--start-scheme impl address prompt)
 502     (geiser-repl--quit-setup)
 503     (geiser-repl--history-setup)
 504     (add-to-list 'geiser-repl--repls (current-buffer))
 505     (geiser-repl--set-this-buffer-repl (current-buffer))
 506     (setq geiser-repl--connection
 507           (geiser-con--make-connection (get-buffer-process (current-buffer))
 508                                        prompt-rx
 509                                        deb-prompt-rx))
 510     (geiser-repl--startup impl address)
 511     (geiser-repl--autodoc-mode 1)
 512     (geiser-company--setup geiser-repl-company-p)
 513     (add-hook 'comint-output-filter-functions
 514               'geiser-repl--output-filter
 515               nil
 516               t)
 517     (set-process-query-on-exit-flag (get-buffer-process (current-buffer))
 518                                     geiser-repl-query-on-kill-p)
 519     (message "%s up and running!" (geiser-repl--repl-name impl))))
 520
 521 (defun geiser-repl--start-scheme (impl address prompt)
 522   (setq comint-prompt-regexp prompt)
 523   (let* ((name (geiser-repl--repl-name impl))
 524          (buff (current-buffer))
 525          (args (cond ((consp address) (list address))
 526                      ((stringp address) '(()))
 527                      (t `(,(geiser-repl--binary impl)
 528                           nil
 529                           ,@(geiser-repl--arglist impl))))))
 530     (condition-case err
 531         (if (and address (stringp address))
 532             ;; Connect over a Unix-domain socket.
 533             (let ((proc (make-network-process :name (buffer-name buff)
 534                                               :buffer buff
 535                                               :family 'local
 536                                               :remote address)))
 537               ;; brittleness warning: this is stuff
 538               ;; make-comint-in-buffer sets up, via comint-exec, when
 539               ;; it creates its own process, something we're doing
 540               ;; here by ourselves.
 541               (set-process-filter proc 'comint-output-filter)
 542               (goto-char (point-max))
 543               (set-marker (process-mark proc) (point)))
 544           (apply 'make-comint-in-buffer `(,name ,buff ,@args)))
 545       (error (insert "Unable to start REPL:\n"
 546                      (error-message-string err)
 547                      "\n")
 548              (error "Couldn't start Geiser: %s" err)))
 549     (geiser-repl--wait-for-prompt geiser-repl-startup-time)))
 550
 551 (defun geiser-repl--wait-for-prompt (timeout)
 552   (let ((p (point)) (seen) (buffer (current-buffer)))
 553     (while (and (not seen)
 554                 (> timeout 0)
 555                 (get-buffer-process buffer))
 556       (sleep-for 0.1)
 557       (setq timeout (- timeout 100))
 558       (goto-char p)
 559       (setq seen (re-search-forward comint-prompt-regexp nil t)))
 560     (goto-char (point-max))
 561     (unless seen (error "%s" "No prompt found!"))))
 562
 563 (defun geiser-repl--is-debugging ()
 564   (let ((dp (geiser-con--connection-debug-prompt geiser-repl--connection)))
 565     (and dp
 566          (save-excursion
 567            (goto-char (geiser-repl--last-prompt-start))
 568            (re-search-forward dp (geiser-repl--last-prompt-end) t)))))
 569
 570 (defun geiser-repl--connection* ()
 571   (let ((buffer (geiser-repl--set-up-repl geiser-impl--implementation)))
 572    (and (buffer-live-p buffer)
 573         (get-buffer-process buffer)
 574         (with-current-buffer buffer geiser-repl--connection))))
 575
 576 (defun geiser-repl--connection ()
 577   (or (geiser-repl--connection*)
 578       (error "No Geiser REPL for this buffer (try M-x run-geiser)")))
 579
 580 (setq geiser-eval--default-connection-function 'geiser-repl--connection)
 581
 582 (defun geiser-repl--prepare-send ()
 583   (geiser-image--clean-cache)
 584   (geiser-autodoc--inhibit-autodoc)
 585   (geiser-con--connection-deactivate geiser-repl--connection))
 586
 587 (defun geiser-repl--send (cmd &optional save-history)
 588   "Send CMD input string to the current REPL buffer.
 589 If SAVE-HISTORY is non-nil, save CMD in the REPL history."
 590   (when (and cmd (eq major-mode 'geiser-repl-mode))
 591     (geiser-repl--prepare-send)
 592     (goto-char (point-max))
 593     (comint-kill-input)
 594     (insert cmd)
 595     (let ((comint-input-filter (if save-history
 596                                    comint-input-filter
 597                                  'ignore)))
 598       (comint-send-input nil t))))
 599
 600 (defun geiser-repl-interrupt ()
 601   (interactive)
 602   (when (get-buffer-process (current-buffer))
 603     (interrupt-process nil comint-ptyp)))
 604
 605 \f
 606 ;;; REPL history
 607
 608 (defconst geiser-repl--history-separator "\n}{\n")
 609
 610 (defsubst geiser-repl--history-file ()
 611   (format "%s.%s" geiser-repl-history-filename geiser-impl--implementation))
 612
 613 (defun geiser-repl--read-input-ring ()
 614   (let ((comint-input-ring-file-name (geiser-repl--history-file))
 615         (comint-input-ring-separator geiser-repl--history-separator)
 616         (buffer-file-coding-system 'utf-8))
 617     (comint-read-input-ring t)))
 618
 619 (defun geiser-repl--write-input-ring ()
 620   (let ((comint-input-ring-file-name (geiser-repl--history-file))
 621         (comint-input-ring-separator geiser-repl--history-separator)
 622         (buffer-file-coding-system 'utf-8))
 623     (comint-write-input-ring)))
 624
 625 (defun geiser-repl--history-setup ()
 626   (set (make-local-variable 'comint-input-ring-size) geiser-repl-history-size)
 627   (set (make-local-variable 'comint-input-filter) 'geiser-repl--input-filter)
 628   (geiser-repl--read-input-ring))
 629
 630 \f
 631 ;;; Cleaning up
 632
 633 (defun geiser-repl--on-quit ()
 634   (geiser-repl--write-input-ring)
 635   (let ((cb (current-buffer))
 636         (impl geiser-impl--implementation)
 637         (comint-prompt-read-only nil))
 638     (geiser-con--connection-deactivate geiser-repl--connection t)
 639     (geiser-con--connection-close geiser-repl--connection)
 640     (setq geiser-repl--repls (remove cb geiser-repl--repls))
 641     (dolist (buffer (buffer-list))
 642       (when (buffer-live-p buffer)
 643         (with-current-buffer buffer
 644           (when (and (eq geiser-impl--implementation impl)
 645                      (equal cb geiser-repl--repl))
 646             (geiser-repl--set-up-repl geiser-impl--implementation)))))))
 647
 648 (defun geiser-repl--sentinel (proc event)
 649   (let ((pb (process-buffer proc)))
 650     (when (buffer-live-p pb)
 651       (with-current-buffer pb
 652         (let ((comint-prompt-read-only nil)
 653               (comint-input-ring-file-name (geiser-repl--history-file))
 654               (comint-input-ring-separator geiser-repl--history-separator))
 655           (geiser-repl--on-quit)
 656           (push pb geiser-repl--closed-repls)
 657           (goto-char (point-max))
 658           (when geiser-repl-delete-last-output-on-exit-p
 659             (comint-kill-region comint-last-input-start (point)))
 660           (insert "\nIt's been nice interacting with you!\n")
 661           (insert "Press C-c C-z to bring me back.\n"))))))
 662
 663 (defun geiser-repl--on-kill ()
 664   (geiser-repl--on-quit)
 665   (setq geiser-repl--closed-repls
 666         (remove (current-buffer) geiser-repl--closed-repls)))
 667
 668 (defun geiser-repl--input-filter (str)
 669   (not (or (and (not geiser-repl-save-debugging-history-p)
 670                 (geiser-repl--is-debugging))
 671            (string-match "^\\s *$" str)
 672            (string-match "^,quit *$" str))))
 673
 674 (defun geiser-repl--old-input ()
 675   (save-excursion
 676     (let ((end (point)))
 677       (backward-sexp)
 678       (buffer-substring (point) end))))
 679
 680 (defun geiser-repl--quit-setup ()
 681   (add-hook 'kill-buffer-hook 'geiser-repl--on-kill nil t)
 682   (set-process-sentinel (get-buffer-process (current-buffer))
 683                         'geiser-repl--sentinel))
 684
 685 \f
 686 ;;; geiser-repl mode:
 687
 688 (defun geiser-repl--bol ()
 689   (interactive)
 690   (when (= (point) (comint-bol)) (beginning-of-line)))
 691
 692 (defun geiser-repl--beginning-of-defun ()
 693   (save-restriction
 694     (narrow-to-region (geiser-repl--last-prompt-end) (point))
 695     (let ((beginning-of-defun-function nil))
 696       (beginning-of-defun))))
 697
 698 (defun geiser-repl--module-function (&optional module)
 699   (if (and module geiser-eval--get-impl-module)
 700       (funcall geiser-eval--get-impl-module module)
 701       :f))
 702
 703 (defun geiser-repl--doc-module ()
 704   (interactive)
 705   (let ((geiser-eval--get-module-function
 706          (geiser-impl--method 'find-module geiser-impl--implementation)))
 707     (geiser-doc-module)))
 708
 709 (defun geiser-repl--newline-and-indent ()
 710   (interactive)
 711   (save-restriction
 712     (narrow-to-region comint-last-input-start (point-max))
 713     (insert "\n")
 714     (lisp-indent-line)))
 715
 716 (defun geiser-repl--nesting-level ()
 717   (save-restriction
 718     (narrow-to-region (geiser-repl--last-prompt-end) (point-max))
 719     (geiser-syntax--nesting-level)))
 720
 721 (defun geiser-repl--is-input ()
 722   (not (eq (field-at-pos (point)) 'output)))
 723
 724 (defun geiser-repl--grab-input ()
 725   (let ((pos (comint-bol)))
 726     (goto-char (point-max))
 727     (insert (field-string-no-properties pos))))
 728
 729 (defun geiser-repl--send-input ()
 730   (set-marker geiser-repl--last-output-start (point-max))
 731
 732   (let* ((proc (get-buffer-process (current-buffer)))
 733          (pmark (and proc (process-mark proc)))
 734          (intxt (and pmark (buffer-substring pmark (point))))
 735          (eob (point-max)))
 736     (when intxt
 737       (and geiser-repl-forget-old-errors-p
 738            (not (geiser-repl--is-debugging))
 739            (compilation-forget-errors))
 740       (geiser-repl--prepare-send)
 741       (comint-send-input)
 742       (when (string-match "^\\s-*$" intxt)
 743         (comint-send-string proc (geiser-eval--scheme-str '(:ge no-values)))
 744         (comint-send-string proc "\n")))))
 745
 746 (defun geiser-repl--maybe-send ()
 747   (interactive)
 748   (let ((p (point)))
 749     (cond ((< p (geiser-repl--last-prompt-start))
 750            (if (geiser-repl--is-input)
 751                (geiser-repl--grab-input)
 752              (ignore-errors (compile-goto-error))))
 753           ((let ((inhibit-field-text-motion t))
 754              (when geiser-repl-send-on-return-p
 755                (end-of-line))
 756              (<= (geiser-repl--nesting-level) 0))
 757            (geiser-repl--send-input))
 758           (t (goto-char p)
 759              (if geiser-repl-auto-indent-p
 760                  (geiser-repl--newline-and-indent)
 761                (insert "\n"))))))
 762
 763 (defun geiser-repl-tab-dwim (n)
 764   "If we're after the last prompt, complete symbol or indent (if
 765 there's no symbol at point). Otherwise, go to next error in the REPL
 766 buffer."
 767   (interactive "p")
 768   (if (>= (point) (geiser-repl--last-prompt-end))
 769       (or (completion-at-point)
 770           (lisp-indent-line))
 771     (compilation-next-error n)))
 772
 773 (defun geiser-repl--previous-error (n)
 774   "Go to previous error in the REPL buffer."
 775   (interactive "p")
 776   (compilation-next-error (- n)))
 777
 778 (defun geiser-repl-clear-buffer ()
 779   "Delete the output generated by the scheme process."
 780   (interactive)
 781   (let ((inhibit-read-only t))
 782     (delete-region (point-min) (geiser-repl--last-prompt-start))
 783     (when (< (point) (geiser-repl--last-prompt-end))
 784       (goto-char (geiser-repl--last-prompt-end)))
 785     (recenter t)))
 786
 787 (define-derived-mode geiser-repl-mode comint-mode "REPL"
 788   "Major mode for interacting with an inferior scheme repl process.
 789 \\{geiser-repl-mode-map}"
 790   (scheme-mode-variables)
 791   (set (make-local-variable 'geiser-repl--last-output-start) (point-marker))
 792   (set (make-local-variable 'geiser-repl--last-output-end) (point-marker))
 793   (set (make-local-variable 'face-remapping-alist)
 794        '((comint-highlight-prompt geiser-font-lock-repl-prompt)
 795          (comint-highlight-input geiser-font-lock-repl-input)))
 796   (set (make-local-variable 'mode-line-process) nil)
 797   (set (make-local-variable 'comint-use-prompt-regexp) nil)
 798   (set (make-local-variable 'comint-prompt-read-only)
 799        geiser-repl-read-only-prompt-p)
 800   (setq comint-process-echoes nil)
 801   (set (make-local-variable 'beginning-of-defun-function)
 802        'geiser-repl--beginning-of-defun)
 803   (set (make-local-variable 'comint-input-ignoredups)
 804        geiser-repl-history-no-dups-p)
 805   (setq geiser-eval--get-module-function 'geiser-repl--module-function)
 806   (geiser-completion--setup t)
 807   (setq geiser-smart-tab-mode-string "")
 808   (geiser-smart-tab-mode t)
 809
 810   (setq-local font-lock-fontify-region-function
 811               #'geiser-repl--wrap-fontify-region-function)
 812   (setq-local font-lock-unfontify-region-function
 813               #'geiser-repl--wrap-unfontify-region-function)
 814
 815   ;; enabling compilation-shell-minor-mode without the annoying highlighter
 816   (compilation-setup t))
 817
 818 (define-key geiser-repl-mode-map "\C-d" 'delete-char)
 819 (define-key geiser-repl-mode-map "\C-m" 'geiser-repl--maybe-send)
 820 (define-key geiser-repl-mode-map [return] 'geiser-repl--maybe-send)
 821 (define-key geiser-repl-mode-map "\C-j" 'geiser-repl--newline-and-indent)
 822 (define-key geiser-repl-mode-map (kbd "TAB") 'geiser-repl-tab-dwim)
 823 (define-key geiser-repl-mode-map [backtab] 'geiser-repl--previous-error)
 824
 825 (define-key geiser-repl-mode-map "\C-a" 'geiser-repl--bol)
 826 (define-key geiser-repl-mode-map (kbd "<home>") 'geiser-repl--bol)
 827
 828 (geiser-menu--defmenu repl geiser-repl-mode-map
 829   ("Complete symbol" ((kbd "M-TAB"))
 830    completion-at-point :enable (geiser--symbol-at-point))
 831   ("Complete module name" ((kbd "C-.") (kbd "M-`"))
 832    geiser-completion--complete-module :enable (geiser--symbol-at-point))
 833   ("Edit symbol" "\M-." geiser-edit-symbol-at-point
 834    :enable (geiser--symbol-at-point))
 835   --
 836   ("Load scheme file..." "\C-c\C-l" geiser-load-file)
 837   ("Switch to module..." "\C-c\C-m" switch-to-geiser-module)
 838   ("Import module..." "\C-c\C-i" geiser-repl-import-module)
 839   ("Add to load path..." "\C-c\C-r" geiser-add-to-load-path)
 840   --
 841   ("Previous matching input" "\M-p" comint-previous-matching-input-from-input
 842    "Previous input matching current")
 843   ("Next matching input" "\M-n" comint-next-matching-input-from-input
 844    "Next input matching current")
 845   ("Previous prompt" "\C-c\C-p" geiser-repl-previous-prompt)
 846   ("Next prompt" "\C-c\C-n" geiser-repl-next-prompt)
 847   ("Previous input" "\C-c\M-p" comint-previous-input)
 848   ("Next input" "\C-c\M-n" comint-next-input)
 849   --
 850   ("Interrupt evaluation" ("\C-c\C-k" "\C-c\C-c" "\C-ck")
 851    geiser-repl-interrupt)
 852   --
 853   (mode "Autodoc mode" ("\C-c\C-da" "\C-c\C-d\C-a") geiser-autodoc-mode)
 854   ("Symbol documentation" ("\C-c\C-dd" "\C-c\C-d\C-d")
 855    geiser-doc-symbol-at-point
 856    "Documentation for symbol at point" :enable (geiser--symbol-at-point))
 857   ("Lookup symbol in manual" ("\C-c\C-di" "\C-c\C-d\C-i")
 858    geiser-doc-look-up-manual
 859    "Documentation for symbol at point" :enable (geiser--symbol-at-point))
 860   ("Module documentation" ("\C-c\C-dm" "\C-c\C-d\C-m") geiser-repl--doc-module
 861    "Documentation for module at point" :enable (geiser--symbol-at-point))
 862   --
 863   ("Clear buffer" "\C-c\M-o" geiser-repl-clear-buffer
 864    "Clean up REPL buffer, leaving just a lonely prompt")
 865   ("Kill Scheme interpreter" "\C-c\C-q" geiser-repl-exit
 866    :enable (geiser-repl--live-p))
 867   ("Restart" "\C-c\C-z" switch-to-geiser :enable (not (geiser-repl--live-p)))
 868   --
 869   (custom "REPL options" geiser-repl))
 870
 871 (define-key geiser-repl-mode-map [menu-bar completion] 'undefined)
 872
 873 \f
 874 ;;; User commands
 875
 876 (defun run-geiser (impl)
 877   "Start a new Geiser REPL."
 878   (interactive
 879    (list (geiser-repl--get-impl "Start Geiser for scheme implementation: ")))
 880   (let ((buffer (current-buffer)))
 881     (geiser-repl--start-repl impl nil)
 882     (geiser-repl--maybe-remember-scm-buffer buffer)))
 883
 884 (defalias 'geiser 'run-geiser)
 885
 886 (defun geiser-connect (impl &optional host port)
 887   "Start a new Geiser REPL connected to a remote Scheme process."
 888   (interactive
 889    (list (geiser-repl--get-impl "Connect to Scheme implementation: ")))
 890   (let ((buffer (current-buffer)))
 891     (geiser-repl--start-repl impl
 892                              (geiser-repl--read-address host port))
 893     (geiser-repl--maybe-remember-scm-buffer buffer)))
 894
 895 (defun geiser-connect-local (impl socket)
 896   "Start a new Geiser REPL connected to a remote Scheme process
 897 over a Unix-domain socket."
 898   (interactive
 899    (list (geiser-repl--get-impl "Connect to Scheme implementation: ")
 900          (expand-file-name (read-file-name "Socket file name: "))))
 901   (let ((buffer (current-buffer)))
 902     (geiser-repl--start-repl impl socket)
 903     (geiser-repl--maybe-remember-scm-buffer buffer)))
 904
 905 (make-variable-buffer-local
 906  (defvar geiser-repl--last-scm-buffer nil))
 907
 908 (defun geiser-repl--maybe-remember-scm-buffer (buffer)
 909   (when (and buffer
 910              (eq 'scheme-mode (with-current-buffer buffer major-mode))
 911              (eq major-mode 'geiser-repl-mode))
 912     (setq geiser-repl--last-scm-buffer buffer)))
 913
 914 (defun switch-to-geiser (&optional ask impl buffer)
 915   "Switch to running Geiser REPL.
 916
 917 If REPL is the current buffer, switch to the previously used
 918 scheme buffer.
 919
 920 With prefix argument, ask for which one if more than one is running.
 921 If no REPL is running, execute `run-geiser' to start a fresh one."
 922   (interactive "P")
 923   (let* ((impl (or impl geiser-impl--implementation))
 924          (in-repl (eq major-mode 'geiser-repl-mode))
 925          (in-live-repl (and in-repl (get-buffer-process (current-buffer))))
 926          (repl (unless ask
 927                  (if impl
 928                      (geiser-repl--repl/impl impl)
 929                    (or geiser-repl--repl (car geiser-repl--repls))))))
 930     (cond (in-live-repl
 931            (when (and (not (eq repl buffer))
 932                       (buffer-live-p geiser-repl--last-scm-buffer))
 933              (geiser-repl--switch-to-buffer geiser-repl--last-scm-buffer)))
 934           (repl (geiser-repl--switch-to-buffer repl))
 935           ((geiser-repl--remote-p)
 936            (geiser-connect impl (geiser-repl--host) (geiser-repl--port)))
 937           ((geiser-repl--local-p)
 938            (geiser-connect-local impl geiser-repl--address))
 939           (impl (run-geiser impl))
 940           (t (call-interactively 'run-geiser)))
 941     (geiser-repl--maybe-remember-scm-buffer buffer)))
 942
 943 (defun switch-to-geiser-module (&optional module buffer)
 944   "Switch to running Geiser REPL and try to enter a given module."
 945   (interactive)
 946   (let* ((module (or module
 947                      (geiser-completion--read-module
 948                       "Switch to module (default top-level): ")))
 949          (cmd (and module
 950                    (geiser-repl--enter-cmd geiser-impl--implementation
 951                                            module))))
 952     (unless (eq major-mode 'geiser-repl-mode)
 953       (switch-to-geiser nil nil (or buffer (current-buffer))))
 954     (geiser-repl--send cmd)))
 955
 956 (defun geiser-repl-import-module (&optional module)
 957   "Import a given module in the current namespace of the REPL."
 958   (interactive)
 959   (let* ((module (or module
 960                      (geiser-completion--read-module "Import module: ")))
 961          (cmd (and module
 962                    (geiser-repl--import-cmd geiser-impl--implementation
 963                                             module))))
 964     (switch-to-geiser nil nil (current-buffer))
 965     (geiser-repl--send cmd)))
 966
 967 (defun geiser-repl-exit (&optional arg)
 968   "Exit the current REPL.
 969 With a prefix argument, force exit by killing the scheme process."
 970   (interactive "P")
 971   (when (or (not geiser-repl-query-on-exit-p)
 972             (y-or-n-p "Really quit this REPL? "))
 973     (geiser-con--connection-deactivate geiser-repl--connection t)
 974     (let ((cmd (and (not arg)
 975                     (geiser-repl--exit-cmd geiser-impl--implementation))))
 976       (if cmd
 977           (when (stringp cmd) (geiser-repl--send cmd))
 978         (comint-kill-subjob)))))
 979
 980 (defun geiser-repl-next-prompt (n)
 981   (interactive "p")
 982   (when (> n 0)
 983     (end-of-line)
 984     (re-search-forward comint-prompt-regexp nil 'go n)))
 985
 986 (defun geiser-repl-previous-prompt (n)
 987   (interactive "p")
 988   (when (> n 0)
 989     (end-of-line 0)
 990     (when (re-search-backward comint-prompt-regexp nil 'go n)
 991       (goto-char (match-end 0)))))
 992
 993 \f
 994 ;;; Unload:
 995
 996 (defun geiser-repl--repl-list ()
 997   (let (lst)
 998     (dolist (repl geiser-repl--repls lst)
 999       (when (buffer-live-p repl)
1000         (with-current-buffer repl
1001           (push (cons geiser-impl--implementation
1002                       geiser-repl--address)
1003                 lst))))))
1004
1005 (defun geiser-repl--restore (impls)
1006   (dolist (impl impls)
1007     (when impl
1008       (condition-case err
1009           (geiser-repl--start-repl (car impl) (cdr impl))
1010         (error (message (error-message-string err)))))))
1011
1012 (defun geiser-repl-unload-function ()
1013   (dolist (repl geiser-repl--repls)
1014     (when (buffer-live-p repl)
1015       (with-current-buffer repl
1016         (let ((geiser-repl-query-on-exit-p nil)) (geiser-repl-exit))
1017         (sit-for 0.05)
1018         (kill-buffer)))))
1019
1020 \f
1021 (provide 'geiser-repl)
1022
1023 \f
1024 ;;; Initialization:
1025 ;; After providing 'geiser-repl, so that impls can use us.
1026 (mapc 'geiser-impl--load-impl geiser-active-implementations)