;;; my-editing.el -- Editing 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:

;; Editing related extensions.

;;; Code:



;;; Some of the following functions are adapted from prot-dotfiles
(defun my-comment-and-copy-selection ()
  (interactive)
  (comment-dwim nil)
  (my-yank-primary))

(defun my-kill-region-if-active (beg end &optional region)
  (interactive (list (mark) (point) 'region))
  (when mark-active
    (kill-region beg end region)))

;;; Stefan Monnier <foo at acm.org>. It is the opposite of fill-paragraph
(defun my-unfill-paragraph (&optional region)
  "Takes a multi-line paragraph and makes it into a single line of text."
  (interactive (progn (barf-if-buffer-read-only) '(t)))
  (let ((fill-column (point-max))
        ;; This would override `fill-column' if it's an integer.
        (emacs-lisp-docstring-fill-column t))
    (fill-paragraph nil region)))

;;; fixme: move to search
(defun my-replace-leading-space (to-string begin end)
  (interactive (list (read-string "Replace leading whitespace by: ")
		                 (region-beginning) (region-end)))
  (save-excursion
    (goto-char begin)
    (while (re-search-forward "^\\ +" end t)
      (replace-match to-string))))

(defun my-concat-lines (begin end)
  (interactive (list (region-beginning) (region-end)))
  (replace-regexp "\n" " " nil begin end))

(defun my-save-without-formatting ()
  (interactive)
  (read-only-mode 1)
  (save-buffer)
  (read-only-mode -1))

(defun my-yank-primary ()
  (interactive)
  (let ((primary (gui-get-primary-selection)))
    (push-mark)
    (insert-for-yank primary)))

(defun my-beginning-of-line-or-indentation ()
  "Move to beginning of line, or indentation"
  (interactive)
  (if (bolp)
      (back-to-indentation)
    (beginning-of-line)))

(defun my-copy-url-at-point ()
  (interactive)
  (when-let ((url (thing-at-point-url-at-point)))
    (kill-new url)
    (message "Copied: %s" (thing-at-point-url-at-point))))

(defun my-backward-kill-path-component ()
  (interactive)
  (zap-up-to-char -1 ?/))

(defun my-toggle-forward-word-symbol ()
  (interactive)
  (require 'viper)
  (cond ((eq (lookup-key (current-global-map) "\M-f") 'forward-word)
         (progn
           (define-key global-map "\M-f" 'viper-forward-word)
           (define-key global-map "\M-b" 'viper-backward-word)
           (message "M-f is viper-forward-word")))
        ((eq (lookup-key (current-global-map) "\M-f") 'viper-forward-word)
         (progn
           (define-key global-map "\M-f" 'forward-symbol)
           (define-key global-map "\M-b"
                       (lambda () (interactive)
                         (forward-symbol -1)))
           (message "M-f is forward-symbol")))
        (t (progn
             (define-key global-map "\M-f" 'forward-word)
             (define-key global-map "\M-b" 'backward-word)
             (message "M-f is forward-word")))))

;;; todo: move to my-viper
;;; do not skip underscore
(defun viper-forward-word-kernel (val)
  (while (> val 0)
    (cond ((viper-looking-at-alpha)
	         (viper-skip-alpha-forward "")
	         (viper-skip-separators t))
	        ((viper-looking-at-separator)
	         (viper-skip-separators t))
	        ((not (viper-looking-at-alphasep))
	         (viper-skip-nonalphasep-forward)
	         (viper-skip-separators t)))
    (setq val (1- val))))

(defun viper-backward-word-kernel (val)
  (while (> val 0)
    (viper-backward-char-carefully)
    (cond ((viper-looking-at-alpha)
	         (viper-skip-alpha-backward ""))
	        ((viper-looking-at-separator)
	         (forward-char)
	         (viper-skip-separators nil)
	         (viper-backward-char-carefully)
	         (cond ((viper-looking-at-alpha)
		              (viper-skip-alpha-backward "_"))
		             ((not (viper-looking-at-alphasep))
		              (viper-skip-nonalphasep-backward))
		             ((bobp)) ; could still be at separator, but at beg of buffer
		             (t (forward-char))))
	        ((not (viper-looking-at-alphasep))
	         (viper-skip-nonalphasep-backward)))
    (setq val (1- val))))

(defun my--duplicate-buffer-substring (beg end &optional indent)
  "Duplicate buffer substring between BEG and END positions.
With optional INDENT, run `indent-for-tab-command' after
inserting the substring."
  (save-excursion
    (goto-char end)
    (insert (buffer-substring-no-properties beg end))
    (when indent
      (indent-for-tab-command))))

;;;###autoload
(defun my-copy-line-or-region (&optional duplicate)
  "Copy the current line or active region to the `kill-ring'.
With optional DUPLICATE as a prefix argument, duplicate the
current line or active region without adding it to the `kill-ring'."
  (interactive "P")
  (let* ((region (region-active-p))
         (beg (if region (region-beginning) (line-beginning-position)))
         (end (if region (region-end) (1+ (line-end-position))))
         (message (if region "region" "line")))
    (if duplicate
        (my--duplicate-buffer-substring beg end)
      (copy-region-as-kill beg end)
      (message "Copied current %s" message))))

;;;###autoload
(defun my-new-line-below ()
  "Open a new line below and indent."
  (interactive)
  (end-of-line)
  (newline-and-indent))

;;;###autoload
(defun my-new-line-above-or-below (&optional arg)
  "Create an empty line above the current one.
Move the point to the absolute beginning.  Open a new line below
by passing optional prefix ARG (\\[universal-argument])."
  (interactive "P")
  (if arg
      (my-new-line-below)
    (if (or (bobp)
            (line-number-at-pos (point-min)))
        (progn
          (beginning-of-line)
          (newline)
          (forward-line -1)
          (indent-according-to-mode))
      (forward-line -1)
      (my-new-line-below))))

(defun my--pos-url-on-line (&optional char)
  "Return position of `my-url-regexp' on line or at CHAR."
  (save-excursion
    (goto-char (or char (line-beginning-position)))
    (re-search-forward my-url-regexp (line-end-position) :noerror)))

;;;###autoload
(defun my-escape-url-line (&optional char)
  "Escape all URLs or email addresses on the current line.
By default, start operating from `line-beginning-position' to the
end of the current line.  With optional CHAR as a buffer
position, operate from CHAR to the end of the line."
  (interactive)
  (when-let ((regexp-end (my--pos-url-on-line char)))
    (save-excursion
      (goto-char regexp-end)
      (unless (looking-at ">")
        (insert ">")
        (search-backward "\s")
        (forward-char 1)
        (insert "<")))
    (my-escape-url-line (1+ regexp-end))))

;; Thanks to Bruno Boal for `my-escape-url-region'.  I am
;; just renaming it for consistency with the rest of prot-simple.el.
;; Check Bruno's Emacs config: <https://github.com/BBoal/emacs-config>.

;;;###autoload
(defun my-escape-url-region (&optional beg end)
  "Apply `my-escape-url-line' on region lines between BEG and END."
  (interactive
   (if (region-active-p)
       (list (region-beginning) (region-end))
     (error "There is no region!")))
  (unless (> end beg)
    (cl-rotatef end beg))
  (save-excursion
    (goto-char beg)
    (setq beg (line-beginning-position))
    (while (<= beg end)
      (my-escape-url-line beg)
      (beginning-of-line 2)
      (setq beg (point)))))

;;;###autoload
(defun my-escape-url-dwim ()
  "Escape URL on the current line or lines implied by the active region.
Call the commands `my-escape-url-line' and
`my-escape-url-region' ."
  (interactive)
  (call-interactively
   (if (region-active-p)
       #'my-escape-url-region
     #'my-escape-url-line)))

;; Got those numbers from `string-to-char'
(defcustom my-insert-pair-alist
  '(("' Single quote"        . (39 39))     ; ' '
    ("\" Double quotes"      . (34 34))     ; " "
    ("` Elisp quote"         . (96 39))     ; ` '
    ("‘ Single apostrophe"   . (8216 8217)) ; ‘ ’
    ("“ Double apostrophes"  . (8220 8221)) ; “ ”
    ("( Parentheses"         . (40 41))     ; ( )
    ("{ Curly brackets"      . (123 125))   ; { }
    ("[ Square brackets"     . (91 93))     ; [ ]
    ("< Angled brackets"     . (60 62))     ; < >
    ("« Εισαγωγικά Gr quote" . (171 187))   ; « »
    ("= Equals signs"        . (61 61))     ; = =
    ("~ Tilde"               . (126 126))   ; ~ ~
    ("* Asterisks"           . (42 42))     ; * *
    ("/ Forward Slash"       . (47 47))     ; / /
    ("_ underscores"         . (95 95)))    ; _ _
  "Alist of pairs for use with `my-insert-pair-completion'."
  :type 'alist
  :group 'my-editing)

(defvar my--character-hist '()
  "History of inputs for `my-insert-pair-completion'.")

(defun my--character-prompt (chars)
  "Helper of `my-insert-pair-completion' to read CHARS."
  (let ((def (car my--character-hist)))
    (let ((electric-pair-mode nil))
      (completing-read
       (format "Select character [%s]: " def)
       chars nil t nil 'my--character-hist def))))

;;;###autoload
(defun my-insert-pair (pair &optional count)
  "Insert PAIR from `my-insert-pair-alist'.
Operate on the symbol at point.  If the region is active, use it
instead.

With optional COUNT (either as a natural number from Lisp or a
universal prefix argument (\\[universal-argument]) when used
interactively) prompt for the number of delimiters to insert."
  (interactive
   (list
    (my--character-prompt my-insert-pair-alist)
    current-prefix-arg))
  (let* ((data my-insert-pair-alist)
         (left (cadr (assoc pair data)))
         (right (caddr (assoc pair data)))
         (n (cond
             ((and count (natnump count))
              count)
             (count
              (read-number "How many delimiters?" 2))
             (1)))
         (beg)
         (end)
         (forward))
    (cond
     ((region-active-p)
      (setq beg (region-beginning)
            end (region-end)))
     ((when (thing-at-point 'symbol)
        (let ((bounds (bounds-of-thing-at-point 'symbol)))
          (setq beg (car bounds)
                end (cdr bounds)))))
     (t (setq beg (point)
              end (point)
              forward t)))
    (save-excursion
      (goto-char end)
      (dotimes (_ n)
        (insert right))
      (goto-char beg)
      (dotimes (_ n)
        (insert left)))
    (when forward (forward-char n))))

;;;###autoload
(defun my-delete-pair-dwim ()
  "Delete pair following or preceding point.
For Emacs version 28 or higher, the feedback's delay is
controlled by `delete-pair-blink-delay'."
  (interactive)
  (if (eq (point) (cdr (bounds-of-thing-at-point 'sexp)))
      (delete-pair -1)
    (delete-pair 1)))

(defun my-delete-line-if-space-only ()
  "Delete the current line, if it has only space and nothing else."
  (interactive)
  (save-excursion
    (beginning-of-line)
    (when (looking-at-p "^\\ *$")
      (delete-line))))

;;; To override delete-pair
(defun my-delete-pair (&optional arg)
  "Delete a pair of characters enclosing ARG sexps that follow point.

A negative ARG deletes a pair around the preceding ARG sexps
instead. The option `delete-pair-blink-delay' can disable
blinking.

Delete space-only-lines caused by the deletion, as well as
re-indent the affected region."
  (interactive "P")
  (if arg
      (setq arg (prefix-numeric-value arg))
    (setq arg 1))
  (let ((beg) (end))
    (if (< arg 0)
        (save-excursion
	        (skip-chars-backward " \t")
	        (save-excursion
	          (let ((close-char (char-before)))
	            (forward-sexp arg)
	            (unless (member (list (char-after) close-char)
			                        (mapcar (lambda (p)
				                                (if (= (length p) 3) (cdr p) p))
				                              insert-pair-alist))
	              (error "Not after matching pair"))
	            (when (and (numberp delete-pair-blink-delay)
		                     (> delete-pair-blink-delay 0))
	              (sit-for delete-pair-blink-delay))
	            (delete-char 1)
              (my-delete-line-if-space-only)
              (setq beg (point))))
	        (delete-char -1)
          (my-delete-line-if-space-only)
          (setq end (point)))
      (save-excursion
        (skip-chars-forward " \t")
        (save-excursion
	        (let ((open-char (char-after)))
	          (forward-sexp arg)
	          (unless (member (list open-char (char-before))
			                      (mapcar (lambda (p)
				                              (if (= (length p) 3) (cdr p) p))
				                            insert-pair-alist))
	            (error "Not before matching pair"))
	          (when (and (numberp delete-pair-blink-delay)
		                   (> delete-pair-blink-delay 0))
	            (sit-for delete-pair-blink-delay))
	          (delete-char -1)
            (my-delete-line-if-space-only)
            (setq end (point))))
        (delete-char 1)
        (my-delete-line-if-space-only)
        (setq beg (point))))
    (when (and beg end)
      (indent-region beg end))))

;;;###autoload
(defun my-zap-back-to-char (char &optional arg)
  "Backward `zap-to-char' for CHAR.
Optional ARG is a numeric prefix to match ARGth occurance of
CHAR."
  (interactive
   (list
    (read-char-from-minibuffer "Zap to char: " nil 'read-char-history)
    (prefix-numeric-value current-prefix-arg)))
  (zap-to-char (- arg) char))

(defun my-transpose-lines ()
  "Same as `transpose-lines' but move point to the original position

Basically move the line up
"
  (interactive)
  (let ((line (current-line))
        (col (current-column)))
    (call-interactively 'transpose-lines)
    (goto-line line)
    (forward-char col)))

(defun my-kill-line (&optional arg)
  "Calls `kill-line', or `my-kill-forward' in case of prefix arg."
  (interactive "P")
  (if arg
      (my-kill-forward)
    (kill-line)))

(defun my-kill-forward ()
  "Kill towards end of line, but not out of sexp."
  (interactive)
  (if (eolp)
      (delete-char 1)
    (let ((end)
          (eol (save-excursion (end-of-line) (point))))
      (save-excursion
        (skip-chars-forward " \t")
        (while (not (or (eq end (point))
                        (>= (point) eol)))
          (setq end (point))
          (ignore-errors (forward-sexp))
          (skip-chars-forward " \t"))
        (when (> (point) eol) (skip-chars-backward " \t"))
        (setq end (point)))
      (kill-region (point) end))))

(defun my-kill-line-backward (&optional arg)
  "Calls `kill-line' with 0, or `my-kill-backward' in case of prefix arg."
  (interactive "P")
  (if arg
      (my-kill-backward)
    (if (bolp) (delete-char -1)
      (kill-line 0))))

(defun my-kill-backward ()
  "Kill towards beginning of line, but not out of sexp."
  (interactive)
  (if (bolp)
      (delete-char -1)
    (let ((beg)
          (bol (save-excursion (beginning-of-line) (point))))
      (save-excursion
        (skip-chars-backward " \t")
        (while (not (or (eq beg (point))
                        (<= (point) bol)))
          (setq beg (point))
          (ignore-errors (backward-sexp))
          (skip-chars-backward " \t"))
        (when (< (point) bol) (skip-chars-forward " \t"))
        (setq beg (point)))
      (kill-region beg (point)))))

(defun my-copy-buffer-file-name (&optional relative)
  "Copy the file name of the current buffer.

With an prefix-arg, copy the file name relative to project root."
  (interactive "P")
  (let ((to-kill
         (if (and relative (project-current))
             (file-relative-name (buffer-file-name)
                                 (project-root (project-current)))
           (buffer-file-name))))
    (kill-new to-kill)
    (message "Copied %s" to-kill)))

(defun my-non-special-modes-setup ()
  (setq indicate-empty-lines t)
  (setq show-trailing-whitespace t)
  )

(defun my-text-modes-setup ()
  ;; it can be hard to preserve balance in text mode
  (setq-local electric-pair-preserve-balance nil)
  (turn-on-auto-fill)
  (visual-line-mode)
  (flyspell-mode)
  )

(defun my-find-file-line-number (orig filename &rest args)
  "Turn files like file.cpp:14 into file.cpp and going to the 14-th line."
  (save-match-data
    (let* ((matched (string-match "^\\(.*\\):\\([0-9]+\\):?$" filename))
           (line-number (and matched
                             (match-string 2 filename)
                             (string-to-number (match-string 2 filename))))
           (filename (if matched (match-string 1 filename) filename)))
      (apply orig filename args)
      (when line-number
        ;; goto-line is for interactive use
        (goto-char (point-min))
        (forward-line (1- line-number))))))

(defun my-mark-backward-up-list ()
  "Mark the sexp containing the current one."
  (interactive)
  (backward-up-list)
  (activate-mark)
  (set-mark (point))
  (forward-sexp)
  (exchange-point-and-mark))

(defun my-kill-sexp-or-comment (&optional n)
  "Kill the next n sexp. On failure, call `comment-kill' instead."
  (interactive)
  (let ((old-max (point-max))
        (old-point (point)))
    (comment-kill (or n 1))
    (when (= old-max (point-max))
      (goto-char old-point)
      (kill-sexp n))))

(defun my-mark-sexp-or-comment ()
  "Mark the next sexp or comment."
  (interactive)
  (condition-case _
      (mark-sexp)
    (user-error
     (set-mark
      (save-excursion
        (forward-comment 1)
        (point))))))

(defun my-elide-region (b e)
  (interactive "r")
  (let ((message-elide-ellipsis (concat comment-start
                                        " [... %l lines elided]
")))
    (message-elide-region b e)))

(defun my-replace-no-filter (old-fun &rest r)
  (let ((search-invisible t))
    (apply old-fun r)))

(defun my-turn-off-truncate-lines ()
  (setq truncate-lines nil))

(defun my-write-file ()
  "Same as `write-file', but keep the old buffer and remain there.

In other words, create a new buffer with the same content and
execute `write-file', then switch back to the current buffer."
  (interactive)
  (let ((old-buffer (current-buffer)))
    (with-temp-buffer
      (insert-buffer-substring old-buffer)
      (call-interactively 'write-file))))

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