Re: Standardizing more key bindings?

[Stefan Monnier <monnier@iro.umontreal.ca>]

> I seem to recall Stefan bringing up such a discussion a few years ago,
> the goal then being to simplify setting up a comint buffer.

FWIW, here's the code I have for that, written about 5 years ago and
never actually used, so take it with a large grain of salt.


        Stefan


;;; prog-proc.el --- Interacting from a source buffer with an inferior process  -*- lexical-binding:t -*-

;; Copyright (C) 2012  Free Software Foundation, Inc.

;; Author: (Stefan Monnier) <monnier@iro.umontreal.ca>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Prog-Proc is a package designed to complement Comint: while Comint was
;; designed originally to handle the needs of inferior process buffers, such
;; as a buffer running a Scheme repl, Comint does not actually provide any
;; functionality that links this process buffer with some source code.
;;
;; That's where Prog-Proc comes into play: it provides the usual commands and
;; key-bindings that lets the user send his code to the underlying repl.

;;; Code:


(eval-when-compile (require 'cl-lib))
(require 'comint)
(require 'compile)

(defvar prog-proc-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map [?\C-c ?\C-l] 'prog-proc-load-file)
    (define-key map [?\C-c ?\C-c] 'prog-proc-compile)
    (define-key map [?\C-c ?\C-z] 'prog-proc-switch-to)
    (define-key map [?\C-c ?\C-r] 'prog-proc-send-region)
    (define-key map [?\C-c ?\C-b] 'prog-proc-send-buffer)
    ;; FIXME: Add
    ;; (define-key map [?\M-C-x] 'prog-proc-send-defun)
    ;; (define-key map [?\C-x ?\C-e] 'prog-proc-send-last-sexp)
    ;; FIXME: Add menu.  Now, that's trickier because keymap inheritance
    ;; doesn't play nicely with menus!
    map)
  "Keymap for `prog-proc-mode'.")

(defvar-local prog-proc--buffer nil
  "The inferior-process buffer to which to send code.")

(defmacro prog-proc-define-token (name &optional parent)
  ;; FIXME: This use of cl-defstruct ends up defining needlessly the
  ;; predicate, the constructor and their respective inliners.
  ;; `(progn
  ;;    (cl-defstruct (,name
  ;;                   (:predicate nil)
  ;;                   (:copier nil)
  ;;                   (:constructor nil)
  ;;                   (:constructor ,name)
  ;;                   ,@(when parent `((:include ,parent)))))
  ;;    (defconst ,name (,name)))
  (let ((tag-sym (intern (format "cl-struct-%S" name)))
        (children-sym (intern (format "cl-struct-%S-tags" name))))
    `(progn
       (defvar ,children-sym)
       (eval-and-compile
         (cl-struct-define ',name nil ',(or parent
                                            ;; FIXME: Make a "token" parent.
                                            'cl-structure-object)
                           nil nil '((cl-tag-slot)) ',children-sym ',tag-sym t))
       (defconst ,name (vector ',tag-sym)))))

(cl-defstruct (prog-proc-descriptor
            (:constructor prog-proc-make)
            (:predicate nil)
            (:copier nil))
  (name nil :read-only t)
  (run nil :read-only t)
  (load-cmd nil :read-only t)
  (chdir-cmd nil :read-only t)
  (command-eol "\n" :read-only t)
  (compile-commands-alist nil :read-only t))

(defvar prog-proc-descriptor nil
  "Struct containing the various functions to create a new process, ...")

(defmacro prog-proc--prop (prop)
  `(,(intern (format "prog-proc-descriptor-%s" prop))
    (or prog-proc-descriptor
        ;; FIXME: Look for available ones and pick one.
        (error "Not a `prog-proc' buffer"))))
(defmacro prog-proc--call (method &rest args)
  `(funcall (prog-proc--prop ,method) ,@args))

;; The inferior process and his buffer are basically interchangeable.
;; Currently the code takes prog-proc--buffer as the main reference,
;; but all users should either use prog-proc-proc or prog-proc-buffer
;; to find the info.

(defun prog-proc-proc ()
  "Return the inferior process for the code in current buffer."
  (or (and (buffer-live-p prog-proc--buffer)
           (get-buffer-process prog-proc--buffer))
      (when (derived-mode-p 'prog-proc-mode 'prog-proc-comint-mode)
        (setq prog-proc--buffer (current-buffer))
        (get-buffer-process prog-proc--buffer))
      (let ((ppd prog-proc-descriptor)
            (buf (prog-proc--call run)))
        (with-current-buffer buf
          (if (and ppd (null prog-proc-descriptor))
              (set (make-local-variable 'prog-proc-descriptor) ppd)))
        (setq prog-proc--buffer buf)
        (get-buffer-process prog-proc--buffer))))

(defun prog-proc-buffer ()
  "Return the buffer of the inferior process."
  (process-buffer (prog-proc-proc)))

(defun prog-proc-run-repl ()
  "Start the read-eval-print process, if it's not running yet."
  (interactive)
  (ignore (prog-proc-proc)))

(defun prog-proc-switch-to ()
  "Switch to the buffer running the read-eval-print process."
  (pop-to-buffer (prog-proc-buffer)))

(defun prog-proc-send-string (proc str)
  "Send command STR to PROC, with an EOL terminator appended."
  (with-current-buffer (process-buffer proc)
    ;; FIXME: comint-send-string does not pass the string through
    ;; comint-input-filter-function, so we have to do it by hand.
    ;; Maybe we should insert the command into the buffer and then call
    ;; comint-send-input?
    (prog-proc-comint-input-filter-function nil)
    (comint-send-string proc (concat str (prog-proc--prop command-eol)))))

(defun prog-proc-load-file (file &optional and-go)
  "Load FILE into the read-eval-print process.
FILE is the file visited by the current buffer.
If prefix argument AND-GO is used, then we additionally switch
to the buffer where the process is running."
  (interactive
   (list (or buffer-file-name
             (read-file-name "File to load: " nil nil t))
         current-prefix-arg))
  (comint-check-source file)
  (let ((proc (prog-proc-proc)))
    (prog-proc-send-string proc (prog-proc--call load-cmd file))
    (when and-go (pop-to-buffer (process-buffer proc)))))

(defvar prog-proc--tmp-file nil)

(defun prog-proc-send-region (start end &optional and-go)
  "Send the content of the region to the read-eval-print process.
START..END delimit the region; AND-GO if non-nil indicate to additionally
switch to the process's buffer."
  (interactive "r\nP")
  (if (> start end) (let ((tmp end)) (setq end start) (setq start tmp))
    (if (= start end) (error "Nothing to send: the region is empty")))
  (let ((proc (prog-proc-proc))
        (tmp (make-temp-file "emacs-region")))
    (write-region start end tmp nil 'silently)
    (when prog-proc--tmp-file
      (ignore-errors (delete-file (car prog-proc--tmp-file)))
      (set-marker (cdr prog-proc--tmp-file) nil))
    (setq prog-proc--tmp-file (cons tmp (copy-marker start)))
    (prog-proc-send-string proc (prog-proc--call load-cmd tmp))
    (when and-go (pop-to-buffer (process-buffer proc)))))

(defun prog-proc-send-buffer (&optional and-go)
  "Send the content of the current buffer to the read-eval-print process.
AND-GO if non-nil indicate to additionally switch to the process's buffer."
  (interactive "P")
  (prog-proc-send-region (point-min) (point-max) and-go))

(define-derived-mode prog-proc-mode prog-mode "Prog-Proc"
  "Major mode for editing source code and interact with an interactive loop."
  )

;;; Extended comint-mode for Prog-Proc.

(defun prog-proc-chdir (dir)
  "Change the working directory of the inferior process to DIR."
  (interactive "DChange to directory: ")
  (let ((dir (expand-file-name dir))
        (proc (prog-proc-proc)))
    (with-current-buffer (process-buffer proc)
      (prog-proc-send-string proc (prog-proc--call chdir-cmd dir))
      (setq default-directory (file-name-as-directory dir)))))

(defun prog-proc-comint-input-filter-function (str)
  ;; `compile.el' doesn't know that file location info from errors should be
  ;; recomputed afresh (without using stale info from earlier compilations).
  (compilation-forget-errors)       ;Has to run before compilation-fake-loc.
  (if (and prog-proc--tmp-file (marker-buffer (cdr prog-proc--tmp-file)))
      (compilation-fake-loc (cdr prog-proc--tmp-file)
                            (car prog-proc--tmp-file)))
  str)

(defvar prog-proc-comint-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map [?\C-c ?\C-r] 'prog-proc-run-repl)
    (define-key map [?\C-c ?\C-l] 'prog-proc-load-file)
    map))

(define-derived-mode prog-proc-comint-mode comint-mode "Prog-Proc-Comint"
  "Major mode for an inferior process used to run&compile source code."
  ;; Enable compilation-minor-mode, but only after the child mode is setup
  ;; since the child-mode might want to add rules to
  ;; compilation-error-regexp-alist.
  (add-hook 'after-change-major-mode-hook #'compilation-minor-mode nil t)
  ;; The keymap of compilation-minor-mode is too unbearable, so we
  ;; need to hide most of the bindings.
  (let ((map (make-sparse-keymap)))
    (dolist (keys '([menu-bar] [follow-link]))
      ;; Preserve some of the bindings.
      (define-key map keys (lookup-key compilation-minor-mode-map keys)))
    (add-to-list 'minor-mode-overriding-map-alist
                 (cons 'compilation-minor-mode map)))

  (add-hook 'comint-input-filter-functions
            #'prog-proc-comint-input-filter-function nil t))

(defvar prog-proc--compile-command nil
  "The command used by default by `prog-proc-compile'.")

(defun prog-proc-compile (command &optional and-go)
  "Pass COMMAND to the read-eval-loop process to compile the current file.

You can then use the command \\[next-error] to find the next error message
and move to the source code that caused it.

Interactively, prompts for the command if `compilation-read-command' is
non-nil.  With prefix arg, always prompts.

Prefix arg AND-GO also means to switch to the read-eval-loop buffer afterwards."
  (interactive
   (let* ((dir default-directory)
	  (cmd "cd \"."))
     ;; Look for files to determine the default command.
     (while (and (stringp dir)
                 (progn
                   (cl-dolist (cf (prog-proc--prop compile-commands-alist))
                     (when (file-exists-p (expand-file-name (cdr cf) dir))
                       (setq cmd (concat cmd "\"; " (car cf)))
                       (cl-return nil)))
                   (not cmd)))
       (let ((newdir (file-name-directory (directory-file-name dir))))
	 (setq dir (unless (equal newdir dir) newdir))
	 (setq cmd (concat cmd "/.."))))
     (setq cmd
	   (cond
	    ((local-variable-p 'prog-proc--compile-command)
             prog-proc--compile-command)
	    ((string-match "^\\s-*cd\\s-+\"\\.\"\\s-*;\\s-*" cmd)
	     (substring cmd (match-end 0)))
	    ((string-match "^\\s-*cd\\s-+\"\\(\\./\\)" cmd)
	     (replace-match "" t t cmd 1))
	    ((string-match ";" cmd) cmd)
	    (t prog-proc--compile-command)))
     ;; code taken from compile.el
     (list (if (or compilation-read-command current-prefix-arg)
               (read-from-minibuffer "Compile command: "
				     cmd nil nil '(compile-history . 1))
             cmd))))
     ;; ;; now look for command's file to determine the directory
     ;; (setq dir default-directory)
     ;; (while (and (stringp dir)
     ;; 	    (dolist (cf (prog-proc--prop compile-commands-alist) t)
     ;; 	      (when (and (equal cmd (car cf))
     ;; 			 (file-exists-p (expand-file-name (cdr cf) dir)))
     ;; 		(return nil))))
     ;;   (let ((newdir (file-name-directory (directory-file-name dir))))
     ;;     (setq dir (unless (equal newdir dir) newdir))))
     ;; (setq dir (or dir default-directory))
     ;; (list cmd dir)))
  (set (make-local-variable 'prog-proc--compile-command) command)
  (save-some-buffers (not compilation-ask-about-save) nil)
  (let ((dir default-directory))
    (when (string-match "^\\s-*cd\\s-+\"\\([^\"]+\\)\"\\s-*;" command)
      (setq dir (match-string 1 command))
      (setq command (replace-match "" t t command)))
    (setq dir (expand-file-name dir))
    (let ((proc (prog-proc-proc))
          (eol (prog-proc--prop command-eol)))
      (with-current-buffer (process-buffer proc)
        (setq default-directory dir)
        (prog-proc-send-string
         proc (concat (prog-proc--call chdir-cmd dir)
                      ;; Strip the newline, to avoid adding a prompt.
                      (if (string-match "\n\\'" eol)
                          (replace-match " " t t eol) eol)
                      command))
        (when and-go (pop-to-buffer (process-buffer proc)))))))


\f
(provide 'prog-proc)

;;; prog-proc.el ends here