path: root/emacs/.emacs.d/lisp/my/my-prog.el

;;; my-prog.el -- Programming related extensions for emacs core -*- lexical-binding: t -*-

;; Copyright (C) 2023 Free Software Foundation.

;; Author: Yuchen Pei <id@ypei.org>
;; Package-Requires: ((emacs "28.2"))

;; This file is part of dotfiles.

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

;; dotfiles 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 Affero General
;; Public License for more details.

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

;;; Commentary:

;; Programming related extensions for emacs core. Covers comint,
;; shell, eshell, elisp, prog-mode, c, c++, etc.

;;; Code:

;;; comint, shell, eshell
(defvar comint-buffer-list nil)
(setq display-buffer-alist
      '(("\\*shell\\*.*" . (display-buffer-same-window))))

(defun my-shell-with-directory (dir)
  "Starts a new shell with prompted directory as the cwd"
  (interactive (list
		            (read-directory-name "Current dir: ")))
  (let ((tmp-dir default-directory)
	      (old-buffer (current-buffer)))
    (setq default-directory dir)
    (shell (generate-new-buffer-name "*shell*"))
    (with-current-buffer old-buffer (setq default-directory tmp-dir))))

(defun my-comint-send-input-and-return-prompt ()
  (interactive)
  (comint-send-input)
  (comint-previous-prompt 1)
  (recenter 0 t))

;; FIXME: not working properly
(defun my-restart-shell ()
  (interactive)
  (ignore-error (comint-send-eof))
  (shell (current-buffer))
  (message "Shell restarted!"))

(defun my-shell-disable-company-if-remote () 
  (when (and (fboundp 'company-mode)
             (file-remote-p default-directory))
    (company-mode -1)))

(defun my-eshell-insert-prompt-prefix ()
  (interactive)
  (let ((prompt (funcall eshell-prompt-function)))
    (string-match "\\(^.*:\\).*$" prompt)
    (when (match-string 1 prompt)
      (insert (match-string 1 prompt)))))

(defun my-eshell-send-input-and-return-prompt ()
  (interactive)
  (eshell-send-input)
  (eshell-previous-prompt 1))

;;; c
(defun my-c-set-compile-command ()
  (unless (file-exists-p "Makefile")
    (setq compile-command
          (let ((file (file-name-nondirectory buffer-file-name)))
            (format "%s -o %s %s %s %s"
		                ;;"%s -c -o %s.o %s %s %s"
                    (or (getenv "CC") "gcc")
                    (file-name-sans-extension file)
                    (or (getenv "CPPFLAGS") "-DDEBUG=9")
                    (or (getenv "CFLAGS")
				                "-ansi -pedantic -Wall -g")
			              file)))))

(defun my-c-switch-between-header-and-source ()
  "Switch between a c/c++ header (.h) and its corresponding source (.c/.cpp/.cc)."
  (interactive)
  (let ((bse (file-name-sans-extension buffer-file-name))
        (ext (downcase (file-name-extension buffer-file-name)))
        (new-file))
    (cond
     ;; first condition - the extension is "h"
     ((equal ext "h")
      (cond ((file-exists-p (setq new-file (concat bse ".c")))
             (find-file new-file))
            ((file-exists-p (setq new-file (concat bse ".cpp")))
             (find-file new-file))
            ((file-exists-p (setq new-file (concat bse ".cc")))
             (find-file new-file))))
     ;; second condition - the extension is "c" or "cpp"
     ((member ext '("c" "cpp" "cc"))
      (when (file-exists-p (setq new-file (concat bse ".h")))
            (find-file new-file))))))

;;; To override `xref-query-replace-in-results'.
(defun my-xref-query-replace-in-results (from to)
  "Perform interactive replacement of FROM with TO in all displayed xrefs.

This function interactively replaces FROM with TO in the names of the
references displayed in the current *xref* buffer.

When called interactively, it uses '.*' as FROM, which means replace
the whole name, and prompts the user for TO.
If invoked with prefix argument, it prompts the user for both FROM and TO.

As each match is found, the user must type a character saying
what to do with it.  Type SPC or `y' to replace the match,
DEL or `n' to skip and go to the next match.  For more directions,
type \\[help-command] at that time.

Note that this function cannot be used in *xref* buffers that show
a partial list of all references, such as the *xref* buffer created
by \\[xref-find-definitions] and its variants, since those list only
some of the references to the identifiers."
  (interactive
   (let* ((fr
           (if current-prefix-arg
               (read-regexp "Query-replace (regexp)" ".*")
             "\\(.*\\)"))
          (prompt (if current-prefix-arg
                      (format "Query-replace (regexp) %s with: " fr)
                    "Query-replace all matches with: ")))
     (list fr (read-regexp prompt))))
  (let* (item xrefs iter)
    (save-excursion
      (while (setq item (xref--search-property 'xref-item))
        (when (xref-match-length item)
          (push item xrefs))))
    (unwind-protect
        (progn
          (goto-char (point-min))
          (setq iter (xref--buf-pairs-iterator (nreverse xrefs)))
          (xref--query-replace-1 from to iter))
      (funcall iter :cleanup))))

(defun my-set-tab-width-to-8 ()
  (interactive)
  (setq tab-width 8))

(defun my-toggle-debug-on-error-quit (arg)
  (interactive "P")
  (if arg
      (toggle-debug-on-quit)
    (toggle-debug-on-error))
  )

(require 'my-buffer)

(defun my-switch-or-create-shell-buffer (arg)
  "Switch to or create a shell buffer.

If there's no buffer with shell mode, or with a prefix-arg,
create a shell buffer using `my-shell-with-directory'"
  (interactive "P")
  (if (or arg
          (not (seq-filter
                (lambda (buffer)
                  (with-current-buffer buffer
                    (derived-mode-p 'shell-mode)))
                (buffer-list))))
      (call-interactively 'my-shell-with-directory)
    (my-buffer-quick-major-mode 'shell-mode)))

;;; gdb
(require 'gdb-mi)
(require 'gud)
(require 'org)
(defun my-org-backtrace-region (beg end)
  "Convert selected backtrace to org links and copy the result to kill ring.

With a prefix arg, convert from bottom to top."
  (let ((bt (buffer-substring-no-properties beg end))
        (case-fold-search nil)
        (results) (func-name))
    (with-temp-buffer
      (insert bt)
      (goto-char (point-min))
      ;; remove paging lines
      (flush-lines "^--.*--$")
      (goto-char (point-min))
      (while (re-search-forward "^#[0-9]+\\ +\\(?:[0-9a-fx]+ in \\)?\\([^ ]+\\) .*$" end t)
        (setq func-name (match-string-no-properties 1))
        (let ((point-from) (file-location-from)
              (point-at) (file-location-at)
              (file-location))
          (save-excursion
            (when (re-search-forward " from \\(/[^ ]+\\)$" end t)
              (setq file-location-from (match-string-no-properties 1)
                    point-from (point))))
          (save-excursion
            ;; a weak check of file:lineno
            (when (re-search-forward " at \\(/[^ ]+:.*\\)$" end t)
              (setq file-location-at (match-string-no-properties 1)
                    point-at (point))))
          (setq file-location
                (cond ((not file-location-from) file-location-at)
                      ((not file-location-at) file-location-from)
                      ((< point-at point-from) file-location-at)
                      (t file-location-from)))
          (when (and func-name file-location)
            (push (concat "[[" file-location "][" func-name "]]") results))))
      (unless current-prefix-arg (setq results (reverse results)))
      (kill-new (string-join results (if current-prefix-arg " < " " > "))))))

(defun my-stack-frame-to-org (rev)
  "Convert stack frame in gdb frames buffer to org.

Conversion is in a similar fashion to `my-org-backtrace-region'."
  (let ((results))
    (with-current-buffer (gdb-stack-buffer-name)
      (save-excursion
        (goto-char (point-min))
        (while (re-search-forward "^[0-9]+\\ +in \\(.*\\) of \\(.*\\)$" nil t)
          (setq func-name (match-string-no-properties 1)
                file-location (match-string-no-properties 2))
          (push (concat "[[" file-location "][" func-name "]]") results))))
    (unless rev (setq results (reverse results)))
    (string-join results (if current-prefix-arg " < " " > "))))

(defun my-insert-stack-frame-to-org (rev)
  (interactive "P")
  (insert (my-stack-frame-to-org rev)))

(defun my-kill-stack-frame-to-org (rev)
  (interactive "P")
  (kill-new (my-stack-frame-to-org rev)))

(defun my-org-backtrace ()
  (interactive)
  (if (region-active-p)
      (my-org-backtrace-region (region-beginning) (region-end))
    (my-org-backtrace-region
     (point)
     (save-excursion (comint-next-prompt 1) (point)))))

(defun my-gdb (&optional command)
  "lock gud command buffer and restore middle and right windows.

Assuming a three window horizontal split to start with.  Assuming
the default configuration of gdb windows is all of them on the
left and the source buffer on the right.
"
  (interactive)
  ;; save windows
  (let* ((old-window (selected-window))
         (right-buffer
          (window-buffer
           (progn
             (while (window-in-direction 'right)
               (select-window (window-in-direction 'right)))
             (selected-window))))
         (middle-buffer
          (window-buffer
           (window-in-direction 'left))))
    (select-window old-window)
    ;; call gdb
    (if (called-interactively-p)
        (call-interactively 'gdb)
      (gdb command))
    (sleep-for 6)
    ;; lock gud-comint-buffer
    (my-toggle-lock-window-to-buffer (get-buffer-window gud-comint-buffer))
    ;; restore windows
    (select-window (car gdb-source-window-list))
    (switch-to-buffer middle-buffer)
    (split-window-horizontally)
    (select-window (window-next-sibling))
    (switch-to-buffer right-buffer)
    (balance-windows)
    (when (window-live-p old-window) (select-window old-window))))

(defun my-gdb-restart ()
  (interactive)
  (let ((old-window (selected-window)))
    (select-window (get-buffer-window gud-comint-buffer))
    (gdb-delchar-or-quit 0)
    (call-interactively 'my-gdb)
    (when (window-live-p old-window) (select-window old-window))))

(defun my-gdb-kill ()
  (interactive)
  (let ((kill-buffer-query-functions nil))
    (kill-buffer "*gud-replay*")))

(defun my-gdb-quit ()
  (interactive)
  (let ((old-window (selected-window)))
    (select-window (get-buffer-window gud-comint-buffer))
    (goto-char (point-max))
    (gdb-delchar-or-quit 0)
    (my-toggle-lock-current-window-to-buffer)
    (when (window-live-p old-window) (select-window old-window))))

(defun my-gdb-frames-add-breakpoint ()
  (interactive)
  (gdb-select-frame)
  (with-current-buffer (gdb-get-source-buffer)
    (call-interactively 'gud-break)))

(defun my-gdb-frames-remove-breakpoint ()
  (interactive)
  (gdb-select-frame)
  (with-current-buffer (gdb-get-source-buffer)
    (call-interactively 'gud-remove)))

(defun my-gdb-frames-select-next (n)
  (interactive "p")
  (next-line n)
  (gdb-select-frame))
(defun my-gdb-frames-select-previous (n)
  (interactive "p")
  (next-line (- n))
  (gdb-select-frame))
(defun my-gdb-switch-to-source-buffer ()
  (interactive)
  (select-window (display-buffer (gdb-get-source-buffer))))

(defun my-gud-comint-set-prompt-regexp ()
  (setq comint-prompt-regexp "\\((rr)|(gdb)\\) "))

(defun my-file-loc-to-github (file-loc &optional revision)
  "Convert a file location to a github url."
  (pcase-let* ((`(,file ,line-no) (split-string file-loc ":"))
               (revision (or revision (vc-working-revision file)))
               (repo-url (vc-git-repository-url file))
               (repo-root (vc-git-root file))
               (path (file-relative-name file repo-root)))
    (format "%s/blob/%s/%s#L%s" repo-url revision path line-no)))

(defun my-org-backtrace-to-github (bt &optional revision)
  (string-join
   (mapcar
    (lambda (link)
      (string-match "\\[\\[\\(.*\\)\\]\\[\\(.*\\)\\]\\]" link)
      (let ((target (match-string 1 link))
            (label (match-string 2 link)))
        (format "[[%s][%s]]"
                (my-file-loc-to-github target revision)
                label)))
    (split-string bt " > "))
   " > "))

(defun my-org-backtrace-to-github-region (beg end)
  (interactive "r")
  (kill-new
   (my-org-backtrace-to-github (buffer-substring-no-properties beg end))))

(defun my-org-backtrace-to-github-slack (beg end)
  (interactive "r")
  (let ((bt (buffer-substring-no-properties beg end))
        (revision (when current-prefix-arg
                    (read-string "Rrevision: ")))
        )
    (with-temp-buffer
      (insert "#+options: ^:nil
")
      (goto-char (point-max))
      (insert (my-org-backtrace-to-github bt revision))
      (org-md-export-as-markdown))))

;;; which-func
(defun my-copy-which-func ()
  (interactive)
  (kill-new (which-function))
  )

(defun my-set-header-line-to-which-func ()
  (setq header-line-format
                '((which-func-mode
                   ("" which-func-format " ")
                   ))))

;; override bookmark-make-record for easier default bookmark name.
(defun my-bookmark-make-record ()
  "Return a new bookmark record (NAME . ALIST) for the current location."
  (let ((record (funcall bookmark-make-record-function)))
    ;; Set up default name if the function does not provide one.
    (unless (stringp (car record))
      (if (car record) (push nil record))
      (setcar record (or bookmark-current-bookmark (bookmark-buffer-name))))
    ;; Set up defaults.
    (bookmark-prop-set
     record 'defaults
     (delq nil (delete-dups (append (bookmark-prop-get record 'defaults)
				                            (list (which-function)
                                          bookmark-current-bookmark
					                                (car record)
                                          (bookmark-buffer-name))))))
    record))

;;; bison-mode
(require 'bison-mode)
(defun my-bison-imenu-create-index ()
  (let ((end))
    (beginning-of-buffer)
    (re-search-forward "^%%")
    (forward-line 1)
    (setq end (save-excursion
                (when (re-search-forward "^%%" nil t) (point))))
    (loop while (re-search-forward "^\\([a-z].*?\\)\\s-*\n?\\s-*:" end t)
          collect (cons (match-string 1) (point)))))
(defun my-bison-set-imenu-create-index-function ()
  (setq imenu-create-index-function
        'my-bison-imenu-create-index))

;;; json-mode
(require 'json-mode)
(defun my-json-mode-path ()
  (string-join
   (mapcar 'prin1-to-string (plist-get (json-path-to-position (point)) :path))
   "/"))

(defun my-json-set-header-line-to-path ()
  (setq header-line-format
        '((:eval (my-json-mode-path)))))

;;; eglot
(defun my-eglot-format-buffer-when-managed ()
  (when (eglot-managed-p)
    (unless (derived-mode-p 'haskell-mode 'c-mode 'c++-mode)
      (eglot-format-buffer))))

(provide 'my-prog)
;;; my-prog.el ends here