emacs-config/elisp/inferior-cc.el

;;; inferior-cc.el --- Run interpreters for cc-mode languages -*- lexical-binding: t; -*-
;;; Commentary:
;;; Code:
(require 'comint)
(require 'cl-lib)
(require 'cc-mode)
(require 'treesit)
(require 'shell)
(eval-when-compile (require 'rx))

(defgroup inferior-cc ()
  "Run interpreters for `cc-mode' languages."
  :group 'comint)

(defclass inferior-cc-interpreter ()
  ((name :type string
         :initarg :name
         :accessor inf-cc-name
         :doc "The name of this interpreter.")
   (command :type string
            :initarg :command
            :accessor inf-cc-command
            :doc "The command (program) for this interpreter.")
   (args :type (list-of string)
         :initarg :args
         :accessor inf-cc-args
         :initform nil
         :doc "Command-line arguments to pass to the interpreter.")
   (font-lock-mode :type (or null function)
                   :initarg :font-lock-mode
                   :accessor inf-cc-font-lock-mode
                   :initform nil
                   :doc "Major mode to use for font locking of the interpreter's
input. A value of nil means don't do font locking.")
   (modes :type (list-of function)
          :initarg :modes
          :accessor inf-cc-modes
          :initform nil
          :doc "The major modes that this interpreter corresponds to.")
   (exp-at-point-func :type (or function null)
                      :initarg :exp-at-point-func
                      :accessor inf-cc-exp-at-point-func
                      :initform nil
                      :doc "Function to retrieve the expression at point for
languages supported by this interpreter."))
  (:documentation "An interpreter for a `cc-mode'-like language."))

(define-widget 'inferior-cc-interpreter 'lazy
  "Interpreter for `cc-mode'-like languages."
  :offset 4
  :tag "Interpreter"
  :type '(list (string :tag "Name")
               (repeat :tag "Command line" (string :tag "Argument"))
               (choice :tag "Font lock mode"
                       (function :tag "Major mode")
                       (const :tag "None" nil))
               (repeat :tag "Major modes" (function :tag "Major mode"))
               (choice :tag "Expression at point function"
                       (function :tag "Function")
                       (const :tag "None" nil))))

(defun inf-cc--interpreter-list-to-obj (list)
  "Return LIST as a proper `inferior-cc-interpreter' object."
  (cl-destructuring-bind (name (command &rest args) font-lock-mode modes
                               exp-at-point-func)
      list
    (inferior-cc-interpreter :name name :command command
                             :args args :font-lock-mode font-lock-mode
                             :modes modes :exp-at-point-func exp-at-point-func)))

(defun inf-cc--interpreter-obj-to-list (obj)
  "Return OBJ, a proper `inferior-cc-interpreter', object as a list."
  (with-slots (name command args font-lock-mode modes exp-at-point-func) obj
    (list name (cons command args) font-lock-mode modes exp-at-point-func)))

(defun inf-cc--remove-trailing-semicolon (str)
  "Remove a trailing semicolon and whitespace from STR."
  (if (string-match (rx (* (syntax whitespace))
                        ";"
                        (* (syntax whitespace)) eos)
                    str)
      (substring str  0 (match-beginning 0))
    str))

(defun inf-cc--remove-surrounding-parens (str)
  "Remove surrounding parenthesis from STR."
  (if (string-match (rx bos (* (syntax whitespace)) "("
                        (group (* any))
                        ")" (* (syntax whitespace)) eos)
                    str)
      (match-string 1 str)
    str))

(defun inf-cc--c-c++-ts-exp-at-point ()
  "Return the expression at point in `c-ts-mode' and `c++-ts-mode' buffers."
  (unless (or (derived-mode-p 'c-ts-mode 'c++-ts-mode))
    (user-error "Major mode does not support find expressions: %s" major-mode))
  (save-excursion
    (let ((start (point)))
      (back-to-indentation)
      (unless (> (point) start)
        (goto-char start)))
    (when-let ((thing (treesit-thing-at-point "_" 'nested)))
      (inf-cc--remove-trailing-semicolon (treesit-node-text thing)))))

(defun inf-cc--java-ts-exp-at-point ()
  "Return the expression at point in `java-ts-mode' buffers."
  (unless (or (derived-mode-p 'java-ts-mode))
    (user-error "Major mode does not support find expressions: %s" major-mode))
  (save-excursion
    (let ((start (point)))
      (back-to-indentation)
      (unless (> (point) start)
        (goto-char start)))
    (let ((root (treesit-buffer-root-node)))
      (let ((node (car (or (treesit-query-range
                            root '([(expression_statement)
                                    (field_declaration)
                                    (local_variable_declaration)
                                    (import_declaration)]
                                   @exp)
                            (point) (1+ (point)))
                           (treesit-query-range
                            root '([(parenthesized_expression)
                                    (binary_expression)
                                    (update_expression)
                                    (unary_expression)]
                                   @exp)
                            (point) (1+ (point)))))))
        (inf-cc--remove-surrounding-parens
         (inf-cc--remove-trailing-semicolon
          (buffer-substring-no-properties (car node) (cdr node))))))))

(defcustom inferior-cc-interpreters
  (list (inferior-cc-interpreter :name "jshell"
                                 :command "jshell"
                                 :font-lock-mode 'java-mode
                                 :modes '(java-mode java-ts-mode)
                                 :exp-at-point-func
                                 'inf-cc--java-ts-exp-at-point)
        (inferior-cc-interpreter :name "root"
                                 :command "root"
                                 :font-lock-mode 'c++-mode
                                 :modes '(c-mode c-ts-mode c++-mode c++-ts-mode)
                                 :exp-at-point-func
                                 'inf-cc--c-c++-ts-exp-at-point))
  "List of inferior-cc interpreters."
  :type '(repeat inferior-cc-interpreter)
  :get (lambda (sym)
         (mapcar 'inf-cc--interpreter-obj-to-list (default-toplevel-value sym)))
  :set (lambda (sym newval)
         (set-default-toplevel-value
          sym (mapcar #'(lambda (elt)
                          (if (inferior-cc-interpreter-p elt)
                              elt
                            (inf-cc--interpreter-list-to-obj elt)))
                      newval)))
  :group 'inferior-cc)

(defvar-local inf-cc--obj nil
  "The current buffer's interpreter object.")
(put 'inf-cc--obj 'permanent-local t)

(defvar-local inf-cc--fontification-buffer nil
  "The fontification buffer for the current buffer.")

(defvar-local inf-cc--skip-next-lines 0
  "Number of lines of output to skip.")

(defun inf-cc--preoutput-filter-function (output)
  "Preoutput filter function for inferior cc buffers.
OUTPUT is the new text to be inserted."
  (if (<= inf-cc--skip-next-lines 0)
      output
    (let* ((lines (string-lines output))
           (cnt (length lines)))
      (if (> cnt inf-cc--skip-next-lines)
          (prog1
              (string-join (nthcdr inf-cc--skip-next-lines lines) "\n")
            (setq inf-cc--skip-next-lines 0))
        (cl-decf inf-cc--skip-next-lines cnt)
        (when (and (not (string-empty-p output))
                   (/= ?\n (elt output (1- (length output)))))
          (cl-incf inf-cc--skip-next-lines))
        ""))))

(defun inf-cc--get-fontification-buffer ()
  "Return or create the current buffer's fontification buffer."
  (if (buffer-live-p inf-cc--fontification-buffer)
      inf-cc--fontification-buffer
    (let ((buffer (generate-new-buffer
                   (format " %s-fontification-buffer" (buffer-name))))
          (obj inf-cc--obj))
      (with-current-buffer buffer
        (setq-local inf-cc--obj obj)
        (unless (and (inf-cc-font-lock-mode inf-cc--obj)
                     (derived-mode-p (inf-cc-font-lock-mode inf-cc--obj)))
          (let ((delayed-mode-hooks nil))
            (delay-mode-hooks
              (funcall (inf-cc-font-lock-mode inf-cc--obj)))))
        (when (eq c-basic-offset 'set-from-style)
          (setq-local c-basic-offset standard-indent))
        (let ((inhibit-message t))
          (indent-tabs-mode -1))
        (unless font-lock-mode
          (font-lock-mode 1)))
      (setq-local inf-cc--fontification-buffer buffer))))

(defmacro inf-cc--with-font-lock-buffer (&rest body)
  "Execute BODY in the current buffer's fortification buffer.
Note that this erases the buffer before doing anything."
  `(with-current-buffer (inf-cc--get-fontification-buffer)
     (erase-buffer)
     ,@body))

(defun inf-cc--fontify-current-input ()
  "Function called from `post-command-hook' to fontify the current input."
  (when-let (((inf-cc-font-lock-mode inf-cc--obj))
             (proc (get-buffer-process (current-buffer)))
             (start (process-mark proc))
             (end (point-max))
             (input (buffer-substring-no-properties start end))
             (fontified (inf-cc--with-font-lock-buffer
                         (insert input)
                         (font-lock-ensure)
                         (buffer-string)))
             (len (length fontified))
             (i 0))
    ;; mostly from:
    ;; `python-shell-font-lock-post-command-hook'
    (while (not (= i len))
      (let* ((props (text-properties-at i fontified))
             (change-i (or (next-property-change i fontified)
                           len)))
        (when-let ((face (plist-get props 'face)))
          (setf (plist-get props 'face) nil
                (plist-get props 'font-lock-face) face))
        (set-text-properties (+ start i) (+ start change-i) props)
        (setq i change-i)))))

(defun inf-cc--bounds-of-last-prompt ()
  "Return the bounds of the last prompt.
This returns a cons."
  (save-excursion
    (let ((end (process-mark (get-buffer-process (current-buffer)))))
      (goto-char end)
      (cons (pos-bol) end))))

(defun inf-cc--remove-extra-indentation (count)
  "Remove COUNT spaces from the start of each line."
  (save-excursion
    (goto-char (point-min))
    (while (not (eobp))
      (back-to-indentation)
      (let ((indent (- (point) (pos-bol))))
        (when (> indent count)
          (delete-char (- count))))
      (forward-line))))

(defun inf-cc--indent-line-function ()
  "`indent-line-function' for inferior cc comint buffers."
  (when (inf-cc-font-lock-mode inf-cc--obj)
    (let* ((start (process-mark (get-buffer-process (current-buffer)))))
      ;; don't indent the first line
      (unless (= (pos-bol) (save-excursion (goto-char start) (pos-bol)))
        (let* ((input (buffer-substring-no-properties start (pos-eol)))
               (prompt-size (let ((bound (inf-cc--bounds-of-last-prompt)))
                              (- (cdr bound) (car bound))))
               (col (inf-cc--with-font-lock-buffer
                     (insert input)
                     (inf-cc--remove-extra-indentation prompt-size)
                     (c-indent-line nil t)
                     (back-to-indentation)
                     (- (point) (pos-bol)))))
          (save-excursion
            (indent-line-to (+ prompt-size col)))
          (skip-syntax-forward "-"))))))

(defun inferior-cc-send-input ()
  "Like `comint-send-input', but with some extra stuff for inferior cc."
  (interactive)
  (let ((pmark (process-mark (get-buffer-process (current-buffer))))
        (end (if comint-eol-on-send (pos-eol) (point))))
    (with-restriction pmark end
      (let ((res (syntax-ppss (point-max))))
        (without-restriction
          (cond
           ;; open string
           ((cl-fourth res)
            (message "Unterminated string"))
           ;; unmatched blocks or comment
           ((or (numberp (cl-fifth res))
                (not (zerop (cl-first res)))
                ;; trailing . character
                (save-excursion
                  (end-of-line)
                  (skip-syntax-backward "-")
                  (eql (char-before) ?.)))
            (newline-and-indent))
           (t
            ;; ignore the interpreter echoing back our lines
            (setq-local inf-cc--skip-next-lines (count-lines pmark end))
            (when (= pmark end)
              (cl-incf inf-cc--skip-next-lines))
            ;; also, methods add a bunch of extra newlines
            (when (>= inf-cc--skip-next-lines 2)
              (cl-incf inf-cc--skip-next-lines (- inf-cc--skip-next-lines 2)))
            (comint-send-input))))))))

(defvar-keymap inferior-cc-shell-mode-map
  :doc "Keymap for `inferior-cc-shell-mode'."
  :parent comint-mode-map
  "RET" #'inferior-cc-send-input)

(defun inf-cc--kill-fontification-buffer ()
  "Kill the current `inf-cc--fontification-buffer'."
  (ignore-errors
    (kill-buffer inf-cc--fontification-buffer)))

(define-derived-mode inferior-cc-shell-mode comint-mode ""
  "Major mode for buffers running inferior cc interpreters.
You MUST set `inf-cc--obj' before activating this major mode."
  :interactive nil
  :group 'inferior-jshell
  :syntax-table nil
  (with-slots (name font-lock-mode) inf-cc--obj
    (setq-local comint-highlight-input nil
                indent-line-function #'inf-cc--indent-line-function
                electric-indent-chars '(?\n ?})
                mode-name (concat "Inferior " (upcase-initials name)))
    (when-let ((font-lock-mode)
               (sym (intern-soft (format "%s-syntax-table" font-lock-mode)))
               (syntax-table (symbol-value sym)))
      (set-syntax-table syntax-table)))
  (add-hook 'comint-preoutput-filter-functions
            #'inf-cc--preoutput-filter-function
            nil t)
  (add-hook 'post-command-hook
            #'inf-cc--fontify-current-input
            nil t)
  (add-hook 'kill-buffer-hook
            #'inf-cc--kill-fontification-buffer
            nil t))

(cl-defun inf-cc--find-buffer ()
  "Find and return a live inferior cc buffer for the current major mode."
  (let ((target-mode major-mode))
    (dolist (buffer (buffer-list))
      (with-current-buffer buffer
        (when (and (process-live-p (get-buffer-process buffer))
                   inf-cc--obj
                   (member target-mode (inf-cc-modes inf-cc--obj)))
          (cl-return-from inf-cc--find-buffer buffer))))))

(defun inferior-cc-eval (code)
  "Evaluate CODE in a live inferior cc buffer."
  (interactive "sEval: " inferior-cc-shell-mode)
  (let ((buffer (inf-cc--find-buffer)))
    (unless buffer
      (user-error "No live inferior cc buffer found"))
    (with-current-buffer buffer
      (let* ((start (process-mark (get-buffer-process buffer)))
             (end (point-max))
             (old (buffer-substring-no-properties start end)))
        (delete-region start end)
        (goto-char (point-max))
        (insert code)
        (goto-char (point-max))
        ;; don't save history
        (let ((comint-input-filter #'ignore))
          (inferior-cc-send-input))
        (goto-char (point-max))
        (insert old)
        (goto-char (point-max))))))

(defun inferior-cc-eval-region (start end)
  "Evaluate the current buffer from START to END in a live inferior cc buffer.
START and END default to the current region."
  (interactive "r" inferior-cc-shell-mode)
  (inferior-cc-eval (buffer-substring-no-properties start end))
  (message "Evaluated %s lines" (count-lines start end)))

(defun inferior-cc-eval-buffer ()
  "Send the current buffer to a live inferior cc buffer."
  (interactive nil inferior-cc-shell-mode)
  (inferior-cc-eval-region (point-min) (point-max))
  (message "Evaluated buffer %s" (current-buffer)))

(defun inferior-cc-eval-defun ()
  "Send the defun under point to a live inferior cc buffer."
  (interactive nil inferior-cc-shell-mode)
  (let ((bounds (bounds-of-thing-at-point 'defun)))
    (unless bounds
      (user-error "No defun under point"))
    (inferior-cc-eval-region (car bounds) (cdr bounds))
    (message "Evaluated defun (%s lines)" (count-lines (car bounds)
                                                       (cdr bounds)))))

(defun inferior-cc-eval-line ()
  "Send the line under point to a live inferior cc buffer."
  (interactive nil inferior-cc-shell-mode)
  (inferior-cc-eval-region (pos-bol) (pos-eol))
  (message "Evaluated %s" (buffer-substring (pos-bol) (pos-eol))))

(defun inferior-cc-eval-expression ()
  "Evaluate the expression under point in a live inferior cc buffer.
This only works in modes that have defined an \\=:exp-at-point-func."
  (interactive nil inferior-cc-shell-mode)
  (let ((obj (inf-cc--find-interpreter-for-mode)))
    (unless obj
      (user-error "Cannot get expression for major mode: %s" major-mode))
    (with-slots ((func exp-at-point-func)) obj
      (unless func
        (user-error "Cannot get expression for major mode: %s" major-mode))
      (let ((code (funcall func)))
        (unless code
          (user-error "No expression under point"))
        (inferior-cc-eval code)
        (message "Evaluated expression (%s lines)"
                 (1+ (cl-count ?\n code)))))))

(defun inf-cc--find-interpreter-for-mode (&optional mode)
  "Find a suitable interpreter for MODE, defaulting to `major-mode'."
  (unless mode (setq mode major-mode))
  (cl-find-if (lambda (elt)
                (with-slots (modes) elt
                  (member mode modes)))
              inferior-cc-interpreters))

(defun inf-cc--interpreter-by-name (name)
  "Find the interpreter named NAME."
  (cl-find-if (lambda (elt)
                (equal (inf-cc-name elt) name))
              inferior-cc-interpreters))

(defun inf-cc--prompt-for-interpreter ()
  "Prompt for an inferior cc interpreter."
  (inf-cc--interpreter-by-name
   (completing-read "Interpreter: "
                    (mapcar 'inf-cc-name inferior-cc-interpreters) nil t)))

(defun inf-cc--prompt-for-command (int)
  "Prompt for a command line for INT."
  (with-slots (command args) int
    (let* ((def-cmd (string-join (mapcar 'shell-quote-argument
                                         (cons command args))
                                 " "))
           (choice (read-shell-command "Command: " def-cmd)))
      (split-string-shell-command choice))))

(defun run-cc-interpreter (int &optional command)
  "Run the `cc-mode'-like interpreter INT.
Interactively, INT will be an interpreter suitable for the current
`major-mode'.  With a prefix argument, prompt for an interpreter.

If COMMAND is non-nil, it should be a list with the first element being the
program to execute and the rest of the elements being the arguments to pass to
the interpreter.  This overrides the default settings in INT.  Interactively,
prompt for COMMAND with two prefix arguments."
  (interactive (let ((int (if current-prefix-arg
                              (inf-cc--prompt-for-interpreter)
                            (or (inf-cc--find-interpreter-for-mode)
                                (inf-cc--prompt-for-interpreter)))))
                 (list int
                       (when (>= (prefix-numeric-value current-prefix-arg) 16)
                         (inf-cc--prompt-for-command int)))))
  (with-slots (name (def-cmd command) args) int
    (unless command
      (setq command (cons def-cmd args)))
    (pop-to-buffer
     (with-current-buffer (get-buffer-create (format "*%s*" name))
       (prog1 (current-buffer)
         (unless (process-live-p (get-buffer-process (current-buffer)))
           (setq-local inf-cc--obj int)
           (inferior-cc-shell-mode)
           (comint-exec (current-buffer)
                        (format "Inferior %s" (upcase-initials name))
                        (car command) nil (cdr command))))))))

(defun run-jshell (command)
  "Run JShell in a comint buffer.
COMMAND is the same as for `run-cc-interpreter', except that any prefix arg
causes the user to be prompted."
  (interactive (list (when current-prefix-arg
                       (inf-cc--prompt-for-command
                        (inf-cc--interpreter-by-name "jshell")))))
  (run-cc-interpreter (inf-cc--interpreter-by-name "jshell") command))

(defun run-root (command)
  "Run CERN root in a comint buffer.
COMMAND is the same as for `run-cc-interpreter', except that any prefix arg
causes the user to be prompted."
  (interactive (list (when current-prefix-arg
                       (inf-cc--prompt-for-command
                        (inf-cc--interpreter-by-name "root")))))
  (run-cc-interpreter (inf-cc--interpreter-by-name "root") command))

(provide 'inferior-cc)
;;; inferior-cc.el ends here