elisp/geiser-repl.el

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