path: root/.emacs

;; -*- lexical-binding: t -*-

;; Packages and Custom initialization

;; Letting Custom run *before* initializing packages seems to result
;; in packages resetting some of their variables, eg page-break-lines
;; resets global-page-break-lines-mode to nil.  Cue Custom shrugging,
;; "changed outside Customize".

;; NB: starting from Emacs 27, package-initialize is automatically
;; called before loading the user's init file, unless
;; package-enable-at-startup is set to nil in the early init file.
(when (< emacs-major-version 27)
  (package-initialize))

(setq custom-file "~/.emacs-custom.el")
(load custom-file)


;; Key bindings

;; C-h is a special snowflake in many situations; this is the most
;; reliable way I found to consistently get C-h to do what DEL does.
;;
;; Likewise, C-M-h is re-bound by some major modes (CC, Python, Perl),
;; so this is the simplest way I know of to make sure C-M-h sticks as
;; "backward-kill-word".
;;
;; Same story with M-h (mark-paragraph) which gets re-bound by eg
;; markdown-mode and nxml-mode.
;;
;; NB: help and mark-defun are still accessible using H instead of h,
;; except in a terminal.
(define-key input-decode-map (kbd "C-h") (kbd "DEL"))
(define-key input-decode-map (kbd "C-M-h") (kbd "M-DEL"))

(global-set-key (kbd "C-x C-b") 'ibuffer)

(defun my/other-window (count &optional all-frames)
  (interactive "p")
  (let ((repeat-map (make-sparse-keymap)))
    (define-key repeat-map [?o] #'other-window)
    (set-transient-map repeat-map t)
    (other-window count all-frames)))

(global-set-key (kbd "C-x o") #'my/other-window)

;; Hopefully these will be easier to remember than TeX commands:

(quail-define-package
 "my/symbols" "UTF-8" "𝒰" t
 "Input arbitrary Unicode symbols with other arbitrary symbols.")

(pcase-dolist
    (`(,key ,translation)
     '(;; Punctuation
       ("..." ?…)
       ;; Math symbols
       ("~~" ?≈) ("~~_" ?≊) ("~=" ?≅) ("~_" ?≃)
       ("=_" ?≡) ("^=" ?≙) (":=" ?≔)
       ("<=" ?≤) (">=" ?≥)
       ("-->" ?→) ("-/>" ?↛) ("==>" ?⇒) ("=/>" ?⇏)
       ("<--" ?←) ("</-" ?↚) ("<==" ?⇐) ("</=" ?⇍)
       ("<->" ?↔) ("<=>" ?⇔)
       ;; Emojis
       ("\\o/" ?🙌) ("\\m/" ?🤘)
       ;; Pictograms
       ("/!\\" ?⚠)))
  (quail-defrule key translation "my/symbols"))

(defmacro my/make-input-toggle (input-method)
  (let ((fsym (intern (format "my/toggle-input-%s" input-method)))
        ;; Unfortunately, by default `help-make-xrefs' does not try to
        ;; cross-reference input methods, as `help-xref-mule-regexp'
        ;; is nil.  This can be worked around by setting this variable
        ;; to `help-xref-mule-regexp-template'.
        (doc (format "Toggle `%s' input method." input-method)))
    `(defun ,fsym ()
       ,doc
       (interactive)
       ;; `current-input-method' is a string; if INPUT-METHOD is a
       ;; symbol, neither eq, eql nor equal would return t.
       (if (string= current-input-method ',input-method)
           (deactivate-input-method)
         (set-input-method ',input-method t)))))

(defun my/set-tab-width (&optional arg)
  (interactive "P")
  (let ((new-width (cond (arg (prefix-numeric-value arg))
                         ((= tab-width 4) 8)
                         (4)))
        (old-width tab-width))
    ;; TODO: for some reason, set-variable takes effect immediately,
    ;; but setq(-local)? do not: I need to move the cursor before tabs
    ;; are re-drawn.
    (set-variable 'tab-width new-width)
    (message "changed from %s to %s" old-width new-width)))

(defun my/kill (stuff)
  (kill-new stuff)
  (message stuff))

(defun my/kill-ring-filename ()
  (interactive)
  (my/kill (or (buffer-file-name) default-directory)))

(defun my/kill-ring-pipe-region (command)
  (interactive (list (read-shell-command "Shell command on region: ")))
  (let ((input (funcall region-extract-function nil)))
    (with-temp-buffer
      (insert input)
      (call-process-region (point-min) (point-max) shell-file-name
                           t t nil shell-command-switch command)
      (my/kill (buffer-string)))))

(defun my/kill-ring-shell (command)
  (interactive (list (read-shell-command "Shell command: ")))
  (with-temp-buffer
    (call-process-shell-command command nil t)
    (my/kill (buffer-string))))

(defun my/make-project-wide (f)
  "Make a function which will run F from the project's root directory."
  (lambda ()
    (:documentation (format "Run `%s' from the project's root directory." f))
    (interactive)
    (let ((default-directory (my/project-root)))
      (call-interactively f))))

(defun my/magit-project ()
  (interactive)
  (require 'project)
  (magit-status (project-prompt-project-dir)))

(defmacro my/define-prefix-command (name doc bindings)
  (declare (indent defun))
  `(defvar ,name
     (let ((map (define-prefix-command ',name)))
       (pcase-dolist (`(,key ,fun) ,bindings)
         (define-key map key fun))
       map)
     ,doc))

(my/define-prefix-command my/buffer-map
  "Keymap for buffer manipulation commands."
  '(("b" bury-buffer)
    ("g" revert-buffer)
    ("r" rename-buffer)))

(my/define-prefix-command my/display-map
  "Keymap for display-related commands."
  '(("t" toggle-truncate-lines)
    ("v" visual-line-mode)))

(my/define-prefix-command my/editing-map
  "Keymap for toggling editing features."
  '(("f" auto-fill-mode)))

(my/define-prefix-command my/magit-map
  "Keymap for Magit commands."
  '(("c" magit-file-dispatch)
    ("f" magit-find-file)
    ("g" magit-status)
    ("x" magit-dispatch)))

(my/define-prefix-command my/input-map
  "Keymap for input methods shortcuts."
  `(("t" ,(my/make-input-toggle TeX))
    ("u" ,(my/make-input-toggle my/symbols))))

(my/define-prefix-command my/kill-map
  "Keymap for adding things to the kill ring."
  '(("f" my/kill-ring-filename)
    ("|" my/kill-ring-pipe-region)
    ("!" my/kill-ring-shell)))

(my/define-prefix-command my/manual-map
  "Keymap for reading manuals."
  '(("i" info-display-manual)
    ("m" man)))

(my/define-prefix-command my/project-map
  "Keymap for project-related commands."
  '(("g" my/magit-project)))

(my/define-prefix-command my/whitespace-map
  "Keymap for whitespace-related commands."
  '(("c" whitespace-cleanup)
    ("f" page-break-lines-mode)
    ("m" whitespace-mode)
    ("t" my/set-tab-width)))

;; C-c [[:alpha:]] is reserved for users - let's make good use of it.

(global-set-key (kbd "C-c b") 'my/buffer-map)
(global-set-key (kbd "C-c c") 'compile)
(global-set-key (kbd "C-c d") 'my/display-map)
(global-set-key (kbd "C-c e") 'my/editing-map)
(global-set-key (kbd "C-c g") 'my/magit-map)
(global-set-key (kbd "C-c i") 'my/input-map)
(global-set-key (kbd "C-c k") 'my/kill-map)
(global-set-key (kbd "C-c m") 'my/manual-map)
(global-set-key (kbd "C-c p") 'my/project-map)
(global-set-key (kbd "C-c w") 'my/whitespace-map)

(unless (>= emacs-major-version 28)
  (define-key my/project-map "c" (my/make-project-wide 'compile))
  (define-key my/project-map "f" 'project-find-file)
  (define-key my/project-map "!" (my/make-project-wide 'shell-command))
  (define-key my/project-map "&" (my/make-project-wide 'async-shell-command)))

(rg-enable-default-bindings)            ; Uses the C-c s prefix.

;; What's life without a little risk?
(setq disabled-command-function nil)


;; Window management

(when window-system
  (load-theme 'eighters t)
  ;; Bindings ala Terminator
  (global-set-key (kbd "C-S-o") 'split-window-below)
  (global-set-key (kbd "C-S-e") 'split-window-right)
  (global-set-key (kbd "C-+") 'text-scale-adjust)
  (global-set-key (kbd "C--") 'text-scale-adjust)
  (global-set-key (kbd "C-0") 'text-scale-adjust)
  (global-set-key (kbd "C-S-<up>") 'enlarge-window)
  (global-set-key (kbd "C-S-<down>") 'shrink-window)
  (global-set-key (kbd "C-S-<right>") 'enlarge-window-horizontally)
  (global-set-key (kbd "C-S-<left>") 'shrink-window-horizontally))


;; Online packages configuration

;; So long, Will Mengarini.
(delight 'abbrev-mode nil 'abbrev)
(delight 'auto-fill-function "⏎" t)
(delight 'auto-revert-mode "⟳" 'autorevert)
(delight 'auto-revert-tail-mode "⤓" 'autorevert)
(delight 'eldoc-mode "📖" 'eldoc)
(delight 'footnote-mode "¹" 'footnote)
(delight 'flyspell-mode (propertize "🖋" 'face 'flyspell-incorrect) 'flyspell)
(delight 'hi-lock-mode nil 'hi-lock)
(delight 'hs-minor-mode "…" 'hideshow)
(delight 'isearch-mode "🔍" 'isearch)
(delight 'org-indent-mode "»" 'org-indent)
(delight 'magit-blame-mode "👉" 'magit-blame)
(delight 'mml-mode "📧" 'mml)
(delight 'page-break-lines-mode nil 'page-break-lines)
(delight 'scroll-lock-mode "📜" 'scroll-lock)
(delight 'text-scale-mode
         '(:eval (if (>= text-scale-mode-amount 0) "🗚" "🗛"))
         'face-remap)
(delight 'visual-line-mode nil t)
(delight 'which-key-mode nil 'which-key)
(delight 'whitespace-mode nil 'whitespace)
(delight 'with-editor-mode "⸎" 'with-editor)
;; TODO: Narrow (⌖, ⛶)

(if (< emacs-major-version 27)
    (delight 'compilation-in-progress
             (propertize "⚙" 'face 'compilation-mode-line-run)
             'compile)
  (let* ((indicator (alist-get 'compilation-in-progress mode-line-modes))
         (old-props (text-properties-at 0 (car indicator)))
         (new-props '(face compilation-mode-line-run)))
    (setcar indicator (apply #'propertize "⚙" (append new-props old-props)))))

(add-hook 'magit-pre-refresh-hook 'diff-hl-magit-pre-refresh)
(add-hook 'magit-post-refresh-hook 'diff-hl-magit-post-refresh)

;; Don't use Customize here, since that would set the variable's value
;; in stone, and I would miss out on future updates by Magit.
(add-hook 'git-commit-setup-hook 'git-commit-turn-on-flyspell)

(defun my/revision-at-point ()
  (cond
   ((derived-mode-p 'magit-mode)
    (magit-branch-or-commit-at-point))
   ((derived-mode-p 'vc-git-log-view-mode)
    (log-view-current-tag))
   ((derived-mode-p 'vc-annotate-mode)
    (car (vc-annotate-extract-revision-at-line)))))

(defun my/describe-revision (rev)
  "Format a Git revision in a format suitable for changelogs."
  (interactive
   (list (let ((rev (my/revision-at-point)))
           (read-string (format-prompt "Revision" rev)
                        nil nil rev))))
  (my/kill (string-trim
            (shell-command-to-string
             (format "git show --no-patch --date=short --format='%s' %s"
                     "%cd \"%s\" (%h)" rev)))))


;; Major modes configuration

(defun my/c-modes-hook ()
  (c-set-style "bsd")
  (c-set-offset 'arglist-close 0))

(add-hook 'c-mode-common-hook 'my/c-modes-hook)

(defun my/python-hook ()
  (setq-local forward-sexp-function nil))

(add-hook 'python-mode-hook 'my/python-hook)

(defun my/compilation-notify (buffer results)
  (let* ((title (buffer-name buffer))
         (status (if (string-equal results "finished\n") "success" "failure"))
         (icon (format "%s/icons/compilation-%s.png" user-emacs-directory status)))
    (require 'notifications)
    (notifications-notify :title title :body results :app-icon icon :timeout 3000)))

(add-to-list 'compilation-finish-functions 'my/compilation-notify)

(defun my/make-tabless (f)
  "Make a function which will run F with `indent-tabs-mode' disabled."
  (lambda ()
    (:documentation (format "Run `%s' with `indent-tabs-mode' set to nil." f))
    (interactive)
    (let ((indent-tabs-mode nil))
      (call-interactively f))))

(defun my/makefile-hook ()
  ;; I would rather align backslashes with spaces rather than tabs;
  ;; however, I would also like indent-tabs-mode to remain non-nil.
  (local-set-key (kbd "C-c C-\\") (my/make-tabless 'makefile-backslash-region))
  (local-set-key (kbd "M-q") (my/make-tabless 'fill-paragraph)))

(add-hook 'makefile-mode-hook 'my/makefile-hook)

(defun my/shell-hook ()
  (setq truncate-lines nil)
  (setq-local font-lock-comment-face 'default)
  (setq-local font-lock-string-face 'default)
  (setq-local recenter-positions '(top middle bottom)))

(add-hook 'shell-mode-hook 'my/shell-hook)

(add-hook 'dired-mode-hook 'diff-hl-dired-mode-unless-remote)

(add-to-list 'ibuffer-saved-filter-groups
             '("my/ibuffer-groups"
               ("REPL"
                (or (derived-mode . comint-mode)
                    (mode . lisp-interaction-mode)))
               ("Programming" (derived-mode . prog-mode))
               ("Folders" (mode . dired-mode))
               ("Messaging"
                (or (mode . erc-mode)
                    (mode . message-mode)
                    (derived-mode . gnus-mode)))
               ("Documentation"
                (or (mode . Info-mode)
                    (mode . Man-mode)
                    (mode . help-mode)))
               ("Version control"
                (or (derived-mode . magit-mode)
                    (name . "\\`\\*vc")))))

(add-hook 'ibuffer-mode-hook
          (lambda ()
            (ibuffer-switch-to-saved-filter-groups "my/ibuffer-groups")))

(eval-after-load 'org
  '(when (version< org-version "9.4")
       (define-key org-mode-map (kbd "C-j") 'org-return)
       (define-key org-mode-map (kbd "RET") 'org-return-indent)))


;; Helper functions and miscellaneous settings.

(defun my/froggify ()
  (ispell-change-dictionary "fr")
  (setq-local colon-double-space nil)
  (setq-local sentence-end-double-space nil)
  (setq-local fill-nobreak-predicate
              (cons 'fill-french-nobreak-p fill-nobreak-predicate))
  (setq-local my/froggified t))

(defun my/unfroggify ()
  (ispell-change-dictionary "default")
  (setq-local colon-double-space t)
  (setq-local sentence-end-double-space t)
  (setq-local fill-nobreak-predicate
              (remq 'fill-french-nobreak-p fill-nobreak-predicate))
  (setq-local my/froggified nil))

(defun my/croak ()
  (interactive)
  (if (and (boundp 'my/froggified) my/froggified)
      (my/unfroggify)
    (my/froggify)))

;; Utilities for mailing lists.
(defun my/kill-message-id ()
  (interactive)
  (my/kill (mail-header-message-id (gnus-summary-article-header))))

(defun my/describe-message (id url)
  (my/kill (format "%s\n%s\n"
                   (if (string-prefix-p "<" id)
                       id
                     (format "<%s>" id))
                   url)))

(defun my/describe-message-id (list id)
  "Format references from the Message-ID of a gnu.org list."
  (interactive
   (list
    (read-string "List: ")            ; TODO: default to current list.
    (let ((default-id
            (mail-header-message-id (gnus-summary-article-header))))
      (read-string (format-prompt "Message-ID" default-id)
                   nil nil default-id))))
  (with-current-buffer
      (url-retrieve-synchronously
       (concat
        ;; For some reason, literal "+" chars cause the search to fail.
        ;; Escape them.
        "https://lists.gnu.org/archive/cgi-bin/namazu.cgi"
        "?query=%2Bmessage-id:"
        (replace-regexp-in-string "\\+" "%2B" id)
        "&submit=Search!"
        "&idxname=" list))
    (search-forward-regexp
     (rx "<a href=\""
         (group "/archive/html/" (literal list) "/"
                (+ (any "0-9-")) "/msg" (+ (any "0-9")) ".html")
         "\">"))
    (let ((url (concat "https://lists.gnu.org" (match-string 1))))
      (my/describe-message id url))))

(defun my/describe-message-url (url)
  "Format references from an article archived on MHonArc."
  (interactive
   (list
    (let ((default (or (thing-at-point 'url)
                       (and (derived-mode-p 'eww-mode)
                            (shr-url-at-point nil)))))
      (read-string (format-prompt "URL" default) nil nil default))))
  (with-current-buffer (url-retrieve-synchronously url)
    (search-forward-regexp "^<!--X-Message-Id: \\(.+\\) -->$")
    (let ((id (xml-substitute-numeric-entities (match-string 1))))
      (my/describe-message id url))))

;; Font stuff 🤷🤦.  Emacs comes with sensible defaults (e.g. the
;; default fontset includes Symbola for various subgroups of the
;; "symbol" script), but no color font by default.
(when (>= emacs-major-version 27)
  ;; Prefer a color font for emojis.
  (set-fontset-font t 'symbol "Noto Color Emoji" nil 'prepend)
  ;; Make sure the default font does not get overzealous (⚠⚙).
  (setq use-default-font-for-symbols nil))

(defun my/project-root ()
  (when-let ((project (project-current)))
    (car (project-roots project))))

(defun my/project-name ()
  (when-let ((root (my/project-root)))
    (when (not (file-equal-p root "~"))
      (file-name-nondirectory (string-trim-right root "/")))))

(defun my/connection-name ()
  (when-let ((method (file-remote-p default-directory 'method)))
    (if (string-match-p "sudo" method)
        method
      (format "%s:%s" method (file-remote-p default-directory 'host)))))

(defun my/frame-title-format ()
  (let ((prefix
         ;; Messing with match data during redisplay is dangerous
         ;; (cf. bug#33697).
         (save-match-data
           ;; For some reason, calling filename-parsing functions
           ;; while TRAMP is busy opens the gates to Infinite
           ;; Minibuffer Recursion Hell.  Cautiously side-step that.
           (or
            (my/connection-name)
            (my/project-name)))))
    (concat (when prefix (format "[%s] " prefix))
            "%b")))

(setq frame-title-format '(:eval (my/frame-title-format)))

(setq-default paragraph-start (concat "[ 	]*- \\|" paragraph-start))

;; TODO: decruftify mode-line (e.g. remove superflous parens)