path: root/emacs.d/early-init.el

;;; ~/.emacs.d/early-init.el -*- lexical-binding: t; -*-
;; Author: Case Duckworth <acdw@acdw.net>
;; In this file there are custom functions and macros and early-init settings,
;; all alphabetically ordered.

;; There is a bug in M-x finger
(define-advice finger (:override (user host) acdw-fix)
  "Finger USER on HOST.
This command uses `finger-X.500-host-regexps'
and `network-connection-service-alist', which see."
  ;; One of those great interactive statements that's actually
  ;; longer than the function call! The idea is that if the user
  ;; uses a string like "pbreton@cs.umb.edu", we won't ask for the
  ;; host name. If we don't see an "@", we'll prompt for the host.
  (interactive
   (let* ((answer (let ((default (ffap-url-at-point)))
                    (read-string (format-prompt "Finger User" default)
                                 nil nil default)))
          (index  (string-match (regexp-quote "@") answer)))
     (if index
         (list (substring answer 0 index)
               (substring answer (1+ index)))
       (list answer
             (let ((default (ffap-machine-at-point)))
               (read-string (format-prompt "At Host" default)
                            nil nil default))))))
  (let* ((user-and-host (concat user "@" host))
         (process-name (concat "Finger [" user-and-host "]"))
         (regexps finger-X.500-host-regexps)
         ) ;; found
    (and regexps
         (while (not (string-match (car regexps) host))
           (setq regexps (cdr regexps))))
    (when regexps
      (setq user-and-host user))
    (run-network-program
     process-name
     host
     (cdr (assoc 'finger network-connection-service-alist))
     user-and-host)))

(defmacro after (event &rest body)
  "Do BODY after EVENT, which can be:
- A feature
- A hook -- if it requires arguments they'll be in the list `args'
- The symbol 'init, which runs on after-init-hook"
  (declare (indent 1))
  (let ((lambda-form `(lambda (&rest args) ,@body)))
    (pcase event
      (`(timer ,ev) `(run-with-timer ,ev nil ,lambda-form))
      (`(idle ,ev) `(run-with-idle-timer ,ev nil ,lambda-form))
      (`(hook ,ev) `(add-hook ',ev ,lambda-form))
      (`init `(after (hook after-init-hook) ,@body))
      ((pred numberp) `(after (timer ,event) ,@body))
      ((pred (lambda (ev)
               (and (symbolp ev)
                    (or (string-suffix-p "-hook" (symbol-name ev))
                        (string-suffix-p "-function" (symbol-name ev))
                        (string-suffix-p "-functions" (symbol-name ev))))))
       `(after (hook ,event) ,@body))
      ((pred symbolp) `(with-eval-after-load ',event ,@body))

      (_ (error "Can't determine event type" event)))))

(defmacro find-user-file (name &optional file-name)
  "Template macro to generate user file finding functions."
  (declare (indent 1))
  (let ((file-name (or file-name (intern (format "user-%s-file" name))))
        (func-name (intern (format "find-user-%s-file" name))))
    `(defun ,func-name (&optional arg)
       ,(format "Edit `%s' in the current window.
With ARG, edit in the other window." file-name)
       (interactive "P")
       (funcall (if arg #'find-file-other-window #'find-file)
                ,file-name))))

(defmacro inhibit-messages (&rest body)
  "Inhibit all messages in BODY."
  (declare (indent defun))
  `(cl-letf (((symbol-function 'message) #'ignore))
     ,@body))

;; This needs to be a macro to take advantage of setf magic
(defmacro setf/alist (alist key val &optional testfn)
  `(setf (alist-get ,key ,alist nil nil (or ,testfn #'equal))
         ,val))

(defun ^local-hook (hook fn)
  "Hook FN to HOOK locally in a lambda.
Good for adding to an add-hook."
  (lambda () (add-hook hook fn t)))

(defun ^local-unhook (hook fn)
  "Remove FN from HOOK locally."
  (lambda () (remove-hook hook fn t)))

(defun ^turn-off (mode)
  "Higher-order function: returns a lambda to turn off MODE."
  (lambda ()
    (funcall mode -1)))

(defun create-missing-directories ()
  "Automatically create missing directories."
  (let ((target-dir (file-name-directory buffer-file-name)))
    (unless (file-exists-p target-dir)
      (make-directory target-dir :parents))))

(defun custom-show-all-widgets ()
  "toggle all \"More/Hide\" widgets in the current buffer."
  ;; From unpackaged
  (interactive)
  (widget-map-buttons (lambda (widget _)
                        (pcase (widget-get widget :off)
                          ("More" (widget-apply-action widget)))
                        nil)))

(defun cycle-spacing* (&optional n)
  "Negate N argument on `cycle-spacing'."
  (interactive "*p")
  (cycle-spacing (- n)))

(defun delete-trailing-whitespace-except-current-line ()
  "Delete all trailing whitespace except current line."
  (save-excursion
    (delete-trailing-whitespace (point-min)
                                (line-beginning-position))
    (delete-trailing-whitespace (line-end-position)
                                (point-max))))

(defun delete-window-dwim ()
  "Delete the current window or bury its buffer.
If the current window is alone in its frame, bury the buffer
instead."
  (interactive)
  (unless (ignore-errors (delete-window) t)
    (bury-buffer)))

(defun first-found-font (&rest cands)
  "Return the first font of CANDS that is installed, or nil."
  (cl-loop with ffl = (font-family-list)
           for font in cands
           if (member font ffl)
           return font))

(defun fixup-whitespace ()
  "Indent the current buffer and (un)`tabify'.
Whether it tabifies or untabifies depends on `space-indent-modes'."
  (interactive)
  (save-mark-and-excursion
    (indent-region (point-min) (point-max))
    (if indent-tabs-mode
        (tabify (point-min) (point-max))
      (untabify (point-min) (point-max)))
    (replace-regexp-in-region "
$" "" (point-min) (point-max))))

(defun hide-minor-mode (mode &optional hook)
  "Hide MODE from the mode-line.
HOOK is used to trigger the action, and defaults to MODE-hook."
  (setf (alist-get mode minor-mode-alist) (list ""))
  (add-hook (intern (or hook (format "%s-hook" mode)))
            (lambda () (hide-minor-mode mode))))

(defun keyboard-quit* (arg)
  (interactive "P")
  (if arg
      (quit-minibuffer)
    (keyboard-quit)))

(defun kill-buffer-dwim (&optional buffer-or-name)
  "Kill BUFFER-OR-NAME or the current buffer."
  (interactive "P")
  (cond
   ((bufferp buffer-or-name)
    (kill-buffer buffer-or-name))
   ((null buffer-or-name)
    (kill-current-buffer))
   (:else
    (kill-buffer (read-buffer "Kill: " nil :require-match)))))

(defun minibuffer-delete-directory (&optional n)
  "Delete the last directory in a file-completing minibuffer."
  ;; Cribbed from `vertico-directory-up' (github.com/minad/vertico)
  (interactive "p")
  (let ((here (point))
        (meta (completion-metadata
               "" minibuffer-completion-table
               minibuffer-completion-predicate)))
    (when (and (> (point) (minibuffer-prompt-end))
               (eq 'file (completion-metadata-get meta 'category)))
      (let ((path (buffer-substring-no-properties (minibuffer-prompt-end)
                                                  (point)))
            found)
        (when (string-match-p "\\`~[^/]*/\\'" path)
          (delete-minibuffer-contents)
          (insert (expand-file-name path)))
        (dotimes (_ (or n 1) found)
          (save-excursion
            (let ((end (point)))
              (goto-char (1- end))
              (when (search-backward "/" (minibuffer-prompt-end) t)
                (delete-region (1+ (point)) end)
                (setq found t)))))))))

(defun other-window-dwim (&optional arg)
  "Switch to another window/buffer.
Calls `other-window', which see, unless
- the current window is alone on its frame
- `other-window-dwim' is called with \\[universal-argument]
In these cases, switch to the last-used buffer."
  (interactive "P")
  (if (or arg (one-window-p))
      (switch-to-buffer (other-buffer) nil t)
    (other-window 1)))

(defun package-ensure (pkgspec &optional require)
  "Install PKG if it's not already installed.
REQUIRE means require it after ensuring it's installed."
  (let ((pkg (if (listp pkgspec) (car pkgspec) pkgspec)))
    (unless (package-installed-p pkg)
      (if (symbolp pkgspec)
          (or (ignore-errors
                (package-install pkg)
                t)
              (ignore-errors
                (message "Package `%s' not found, refreshing packages" pkg)
                (package-refresh-contents)
                (package-install pkg)
                t)
              (ignore-errors
                (message "Package `%s' still not found, trying `%s'"
                         pkg 'pkg-vc-install)
                (package-vc-install pkgspec)
                t)
              (if no-error nil
                (error "Can't find package: %s" pkg)))))
    (when require (require pkg))))

(defun popup-eshell (arg)
  "Popup an eshell buffer in the current window."
  (interactive "P")
  (let ((dd default-directory))
    (eshell arg)
    (unless (equal dd default-directory)
      (setq default-directory dd)
      ;; Is this a good idea, really?
      (eshell-bol)
      (unless (eolp)
        (insert "# "))
      (eshell-send-input))))

(defun pulse@eval (start end &rest _)
  "ADVICE: makes `pulse-momentary-highlight-region' accept other arities."
  (pulse-momentary-highlight-region start end))

(defun quit-minibuffer ()
  (interactive)
  (switch-to-minibuffer)
  (minibuffer-keyboard-quit))

(defun regexp-concat (&rest regexps)
  (string-join regexps "\\|"))

(defun save-buffers-kill* (arg)
  "Save all the buffers and kill ... something.
If ARG is 1 (called normally), kill the current terminal.
If ARG is 4 (with C-u), kill emacs but ask if there are processes running.
If ARG is 16, kill emacs without asking about processes."
  (interactive "p")
  (pcase arg
    (1 (save-buffers-kill-terminal))
    (4 (save-buffers-kill-emacs t))
    (16 (let ((confirm-kill-processes nil)
              (kill-emacs-query-functions nil)
              (confirm-kill-emacs nil))
          (save-buffers-kill-emacs t)))))

(defun setup-faces ()
  "Setup Emacs faces."
  ;; Default faces
  (cl-loop for (face . spec) in *fonts*
           do (set-face-attribute face nil
                                  :family (plist-get spec :family)
                                  :height (or (plist-get spec :height)
                                              'unspecified)))
  ;; Specialized fonts
  (cl-loop with ffl = (font-family-list)
           for (charset . font)
           in '((latin . "Noto Sans")
                (han . "Noto Sans CJK SC Regular")
                (kana . "Noto Sans CJK JP Regular")
                (hangul . "Noto Sans CJK KR Regular")
                (cjk-misc . "Noto Sans CJK KR Regular")
                (khmer . "Noto Sans Khmer")
                (lao . "Noto Sans Lao")
                (burmese . "Noto Sans Myanmar")
                (thai . "Noto Sans Thai")
                (ethiopic . "Noto Sans Ethiopic")
                (hebrew . "Noto Sans Hebrew")
                (arabic . "Noto Sans Arabic")
                (gujarati . "Noto Sans Gujarati")
                (devanagari . "Noto Sans Devanagari")
                (kannada . "Noto Sans Kannada")
                (malayalam . "Noto Sans Malayalam")
                (oriya . "Noto Sans Oriya")
                (sinhala . "Noto Sans Sinhala")
                (tamil . "Noto Sans Tamil")
                (telugu . "Noto Sans Telugu")
                (tibetan . "Noto Sans Tibetan")
                ;; emojis
                (symbol . "Noto Emoji")
                ;; (symbol . "Noto Color Emoji")
                (symbol . "Segoe UI Emoji")
                (symbol . "Apple Color Emoji")
                (symbol . "FreeSans")
                (symbol . "FreeMono")
                (symbol . "FreeSerif")
                (symbol . "Unifont")
                (symbol . "Symbola"))
           if (member font ffl)
           do (set-fontset-font t charset font)))

(defun sort-sexps (beg end)
  "Sort sexps in region.
Comments stay with the code below."
  ;; From unpackaged
  (interactive "r")
  (cl-flet ((skip-whitespace () (while (looking-at (rx (1+ (or space "\n"))))
                                  (goto-char (match-end 0))))
            (skip-both () (while (cond ((or (nth 4 (syntax-ppss))
                                            (ignore-errors
                                              (save-excursion
                                                (forward-char 1)
                                                (nth 4 (syntax-ppss)))))
                                        (forward-line 1))
                                       ((looking-at (rx (1+ (or space "\n"))))
                                        (goto-char (match-end 0)))))))
    (save-excursion
      (save-restriction
        (narrow-to-region beg end)
        (goto-char beg)
        (skip-both)
        (cl-destructuring-bind (sexps markers)
            (cl-loop do (skip-whitespace)
                     for start = (point-marker)
                     for sexp = (ignore-errors
                                  (read (current-buffer)))
                     for end = (point-marker)
                     while sexp
                     ;; Collect the real string, then one used for sorting.
                     collect (cons (buffer-substring (marker-position start)
                                                     (marker-position end))
                                   (save-excursion
                                     (goto-char (marker-position start))
                                     (skip-both)
                                     (buffer-substring (point)
                                                       (marker-position end))))
                     into sexps
                     collect (cons start end)
                     into markers
                     finally return (list sexps markers))
          (setq sexps (sort sexps (lambda (a b)
                                    (string< (cdr a) (cdr b)))))
          (cl-loop for (real . sort) in sexps
                   for (start . end) in markers
                   do (progn
                        (goto-char (marker-position start))
                        (insert-before-markers real)
                        (delete-region (point) (marker-position end)))))))))

(defun switch-to-other-buffer ()
  "Switch to the `other-buffer'."
  (interactive)
  (switch-to-buffer nil))

(defun unfill-buffer ()
  (interactive)
  (unfill-region (point-min) (point-max)))

(defun unfill-buffer/force ()
  (interactive)
  (let ((buffer-read-only nil))
    (unfill-buffer)
    (visual-line-mode t)))

(defun unfill-paragraph ()
  (interactive)
  (let ((fill-column most-positive-fixnum))
    (fill-paragraph beg end)))

(defun unfill-region (beg end)
  (interactive "*r")
  (let ((fill-column most-positive-fixnum))
    (fill-region beg end)))

(defun vc-jump (arg)
  "Jump to the current project's VC buffer.
With ARG, prompt for the directory."
  (interactive "P")
  (if arg
      (let ((current-prefix-arg nil))
        (call-interactively #'vc-dir))
    (project-vc-dir)))

(progn (defvar *fonts*
         (let ((fixed "Recursive Mono Casual Static")
               (variable "Recursive Sans Linear Static"))
           `((default
              :family ,variable
              :height 100)
             (variable-pitch :family ,variable)
             (fixed-pitch :family ,fixed)
             (fixed-pitch-serif :family ,fixed)
             (font-lock-string-face :family "Recursive Mono Linear Static"))))
       ;; (setup-faces)
       )

(setopt default-frame-alist
        '((menu-bar-lines . 0)
          (tool-bar-lines . 0)
          ;;(vertical-scroll-bars)
          (horizontal-scroll-bars)))

(setopt frame-inhibit-implied-resize t)
(setopt frame-resize-pixelwise t)
(setopt window-resize-pixelwise t)

(when (getenv "IN_EXWM")
  (add-to-list 'default-frame-alist '(fullscreen . fullboth)))

(when (require 'package)
  (add-to-list 'package-archives '("melpa" . "https://melpa.org/packages/"))
  (package-initialize))