;;; 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))

(defun my-comint-restart ()
  (interactive)
  (ignore-errors (comint-send-eof))
  (sleep-for .1)
  (my-comint-revive))

(defun my-comint-add-write-history-hook ()
  "Add `comint-write-input-ring' to `kill-buffer-hook'.

To use as a hook to comint mode, so that history is updated on
buffer kill."
  (add-hook 'kill-buffer-hook 'comint-write-input-ring 0 t))

(defvar my-comint-revive-commands
  '((shell-mode . my-shell-revive)
    (inferior-emacs-lisp-mode . ielm))
  "Alist of commands for each comint derived mode to revive a \"no
  process\" buffer ")

(defun my-shell-revive ()
  (interactive)
  (shell (current-buffer)))

(defun my-comint-revive ()
  "Revive a comint process after death"
  (interactive)
  (if-let ((revive-command (alist-get major-mode
                                      my-comint-revive-commands)))
      (funcall revive-command)
    (error "I don't know how to restart in %S" major-mode))
  )

(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))))))

(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)

(defvar my-shell-buffer-list nil
  "List of shell mode buffers.")

(defun my-shell-dir-filter (pairs)
  "Filter function for `my-read-shell-buffer'."
  (lambda (str pred flag)
    (pcase flag
      ('metadata
       (list 'metadata
             (cons 'annotation-function
                   (lambda (c)
                     (alist-get c pairs nil nil #'equal)))))
      (_
       (if (string-blank-p str)
           (all-completions str pairs)
         (all-completions
          str
          (lambda (&rest _)
            (seq-map
             #'car
             (seq-filter
              (lambda (x)
                (unless (string-blank-p str)
                  (or
                   (string-match-p (regexp-quote str) (car x))
                   (string-match-p (regexp-quote str) (cdr x)))))
              pairs)))))))))

(defun my-read-shell-buffer ()
  "Switch to a shell buffer by default directory."
  (interactive)
  (let ((coll
         (seq-map
          (lambda (buffer)
            (with-current-buffer buffer
              (cons (buffer-name buffer) default-directory)))
          (seq-filter
           (lambda (buffer)
             (with-current-buffer buffer
               (derived-mode-p 'shell-mode)))
           (buffer-list)))))
    (completing-read "Shell prompt: "
                     (my-shell-dir-filter coll))))

(defun my-shell-open-or-cycle (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 (my-buffer-find-mode 'shell-mode)))
      (progn
        (call-interactively 'my-shell-with-directory)
        (setq my-shell-buffer-list
              (seq-filter 'my-buffer-with-same-major-mode-p
                          (buffer-list))))
    (if (eq last-command 'my-shell-open-or-cycle)
        (progn
          (setq my-shell-buffer-list
                (my-list-cycle my-shell-buffer-list))
          (switch-to-buffer (car my-shell-buffer-list)))
      (let ((buffer
             (my-buffer-find-mode 'shell-mode)))
        (switch-to-buffer buffer)
        (setq my-shell-buffer-list
              (seq-filter 'my-buffer-with-same-major-mode-p
                          (buffer-list)))))))

;;; 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)
                      (_ 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 ((kill-buffer-query-functions nil))
    (kill-buffer gud-comint-buffer))
  )

(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)\\) "))


;;; used to override `gdb-frame-handler': do not re-display frame on
;;; completion.
(defun my-gdb-frame-handler ()
  "Set `gdb-selected-frame' and `gdb-selected-file' to show
overlay arrow in source buffer."
  (let ((frame (gdb-mi--field (gdb-mi--partial-output) 'frame)))
    (when frame
      (setq gdb-selected-frame (gdb-mi--field frame 'func))
      (setq gdb-selected-file
            (when-let ((full (gdb-mi--field frame 'fullname)))
              (file-local-name full)))
      (setq gdb-frame-number (gdb-mi--field frame 'level))
      (setq gdb-frame-address (gdb-mi--field frame 'addr))
      (let ((line (gdb-mi--field frame 'line)))
        (setq gdb-selected-line (and line (string-to-number line)))
        (when (and gdb-selected-file gdb-selected-line
                   (not (and (boundp 'gud-gdb-fetch-lines-break)
                             gud-gdb-fetch-lines-break)))
          (setq gud-last-frame (cons gdb-selected-file gdb-selected-line))
          (gud-display-frame)))
      (if gud-overlay-arrow-position
          (let ((buffer (marker-buffer gud-overlay-arrow-position))
                (position (marker-position gud-overlay-arrow-position)))
            (when buffer
              (with-current-buffer buffer
                (setq fringe-indicator-alist
                      (if (string-equal gdb-frame-number "0")
                          nil
                        '((overlay-arrow . hollow-right-triangle))))
                (setq gud-overlay-arrow-position (make-marker))
                (set-marker gud-overlay-arrow-position position))))))))


;;; Can't override gud-gdbmi-completions - would get:
;;; error in process filter: gud-marker-filter: Symbol’s value as variable is void: gud-gdb-fetch-lines-string
;;; error in process filter: Symbol’s value as variable is void: gud-gdb-fetch-lines-string

;; (defun gud-gdbmi-completions (context command)
;;   "Completion table for GDB/MI commands.
;; COMMAND is the prefix for which we seek completion.
;; CONTEXT is the text before COMMAND on the line."
;;   (let ((gud-gdb-fetch-lines-in-progress t)
;; 	      (gud-gdb-fetch-lines-string nil)
;; 	      (gud-gdb-fetch-lines-break (length context))
;; 	      (gud-gdb-fetched-lines nil)
;; 	      ;; This filter dumps output lines to `gud-gdb-fetched-lines'.
;; 	      (gud-marker-filter #'gud-gdbmi-fetch-lines-filter))
;;     (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer)
;;       (gdb-input (concat "complete " context command)
;; 		             (lambda () (setq gud-gdb-fetch-lines-in-progress nil)))
;;       (while gud-gdb-fetch-lines-in-progress
;; 	      (accept-process-output (get-buffer-process gud-comint-buffer) 1)))
;;     (gud-gdb-completions-1 gud-gdb-fetched-lines)))

;;; 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
(defun my-bison-imenu-create-index ()
  (require 'bison-mode)
  (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
(defun my-json-mode-path ()
  (require 'json-mode)
  (string-join
   (mapcar 'prin1-to-string (plist-get (json-path-to-position (point)) :path))
   "/"))

(defun my-json-setup-hook ()
  (if (< (point-max) 100000)
      (my-json-set-header-line-to-path)
    (setq which-func-mode nil)))

(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))))

;;; lisp
(defun my-eval-defun-or-region (&optional arg)
  "Call `eval-region' if region is active, otherwise call `eval-defun'"
  (interactive "P")
  (if (region-active-p)
      (eval-region (region-beginning) (region-end) t)
    (eval-defun arg)))

(defun my-insert-current-prefix ()
  "Insert file basename followed by a dash"
  (interactive)
  (insert (file-name-base (buffer-file-name)) "-"))

;; override `debugger-quit' - delete instead quit window
(defun my-debugger-quit ()
  "Quit debugging and return to the top level."
  (interactive)
  (if (= (recursion-depth) 0)
      (delete-window)
    (top-level)))

;;; prog-mode
(defun my-prog-modes-setup ()
  (setq-local comment-auto-fill-only-comments t)
  (auto-fill-mode)
  (display-line-numbers-mode)
  (setq tab-width 2)
  (setq indent-tabs-mode nil)
  (bug-reference-prog-mode)
  (flyspell-prog-mode))

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