generic-repl.el

   1 ;;; generic-repl.el -- Mode for any-language REPL (stolen from Slime).
   2
   3 ;;; License
   4 ;;     Copyright (C) 2004 Sean O'Rourke; mostly copied from Slime,
   5 ;;     which is Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut
   6 ;;     Eller
   7 ;;
   8 ;;     This program is free software; you can redistribute it and/or
   9 ;;     modify it under the terms of the GNU General Public License as
  10 ;;     published by the Free Software Foundation; either version 2 of
  11 ;;     the License, or (at your option) any later version.
  12 ;;
  13 ;;     This program is distributed in the hope that it will be useful,
  14 ;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 ;;     GNU General Public License for more details.
  17 ;;
  18 ;;     You should have received a copy of the GNU General Public
  19 ;;     License along with this program; if not, write to the Free
  20 ;;     Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  21 ;;     MA 02111-1307, USA.
  22
  23 \f
  24 ;; This mode is designed to provide a comfortable REPL to something
  25 ;; with only the ability to evaluate a string and return the result as
  26 ;; a string (see the documentation for ``repl-supported-modes'' for
  27 ;; details).
  28 ;;
  29 ;; The REPL uses some markers to separate input from output.  The
  30 ;; usual configuration is as follows:
  31 ;;
  32 ;;    ... output ...    ... result ...    prompt> ... input ...
  33 ;;    ^            ^                      ^       ^           ^
  34 ;;    output-start output-end  prompt-start       input-start input-end
  35 ;;
  36 ;; output-start and input-start are right inserting markers;
  37 ;; output-end and input-end left inserting.
  38 ;;
  39 ;; We maintain the following invariant:
  40 ;;
  41 ;;  output-start <= output-end <= input-start <= input-end.
  42
  43 ;; Small helper.
  44 (defun repl-make-variables-buffer-local (&rest variables)
  45   (mapcar #'make-variable-buffer-local variables))
  46
  47 (repl-make-variables-buffer-local
  48  ;; Local variables in the REPL buffer.
  49  (defvar repl-input-history '()
  50    "History list of strings read from the REPL buffer.")
  51
  52  (defvar repl-input-history-position 0)
  53
  54  (defvar repl-prompt-start-mark)
  55  (defvar repl-input-start-mark)
  56  (defvar repl-input-end-mark)
  57  (defvar repl-last-input-start-mark)
  58 ;;; Stream output
  59  (defvar repl-output-start nil
  60    "Marker for the start of the output for the evaluation.")
  61  (defvar repl-output-end nil
  62    "Marker for end of output. New output is inserted at this mark.")
  63
  64 ;;; Handlers:
  65  (defvar repl-eval-func nil
  66    "Function to call to evaluate text from the REPL.")
  67  (defvar repl-eval-async-func nil
  68    "Function to call to evaluate text from the REPL asynchronously.")
  69  (defvar repl-get-package-func nil
  70    "Function to call to change the package in which code is evaluated.")
  71  (defvar repl-set-package-func nil
  72    "Function to retrieve the package in which code is evaluated.")
  73  (defvar repl-input-complete-func nil
  74    "Function to tell if the input forms a complete, evaluable
  75    statement/expression.")
  76  (defvar repl-completion-func nil
  77    "Function to complete the symbol at point.")
  78  (defvar repl-header-func nil
  79    "Function to generate extra header information.")
  80  (defvar repl-cd-func nil
  81    "Function to change inferior process working directory.")
  82  )
  83
  84 (defvar repl-supported-modes nil
  85   "An alist of languages supported by generic-repl mode.  Each
  86 entry's car should be a language's name as a string, while the
  87 cdr should be a plist of configuration options.  A mode is
  88 required to supply
  89   :eval           a synchronous evaluation function, which should
  90                   accept a single string, and either return a
  91                   string or throw an error.
  92   :eval-async     an asynchronous evaluation function, which should
  93                   accept a string and a function to be called one
  94                   or more times with output.  Calling this
  95                   function with a nil argument indicates end of
  96                   output.
  97
  98 It may optionally supply any of:
  99   :map            base keymap
 100   :init           initialize state after REPL starts up.
 101   :get-package    return package in which forms are evaluated
 102   :set-package    change default evaluation package
 103   :expression-p   test whether the input forms a complete expression
 104   :complete       function to complete symbol at point
 105   :header         return additional information to display in header-line
 106   :cd             change evaluation directory
 107   :comment-start  single-line comment starting character, used
 108                   to comment out messages from generic-repl.
 109 ")
 110
 111 (defun generic-repl (lang)
 112 "Start a generic repl for language LANG, which must be defined in
 113 ``repl-supported-modes''.  Interactively, prompt for LANG."
 114   (interactive
 115    (list (completing-read "Sublanguage: " repl-supported-modes)))
 116   (assert (assoc lang repl-supported-modes))
 117   (switch-to-buffer (get-buffer-create (format "*%s-interaction*" lang)))
 118   (repl-mode lang))
 119
 120 (defun repl-mode (x)
 121   "Major mode for interacting with a X interpreter in X-mode."
 122   (let ((defn (cdr (assoc x repl-supported-modes))))
 123     (assert (and (or (plist-get defn :eval)
 124                      (plist-get defn :eval-async))
 125                  (not (and (plist-get defn :eval)
 126                            (plist-get defn :eval-async))))
 127             t "Must specify sync XOR async evaluation function.")
 128     (setq
 129      major-mode 'repl-mode
 130      comment-start (plist-get defn :comment-start)
 131      repl-eval-func (plist-get defn :eval)
 132      repl-eval-async-func (plist-get defn :eval-async)
 133      repl-get-package-func (plist-get defn :get-package)
 134      repl-set-package-func (plist-get defn :set-package)
 135      repl-input-complete-func (plist-get defn :expression-p)
 136      repl-completion-func (plist-get defn :complete)
 137      repl-header-func (plist-get defn :header)
 138      repl-cd-func (plist-get defn :cd)
 139      mode-name (format "%s-REPL" x)
 140      )
 141     (use-local-map (repl-make-keymap
 142                     (if (plist-get defn :map)
 143                         (symbol-value (plist-get defn :map))
 144                         nil)))
 145     (dolist (markname (list 'repl-output-start
 146                             'repl-output-end
 147                             'repl-prompt-start-mark
 148                             'repl-input-start-mark
 149                             'repl-input-end-mark
 150                             'repl-last-input-start-mark))
 151       (set markname (make-marker))
 152       (set-marker (symbol-value markname) (point)))
 153     (set-marker-insertion-type repl-input-end-mark t)
 154     (set-marker-insertion-type repl-output-end t)
 155     (set-marker-insertion-type repl-prompt-start-mark t)
 156     (repl-insert-prompt "" 0)
 157     (repl-set-header)
 158     (if (plist-get defn :init)
 159         (funcall (plist-get defn :init)))))
 160
 161 (defun repl-make-keymap (parent)
 162   (let ((kmap (make-sparse-keymap)))
 163     (set-keymap-parent kmap parent)
 164     (dolist (kv '(("\C-m" repl-return)
 165                   ("\C-j" repl-newline-and-indent)
 166                   ("\C-a" repl-bol)
 167                   ("\C-e" repl-eol)
 168                   ("\M-p" repl-previous-input)
 169                   ("\M-n" repl-next-input)
 170                   ("\M-r" repl-previous-matching-input)
 171                   ("\M-s" repl-next-matching-input)
 172                   ([tab] repl-complete-symbol)
 173                   ("\C-c\C-o" repl-clear-output)
 174                   ("\C-c\C-t" repl-clear-buffer)
 175                   ("\C-c\C-n" repl-next-prompt)
 176                   ("\C-c\C-p" repl-previous-prompt)
 177                   ("\M-\C-a" repl-beginning-of-defun)
 178                   ("\M-\C-e" repl-end-of-defun)))
 179       (define-key kmap (car kv) (cadr kv)))
 180     kmap))
 181
 182 (defun repl-complete-symbol ()
 183   (interactive)
 184   (if (fboundp repl-completion-func)
 185       (funcall repl-completion-func)))
 186
 187 (defmacro repl-propertize-region (props &rest body)
 188   (let ((start (gensym)))
 189     `(let ((,start (point)))
 190        (prog1 (progn ,@body)
 191          (add-text-properties ,start (point) ,props)))))
 192
 193 (put 'repl-propertize-region 'lisp-indent-function 1)
 194
 195 (defsubst repl-insert-propertized (props &rest args)
 196   "Insert all ARGS and then add text-PROPS to the inserted text."
 197   (repl-propertize-region props (apply #'insert args)))
 198
 199 (defface repl-output-face
 200   '((t (:inherit font-lock-string-face)))
 201   "Face for output in the REPL."
 202   :group 'repl)
 203
 204 (defface repl-input-face
 205   '((t (:bold t)))
 206   "Face for previous input in the REPL."
 207   :group 'repl)
 208
 209 (defface repl-result-face
 210   '((t ()))
 211   "Face for the result of an evaluation in the REPL."
 212   :group 'repl)
 213
 214 (defun repl-insert-prompt (result &optional time)
 215   "Goto to point max, insert RESULT and the prompt.  Set
 216 repl-output-end to start of the inserted text repl-input-start to
 217 end end."
 218   (goto-char (point-max))
 219   (let ((start (point)))
 220     (unless (bolp) (insert "\n"))
 221     (repl-insert-propertized '(face repl-result-face) result)
 222     (unless (bolp) (insert "\n"))
 223     (let ((prompt-start (point)))
 224       (repl-propertize-region
 225           '(face font-lock-keyword-face
 226                  read-only t
 227                  intangible t
 228                  repl-prompt t
 229                  ;; emacs stuff
 230                  rear-nonsticky (repl-prompt read-only face intangible)
 231                  ;; xemacs stuff
 232                  start-open t end-open t)
 233         (insert (if (fboundp repl-get-package-func)
 234                     (funcall repl-get-package-func)
 235                     "") "> "))
 236       (set-marker repl-output-end start)
 237       (set-marker repl-prompt-start-mark prompt-start)
 238       (repl-mark-input-start)
 239       (let ((time (or time 0.2)))
 240         (cond ((zerop time)
 241                (repl-move-output-mark-before-prompt (current-buffer)))
 242               (t
 243                (run-at-time time nil 'repl-move-output-mark-before-prompt
 244                             (current-buffer))))))))
 245
 246 (defun repl-move-output-mark-before-prompt (buffer)
 247   (when (buffer-live-p buffer)
 248     (with-current-buffer buffer
 249       (save-excursion
 250         (goto-char repl-prompt-start-mark)
 251         (repl-mark-output-start)))))
 252
 253 (defun repl-current-input ()
 254   "Return the current input as string.  The input is the region from
 255 after the last prompt to the end of buffer."
 256   (buffer-substring-no-properties
 257    repl-input-start-mark
 258    (save-excursion
 259      (goto-char repl-input-end-mark)
 260      (when (eq (char-before) ?\n)
 261        (backward-char 1))
 262      (point))))
 263
 264 (defun repl-add-to-input-history (string)
 265   (when (and (plusp (length string))
 266              (eq ?\n (aref string (1- (length string)))))
 267     (setq string (substring string 0 -1)))
 268   (unless (equal string (car repl-input-history))
 269     (push string repl-input-history))
 270   (setq repl-input-history-position -1))
 271
 272 (defun repl-send-string (string)
 273   (repl-add-to-input-history string)
 274 ;;  (with-current-buffer (repl-output-buffer)
 275   (if repl-eval-async-func
 276       (funcall repl-eval-async-func string
 277                (lexical-let ((buf (current-buffer)))
 278                  (lambda (&optional string)
 279                    (with-current-buffer buf
 280                      (cond
 281                        (string (goto-char (point-max))
 282                                (repl-insert-propertized
 283                                 '(face repl-result-face)
 284                                 string))
 285                        (t (repl-insert-prompt "" 0)))))))
 286       (condition-case err
 287           (repl-insert-prompt (funcall repl-eval-func string))
 288         (error (repl-comment (format "ERROR: %s" (cdr err)))
 289                (repl-insert-prompt "" 0)))))
 290
 291 (defun repl-comment (str)
 292   (let ((beg (point)))
 293     (insert str)
 294     (comment-region beg (point))))
 295
 296 (defun repl-show-abort ()
 297 ;;   (with-current-buffer (repl-output-buffer)
 298     (repl-with-output-end-mark
 299      (unless (bolp) (insert "\n"))
 300      (repl-comment "Evaluation aborted\n")))
 301
 302 (defun repl-mark-input-start ()
 303   (set-marker repl-last-input-start-mark
 304               (marker-position repl-input-start-mark))
 305   (set-marker repl-input-start-mark (point) (current-buffer))
 306   (set-marker repl-input-end-mark (point) (current-buffer)))
 307
 308 (defun repl-mark-output-start ()
 309   (set-marker repl-output-start (point))
 310   (set-marker repl-output-end (point)))
 311
 312 (defun repl-mark-output-end ()
 313   (add-text-properties repl-output-start repl-output-end
 314                        '(face repl-output-face rear-nonsticky (face))))
 315
 316 (defun repl-bol ()
 317   "Go to the beginning of line or the prompt."
 318   (interactive)
 319   (if (and (>= (point) repl-input-start-mark)
 320            (repl-same-line-p (point) repl-input-start-mark))
 321       (goto-char repl-input-start-mark)
 322     (beginning-of-line 1)))
 323
 324 (defun repl-eol ()
 325   "Go to the end of line or the prompt."
 326   (interactive)
 327   (if (and (<= (point) repl-input-end-mark)
 328            (repl-same-line-p (point) repl-input-end-mark))
 329       (goto-char repl-input-end-mark)
 330     (end-of-line 1)))
 331
 332 (defun repl-in-input-area-p ()
 333    (and (<= repl-input-start-mark (point))
 334         (<= (point) repl-input-end-mark)))
 335
 336 (defun repl-beginning-of-defun ()
 337   "Move to beginning of defun."
 338   (interactive)
 339   (if (repl-in-input-area-p)
 340       (goto-char repl-input-start-mark)
 341     (beginning-of-defun)))
 342
 343 (defun repl-end-of-defun ()
 344   "Move to next of defun."
 345   (interactive)
 346   (if (repl-in-input-area-p)
 347       (goto-char repl-input-end-mark)
 348     (end-of-defun)))
 349
 350 (defun repl-at-prompt-end-p ()
 351   (and (get-char-property (max 1 (1- (point))) 'repl-prompt)
 352        (not (get-char-property (point) 'repl-prompt))))
 353
 354 (defun repl-find-prompt (move)
 355   (let ((origin (point)))
 356     (loop (funcall move)
 357           (when (or (repl-at-prompt-end-p) (bobp) (eobp))
 358             (return)))
 359     (unless (repl-at-prompt-end-p)
 360       (goto-char origin))))
 361
 362 (defmacro with-lexical-bindings (variables &rest body)
 363   "Execute BODY with VARIABLES in lexical scope."
 364   `(lexical-let ,(mapcar (lambda (variable) (list variable variable))
 365                          variables)
 366      ,@body))
 367
 368 (put 'with-lexical-bindings 'lisp-indent-function 1)
 369
 370 (defun repl-search-property-change-fn (prop &optional backward)
 371   (with-lexical-bindings (prop)
 372     (if backward
 373         (lambda ()
 374           (goto-char
 375            (previous-single-char-property-change (point) prop)))
 376         (lambda ()
 377           (goto-char
 378            (next-single-char-property-change (point) prop))))))
 379
 380 (defun repl-previous-prompt ()
 381   "Move backward to the previous prompt."
 382   (interactive)
 383   (repl-find-prompt
 384    (repl-search-property-change-fn 'repl-prompt t)))
 385
 386 (defun repl-next-prompt ()
 387   "Move forward to the next prompt."
 388   (interactive)
 389   (repl-find-prompt
 390    (repl-search-property-change-fn 'repl-prompt)))
 391
 392 (defun repl-return (&optional force)
 393   "Evaluate the current input string, or insert a newline.
 394 Send the current input only if a whole expression has been
 395 entered, or if prefix argument is suppled."
 396   (interactive)
 397   (assert (<= (point) repl-input-end-mark))
 398   (cond
 399     (force (repl-send-input) (insert "\n"))
 400     ((repl-input-complete-p repl-input-start-mark repl-input-end-mark)
 401      (goto-char repl-input-end-mark)
 402      (insert "\n")
 403      (repl-send-input))
 404     (t (repl-newline-and-indent);;  (message "[input not complete]")
 405        )))
 406
 407 (defun repl-input-complete-p (beg end)
 408   (if (fboundp repl-input-complete-func)
 409       (funcall repl-input-complete-func beg end)
 410       t))
 411
 412 (defun repl-send-input ()
 413   "Goto to the end of the input and send the current input."
 414   (let ((input (repl-current-input)))
 415     (goto-char repl-input-end-mark)
 416     (add-text-properties repl-input-start-mark (point)
 417                          '(face repl-input-face rear-nonsticky (face)))
 418     (repl-mark-output-start)
 419     (repl-mark-input-start)
 420     (repl-send-string (concat input "\n"))))
 421
 422 (defun repl-newline-and-indent ()
 423   "Insert a newline, then indent the next line.
 424 Restrict the buffer from the prompt for indentation, to avoid being
 425 confused by strange characters (like unmatched quotes) appearing
 426 earlier in the buffer."
 427   (interactive)
 428   (save-restriction
 429     (narrow-to-region repl-prompt-start-mark (point-max))
 430     (insert "\n")
 431     (indent-according-to-mode)
 432     ))
 433
 434 (defun repl-delete-current-input ()
 435   (delete-region repl-input-start-mark repl-input-end-mark))
 436
 437 (defun repl-replace-input (string)
 438   (repl-delete-current-input)
 439   (insert-and-inherit string))
 440
 441 (defun repl-input-line-beginning-position ()
 442   (save-excursion
 443     (goto-char repl-input-start-mark)
 444     (line-beginning-position)))
 445
 446 (defun repl-clear-buffer ()
 447   (interactive)
 448   (set-marker repl-last-input-start-mark nil)
 449   (let ((inhibit-read-only t))
 450     (delete-region (point-min) (repl-input-line-beginning-position))))
 451
 452 (defun repl-clear-output ()
 453   (interactive)
 454   (let ((start (save-excursion
 455                  (repl-previous-prompt)
 456                  (point)))
 457         (end (1- (repl-input-line-beginning-position))))
 458     (when (< start end)
 459       (delete-region start end)
 460       (save-excursion
 461         (goto-char start)
 462         (repl-comment "output flushed\n")))))
 463
 464 (defun repl-same-line-p (pos1 pos2)
 465   "Return true if buffer positions PoS1 and POS2 are on the same line."
 466   (save-excursion (goto-char (min pos1 pos2))
 467                   (not (search-forward "\n" (max pos1 pos2) t))))
 468
 469 (defun repl-set-package (package)
 470   "Set the package of the REPL buffer to PACKAGE."
 471   (interactive "sPackage: ")
 472 ;;   (with-current-buffer (repl-output-buffer)
 473     (let ((unfinished-input (repl-current-input)))
 474       (when (fboundp repl-set-package-func)
 475         (funcall repl-set-package-func package))
 476       (repl-insert-prompt "" 0)
 477       (insert unfinished-input)))
 478
 479 ;;;;; History
 480
 481 (defvar repl-history-pattern nil
 482   "The regexp most recently used for finding input history.")
 483
 484 (defun repl-history-replace (direction regexp)
 485   "Replace the current input with the next line in DIRECTION matching REGEXP.
 486 DIRECTION is 'forward' or 'backward' (in the history list)."
 487   (let* ((step (ecase direction
 488                  (forward -1)
 489                  (backward 1)))
 490          (history-pos0 repl-input-history-position))
 491     (setq repl-history-pattern regexp)
 492     ;; Loop through the history list looking for a matching line
 493     (loop for pos = (+ history-pos0 step) then (+ pos step)
 494           while (and (<= 0 pos)
 495                      (< pos (length repl-input-history)))
 496           do (let ((string (nth pos repl-input-history)))
 497                (when (and (string-match regexp string)
 498                           (not (string= string (repl-current-input))))
 499                  (repl-replace-input string)
 500                  (setq repl-input-history-position pos)
 501                  (return)))
 502           finally (message "End of history; no matching item"))))
 503
 504 (defun repl-matching-input-regexp ()
 505   (if (memq last-command
 506             '(repl-previous-input repl-next-input))
 507       repl-history-pattern
 508     (concat "^" (regexp-quote (repl-current-input)))))
 509
 510 (defun repl-previous-input ()
 511   (interactive)
 512   (repl-history-replace 'backward (repl-matching-input-regexp)))
 513
 514 (defun repl-next-input ()
 515   (interactive)
 516   (repl-history-replace 'forward (repl-matching-input-regexp)))
 517
 518 (defun repl-previous-matching-input (regexp)
 519   (interactive "sPrevious element matching (regexp): ")
 520   (repl-history-replace 'backward regexp))
 521
 522 (defun repl-next-matching-input (regexp)
 523   (interactive "sNext element matching (regexp): ")
 524   (repl-history-replace 'forward regexp))
 525
 526 (defun repl-set-header (&optional msg)
 527 "Update the header line to display MSG.  If MSG is nil, then show
 528 the current working directory instead."
 529   (when (boundp 'header-line-format)
 530     (setq header-line-format
 531           (format "%s  %s"
 532                   (if (fboundp repl-header-func)
 533                       (funcall repl-header-func)
 534                       "")
 535                   (or msg (abbreviate-file-name default-directory))))))
 536
 537 (defun repl-cd (dir &optional name)
 538   "Change buffer and (optionally) process working directory to DIR."
 539   (interactive "d")
 540   (with-current-buffer
 541       (if name (get-buffer (format "*%s-interaction*" name)) (current-buffer))
 542     (setq default-directory dir)
 543     (if (fboundp repl-cd-func)
 544         (funcall repl-cd-func (expand-file-name dir)))
 545     (repl-set-header)))
 546
 547
 548 (provide 'generic-repl)
 549 ;;; generic-repl.el ends here