helm-comint.el

;;; helm-comint.el --- Comint prompt navigation for helm. -*- lexical-binding: t -*-

;; Copyright (C) 2019 Pierre Neidhardt <mail@ambrevar.xyz>

;; This program 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.

;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; You can bind this as follows in .emacs:
;;
;; (add-hook 'comint-mode-hook
;;           (lambda ()
;;               (define-key comint-mode-map (kbd "M-s f") 'helm-comint-prompts-all)))

;;; Code:
(require 'cl-lib)
(require 'helm)
(require 'helm-lib)
(require 'helm-help)
(require 'helm-elisp)

;;; Comint prompts
;;
(defface helm-comint-prompts-promptidx
  `((t ,@(and (>= emacs-major-version 27) '(:extend t))
       (:foreground "cyan")))
  "Face used to highlight comint prompt index."
  :group 'helm-comint-faces)

(defface helm-comint-prompts-buffer-name
  `((t ,@(and (>= emacs-major-version 27) '(:extend t))
       (:foreground "green")))
  "Face used to highlight comint buffer name."
  :group 'helm-comint-faces)

(defcustom helm-comint-prompts-promptidx-p t
  "Show prompt number."
  :group 'helm-comint
  :type 'boolean)

(defcustom helm-comint-mode-list '(comint-mode slime-repl-mode sly-mrepl-mode sql-interactive-mode)
  "Supported modes for prompt navigation.
Derived modes (e.g., Geiser's REPL) are automatically supported."
  :group 'helm-comint
  :type '(repeat (choice symbol)))

(defcustom helm-comint-next-prompt-function '((sly-mrepl-mode . (lambda ()
                                                                  (sly-mrepl-next-prompt)
                                                                  (point))))
  "Alist of (MODE . NEXT-PROMPT-FUNCTION) to use.
 If the current major mode is a key in this list, the associated
 function will be used to navigate the prompts.
 The function must return the point after the prompt.
 Otherwise (comint-next-prompt 1) will be used."
  :group 'helm-comint
  :type '(alist :key-type symbol :value-type function))

(defcustom helm-comint-max-offset 400
  "Max number of chars displayed per candidate in comint-input-ring browser.
When t, don't truncate candidate, show all.
By default it is approximatively the number of bits contained in
five lines of 80 chars each i.e 80*5.
Note that if you set this to nil multiline will be disabled, i.e
you will not have anymore separators between candidates."
  :type '(choice (const :tag "Disabled" t)
          (integer :tag "Max candidate offset"))
  :group 'helm-misc)

(defvar helm-comint-prompts-keymap
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map helm-map)
    (define-key map (kbd "C-c o")   'helm-comint-prompts-other-window)
    (define-key map (kbd "C-c C-o") 'helm-comint-prompts-other-frame)
    map)
  "Keymap for `helm-comint-prompt-all'.")

(defun helm-comint-prompts-list (mode &optional buffer)
  "List the prompts in BUFFER in mode MODE.

Return a list of (\"prompt\" (point) (buffer-name) prompt-index))
E.g. (\"ls\" 162 \"*shell*\" 3).
If BUFFER is nil, use current buffer."
  (with-current-buffer (or buffer (current-buffer))
    (when (derived-mode-p mode)
      (save-excursion
        (goto-char (point-min))
        (let (result (count 1))
          (save-mark-and-excursion
            (helm-awhile (and (not (eobp))
                              (helm-aif (alist-get major-mode helm-comint-next-prompt-function)
                                  (funcall it)
                                (comint-next-prompt 1)))
              (push (list (buffer-substring-no-properties
                           it (point-at-eol))
                          it (buffer-name) count)
                    result)
              (setq count (1+ count))))
          (nreverse result))))))

(defun helm-comint-prompts-list-all (mode)
  "List the prompts of all buffers in mode MODE.
See `helm-comint-prompts-list'."
  (cl-loop for b in (buffer-list)
           append (helm-comint-prompts-list mode b)))

(defun helm-comint-prompts-transformer (candidates &optional all)
  ;; ("ls" 162 "*shell*" 3) => ("*shell*:3:ls" . ("ls" 162 "*shell*" 3))
  (cl-loop for (prt pos buf id) in candidates
           collect `(,(concat
                       (when all
                         (concat (propertize
                                  buf
                                  'face 'helm-comint-prompts-buffer-name)
                                 ":"))
                       (when helm-comint-prompts-promptidx-p
                         (concat (propertize
                                  (number-to-string id)
                                  'face 'helm-comint-prompts-promptidx)
                                 ":"))
                       prt)
                      . ,(list prt pos buf id))))

(defun helm-comint-prompts-all-transformer (candidates)
  (helm-comint-prompts-transformer candidates t))

(cl-defun helm-comint-prompts-goto (candidate &optional (action 'switch-to-buffer))
  ;; Candidate format: ("ls" 162 "*shell*" 3)
  (let ((buf (nth 2 candidate)))
    (unless (and (string= (buffer-name) buf)
                 (eq action 'switch-to-buffer))
      (funcall action buf))
    (goto-char (nth 1 candidate))
    (recenter)))

(defun helm-comint-prompts-goto-other-window (candidate)
  (helm-comint-prompts-goto candidate 'switch-to-buffer-other-window))

(defun helm-comint-prompts-goto-other-frame (candidate)
  (helm-comint-prompts-goto candidate 'switch-to-buffer-other-frame))

(defun helm-comint-prompts-other-window ()
  (interactive)
  (with-helm-alive-p
    (helm-exit-and-execute-action 'helm-comint-prompts-goto-other-window)))
(put 'helm-comint-prompts-other-window 'helm-only t)

(defun helm-comint-prompts-other-frame ()
  (interactive)
  (with-helm-alive-p
    (helm-exit-and-execute-action 'helm-comint-prompts-goto-other-frame)))
(put 'helm-comint-prompts-other-frame 'helm-only t)

;;;###autoload
(defun helm-comint-prompts ()
  "Pre-configured `helm' to browse the prompts of the current comint buffer."
  (interactive)
  (if (apply 'derived-mode-p helm-comint-mode-list)
      (helm :sources
            (helm-build-sync-source "Comint prompts"
              :candidates (helm-comint-prompts-list major-mode)
              :candidate-transformer 'helm-comint-prompts-transformer
              :action '(("Go to prompt" . helm-comint-prompts-goto)))
            :buffer "*helm comint prompts*")
    (message "Current buffer is not a comint buffer")))

;;;###autoload
(defun helm-comint-prompts-all ()
  "Pre-configured `helm' to browse the prompts of all comint sessions."
  (interactive)
  (if (apply 'derived-mode-p helm-comint-mode-list)
      (helm :sources
            (helm-build-sync-source "All comint prompts"
              :candidates (helm-comint-prompts-list-all major-mode)
              :candidate-transformer 'helm-comint-prompts-all-transformer
              :action (quote (("Go to prompt" . helm-comint-prompts-goto)
                              ("Go to prompt in other window `C-c o`" .
                               helm-comint-prompts-goto-other-window)
                              ("Go to prompt in other frame `C-c C-o`" .
                               helm-comint-prompts-goto-other-frame)))
              :keymap helm-comint-prompts-keymap)
            :buffer "*helm comint all prompts*")
    (message "Current buffer is not a comint buffer")))

;;; Comint history
;;
;;
(defun helm-comint-input-ring-action (candidate)
  "Default action for comint history."
  (with-helm-current-buffer
    (delete-region (comint-line-beginning-position) (point-max))
    (insert candidate)))

(defvar helm-source-comint-input-ring
  (helm-build-sync-source "Comint history"
    :candidates (lambda ()
                  (with-helm-current-buffer
                    (cl-loop for elm in (ring-elements comint-input-ring)
                             unless (string= elm "")
                             collect elm)))
    :action 'helm-comint-input-ring-action
    ;; Multiline does not work for `shell' because of an Emacs bug.
    ;; It works in other REPLs like Geiser.
    :multiline 'helm-comint-max-offset)
  "Source that provides Helm completion against `comint-input-ring'.")

;;;###autoload
(defun helm-comint-input-ring ()
  "Preconfigured `helm' that provide completion of `comint' history."
  (interactive)
  (when (or (derived-mode-p 'comint-mode)
            (member major-mode helm-comint-mode-list))
    (helm :sources 'helm-source-comint-input-ring
          :input (buffer-substring-no-properties (comint-line-beginning-position)
                                                 (point-at-eol))
          :buffer "*helm comint history*")))

(provide 'helm-comint)

;; Local Variables:
;; byte-compile-warnings: (not obsolete)
;; coding: utf-8
;; indent-tabs-mode: nil
;; End:

;;; helm-comint.el ends here