From 4cf60c3fea16b60eb18c9a7d8403b75c89aeffef Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Fri, 21 Oct 2022 21:37:30 -0500 Subject: blhe --- lisp/+emacs.el | 18 ++++- lisp/+flyspell-correct.el | 4 +- lisp/+ispell.el | 97 +++++++++++++++++++++++++++ lisp/+org-capture.el | 12 ++-- lisp/+org.el | 167 ++++++++++++++++++++++++++++++++++++++++++++++ lisp/+tempo.el | 44 ++++++++++++ lisp/+window.el | 130 ++++++++++++++++++++++++++++++++++++ lisp/acdw.el | 113 ++++++++++++++++++++++++++----- lisp/pita.el | 64 ++++++++++++++++++ lisp/scule.el | 61 +++++++++++++++++ lisp/yoke.el | 72 +++++++++++--------- 11 files changed, 727 insertions(+), 55 deletions(-) create mode 100644 lisp/+ispell.el create mode 100644 lisp/+tempo.el create mode 100644 lisp/+window.el create mode 100644 lisp/pita.el create mode 100644 lisp/scule.el (limited to 'lisp') diff --git a/lisp/+emacs.el b/lisp/+emacs.el index 6f40cf0..8817c19 100644 --- a/lisp/+emacs.el +++ b/lisp/+emacs.el @@ -229,7 +229,7 @@ Do this only if the buffer is not visiting a file." (< (- (time-convert nil 'integer) +save-some-buffers-debounce-time) +save-some-buffers-debounce-timeout)) (save-some-buffers t) - (setq +save-some-buffers-debounce-time (time-convert nil 'integer)))) + (setf +save-some-buffers-debounce-time (time-convert nil 'integer)))) ;;; Better-default functions ... @@ -304,6 +304,11 @@ ARG is passed to `backward-kill-word'." ;; (advice-add #'yank :after #'+yank@indent) ;; (advice-add #'yank-pop :after #'+yank@indent) +;; https://old.reddit.com/r/emacs/comments/y92y4b/tramp_users_slowness_got_you_down_check/it3a35r/ +(defun +vc-off-when-remote () + (when (file-remote-p (buffer-file-name)) + (setq-local vc-handled-backends nil))) + ;;; Extra functions @@ -317,7 +322,7 @@ It returns nil with remote files and those without attached files." (defun +goto-matching-paren (&optional arg) "Go to the matching paren, similar to vi's %." (interactive "p") - (or arg (setq arg 1)) + (or arg (setf arg 1)) (cond ;; Check for "outside of bracket" positions ((looking-at "[\[\(\{]") (forward-sexp arg)) @@ -338,6 +343,15 @@ If the current window is the only window, bury the buffer." ;;; Required libraries +(when (require 'abbrev nil :noerror) + (setq-default abbrev-file-name (sync/ "abbrev.el") + save-abbrevs 'silent)) + +(when (require 'autorevert nil :noerror) + (setq-default global-auto-revert-non-file-buffers t + auto-revert-verbose nil) + (global-auto-revert-mode +1)) + (when (require 'uniquify nil :noerror) (setq-default uniquify-buffer-name-style 'forward uniquify-separator path-separator diff --git a/lisp/+flyspell-correct.el b/lisp/+flyspell-correct.el index f4fc956..9a33cc0 100644 --- a/lisp/+flyspell-correct.el +++ b/lisp/+flyspell-correct.el @@ -12,8 +12,8 @@ With PREFIX, prompt to change the current dictionary." (when prefix (let ((current-prefix-arg nil)) (call-interactively #'ispell-change-dictionary))) - (+with-message "Checking spelling" - (flyspell-correct-move (point-min) :forward :rapid))) + (with-message "Checking spelling" + (flyspell-correct-move (point-min) :forward :rapid))) (defun +flyspell-correct-buffer-h (&rest _) "Run `+flyspell-correct-buffer'. diff --git a/lisp/+ispell.el b/lisp/+ispell.el new file mode 100644 index 0000000..10c31b8 --- /dev/null +++ b/lisp/+ispell.el @@ -0,0 +1,97 @@ +;;; +ispell.el --- Customizations for `ispell' -*- lexical-binding: t; -*- + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) +(require 'seq) + +;; Utility function TODO: move elsewhere +(defun +ispell-append-removing-duplicates (&rest lists) + "Append LISTS, removing duplicates from the result. +Any keyword arguments to `cl-remove-duplicates' should come +before the LISTS." + (let (cl-remove-duplicates-args) + (while (keywordp (car lists)) + (push (pop lists) cl-remove-duplicates-args) + (push (pop lists) cl-remove-duplicates-args)) + (apply #'cl-remove-duplicates (apply #'append lists) + (nreverse cl-remove-duplicates-args)))) + +;;; Ispell in .dir-locals + +;; Let Emacs know a list of strings is safe +(defun +ispell-safe-local-p (list) + (and (listp list) + (seq-every-p #'stringp list))) + +;; Can I instruct ispell to insert LocalWords in a different file? +;; https://emacs.stackexchange.com/q/31396/2264 + +;; How can I move all my file-local LocalWords to .dir-locals.el? +;; https://emacs.stackexchange.com/q/31419 + +;; Adapted from ispell.el:ispell-buffer-local-words +(defun +ispell-buffer-local-words-list () + (let (words) + (or ispell-buffer-local-name + (setf ispell-buffer-local-name (buffer-name))) + (save-excursion + (goto-char (point-min)) + (while (search-forward ispell-words-keyword nil t) + (let ((end (point-at-eol)) + (ispell-casechars (ispell-get-casechars)) + string) + (while (re-search-forward " *\\([^ ]+\\)" end t) + (setf string (match-string-no-properties 1)) + (if (and (< 1 (length string)) + (equal 0 (string-match ispell-casechars string))) + (push string words)))))) + words)) + +;;;###autoload +(defun +ispell-move-buffer-words-to-dir-locals (&optional arg) + "Move the current buffer-local words to .dir-locals.el. +This function prompts the user to save .dir-locals.el, unless +prefix ARG is non-nil; then it just saves them." + (interactive "P") + (unless (buffer-file-name) + (user-error "Buffer not attached to file")) + (hack-dir-local-variables) + (let ((print-level nil) + (print-length nil)) + (when-let ((new-words (cl-remove-if (lambda (el) (eq el '\.\.\.)) ; XXX: NO IDEA + ; where this came from + (+ispell-append-removing-duplicates + :test #'string= + ispell-buffer-session-localwords + (alist-get 'ispell-buffer-session-localwords + dir-local-variables-alist) + (alist-get 'ispell-buffer-session-localwords + file-local-variables-alist) + (+ispell-buffer-local-words-list))))) + (save-excursion + (add-dir-local-variable + major-mode + 'ispell-buffer-session-localwords + (setf ispell-buffer-session-localwords + new-words)) + (when (or arg + (y-or-n-p "Save .dir-locals.el?")) + (save-buffer)) + (bury-buffer)) + (or ispell-buffer-local-name + (setf ispell-buffer-local-name (buffer-name))) + (save-excursion + (goto-char (point-min)) + (while (search-forward ispell-words-keyword nil t) + (delete-region (point-at-bol) (1+ (point-at-eol)))))))) + +;;;###autoload +(defun +ispell-move-buffer-words-to-dir-locals-hook () + "Convenience function for binding to a hook." + (+ispell-move-buffer-words-to-dir-locals t)) + +(provide '+ispell) +;;; +ispell.el ends here diff --git a/lisp/+org-capture.el b/lisp/+org-capture.el index 7ed4e00..06dfcfd 100644 --- a/lisp/+org-capture.el +++ b/lisp/+org-capture.el @@ -17,7 +17,7 @@ LIST defaults to `org-capture-templates'." ;; Set it up as a generic value. Based on the one for `alist-get'. (gv-define-expander +org-capture--get (lambda (do key &optional alist) - (setq alist (or alist org-capture-templates)) + (setf alist (or alist org-capture-templates)) (macroexp-let2 macroexp-copyable-p k key (gv-letplace (getter setter) alist (macroexp-let2 nil p `(assoc ,k ,getter 'equal) @@ -27,7 +27,7 @@ LIST defaults to `org-capture-templates'." (let ((set-exp `(if ,p (setcdr ,p ,v) ,(funcall setter - `(cons (setq ,p (cons ,k ,v)) + `(cons (setf ,p (cons ,k ,v)) ,getter))))) `(progn ,set-exp @@ -36,7 +36,7 @@ LIST defaults to `org-capture-templates'." (defun +org-capture-sort (&optional list) "Sort LIST by string keys. LIST is a symbol and defaults to `org-capture-templates'." - (setq list (or list 'org-capture-templates)) + (setf list (or list 'org-capture-templates)) (set list (sort (symbol-value list) (lambda (a b) (string< (car a) (car b)))))) @@ -68,9 +68,9 @@ SORT-AFTER, when set to t, will call properly process the variable." ;; LIST defaults to `org-capture-templates' (declare (indent 2)) - (unless list (setq list 'org-capture-templates)) + (unless list (setf list 'org-capture-templates)) ;; Ensure VALUE is a list to cons properly - (unless (listp value) (setq value (list value))) + (unless (listp value) (setf value (list value))) (when (> (length key) 1) ;; Check for existence of groups. (let ((expected (cl-loop for i from 1 to (1- (length key)) @@ -87,7 +87,7 @@ properly process the variable." (defun +org-template--ensure-path (keys &optional list) "Ensure path of keys exists in `org-capture-templates'." - (unless list (setq list 'org-capture-templates)) + (unless list (setf list 'org-capture-templates)) (when (> (length key) 1) ;; Check for existence of groups. (let ((expected (cl-loop for i from 1 to (1- (length key)) diff --git a/lisp/+org.el b/lisp/+org.el index b17a1fa..70962d6 100644 --- a/lisp/+org.el +++ b/lisp/+org.el @@ -1,5 +1,106 @@ ;;; +org.el --- -*- lexical-binding: t -*- +;;; Org Return DWIM +;; [[https://github.com/alphapapa/unpackaged.el][unpackaged]] and [[http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/][kitchin]] + +(defun +org-element-descendant-of (type element) + "Return non-nil if ELEMENT is a descendant of TYPE. +TYPE should be an element type, like `item' or `paragraph'. +ELEMENT should be a list like that returned by `org-element-context'." + ;; MAYBE: Use `org-element-lineage'. + (when-let* ((parent (org-element-property :parent element))) + (or (eq type (car parent)) + (+org-element-descendant-of type parent)))) + +(defun +org-return-dwim (&optional prefix) + "A helpful replacement for `org-return'. +With PREFIX, call `org-return'." + (interactive "P") + ;; Auto-fill if enabled + (when auto-fill-function + (dolist (func (ensure-list auto-fill-function)) + (funcall func))) + (cond + (prefix ; Handle prefix + (pcase prefix + ('(4) (newline)) + ('(16) (newline 2)) + (_ (newline prefix)))) + ((and org-return-follows-link ; Open link + (eq 'link (car (org-element-context)))) + (org-open-at-point-global)) + ((org-at-heading-p) ; Open a line after a heading + (let ((heading-start (org-entry-beginning-position))) + (goto-char (org-entry-end-position)) + (cond ((and (org-at-heading-p) + (= heading-start (org-entry-beginning-position))) + ;; Entry ends on its heading, so add 2 newlines + (end-of-line) + (newline 2)) + (t + ;; Entry ends after its heading, so back up + (forward-line -1) + (end-of-line) + (when (org-at-heading-p) + (forward-line) + (newline) + (forward-line -1)) + (while (not (looking-back (rx (repeat 3 (seq (optional blank) "\n"))) + nil)) + (newline)) + (forward-line -1))))) + ((org-at-item-checkbox-p) ; Insert a new checkbox item + (end-of-line) + (org-insert-todo-heading nil)) + ((org-in-item-p) ; Insert a new list item + (let* ((context (org-element-context)) + (first-item-p (eq 'plain-list (car context))) + (itemp (eq 'item (car context))) + (emptyp (or + ;; This (regular) list item is empty + (eq (org-element-property :contents-begin context) + (org-element-property :contents-end context)) + ;; This (definition) list item is empty + (looking-at " *::"))) + (item-child-p (+org-element-descendant-of 'item context))) + (cond ((and itemp emptyp) + (delete-region (line-beginning-position) (line-end-position)) + (newline)) + ((or first-item-p + (and itemp (not emptyp)) + item-child-p) + (org-end-of-item) + (org-insert-item)) + (t + (delete-region (line-beginning-position) (line-end-position)) + (newline))))) + ((and (fboundp 'org-inlinetask-in-task-p) ; Don't insert a new heading with + (org-inlinetask-in-task-p)) ; inline tasks + (org-return)) + ((org-at-table-p) ; Insert a new org-table row + (cond ((save-excursion + (beginning-of-line) + (cl-loop with end = (line-end-position) + for cell = (org-element-table-cell-parser) + always (equal (org-element-property :contents-begin cell) + (org-element-property :contents-end cell)) + while (re-search-forward "|" end t))) + ;; Empty row: end the table + (delete-region (line-beginning-position) (line-end-position)) + (org-return)) + (t + ;; Non-empty row + (org-return)))) + (t ; Otherwise---just call `org-return'. + (org-return)))) + +(defun +org-table-copy-down|+org-return (&optional n) + "Call `org-table-copy-down' or `+org-return' depending on context." + (interactive "P") + (if (org-table-check-inside-data-field 'noerror) + (org-table-copy-down (or n 1)) + (+org-return-dwim n))) + ;;; Copy org trees as HTML ;; Thanks to Oleh Krehel, via [[https://emacs.stackexchange.com/questions/54292/copy-results-of-org-export-directly-to-clipboard][this StackExchange question]]. @@ -41,4 +142,70 @@ and POST-PROCESS are passed to `org-export-to-file'." ("—" "---")))) (replace-match replace nil nil))))) +;;; A ... different ... `org-open-at-point-dwim' +;; I honestly don't remember what the difference is between this and the +;; O.G. one is.. hopefully this one fixes annoying stupid problems. + +(defun +org-open-at-point-dwim (&optional arg) + "Open thing at point, or if there isn't something, list things." + (interactive "P") + (save-excursion + (let* ((this-char-type (org-element-type (org-element-context))) + (prev-char-type (ignore-errors + (save-excursion + (backward-char) + (org-element-type (org-element-context))))) + (types '(citation citation-reference clock comment comment-block + footnote-definition footnote-reference headline + inline-src-block inlinetask keyword link + node-property planning src-block timestamp)) + (type this-char-type)) + (when (and (memq this-char-type types) (memq prev-char-type types)) + (backward-char) + (setq type prev-char-type)) ; what the fuckckckckck + ;; Okay, so this ^ is pretty janky and doesn't /really/ work that well, + ;; especially on DEADLINE (and probably SCHEDULED) lines. However, since + ;; I really just want to open the list of URLs /most of the time/, I'm + ;; fixing it like this instead. + (unless (and (memq type types) + (ignore-errors (org-open-at-point arg) + t)) + (while (not + (progn + (org-back-to-heading) + (car (org-offer-links-in-entry (current-buffer) (point) 1)))) + (org-up-heading-all 1)) + (org-open-at-point arg))))) + +;;; Skip invisible shit when moving around +(defun +org-ignore-invisible (fn &rest r) + ":around ADVICE to ignore invisible text in `org-mode' buffers." + ;; TODO: generalize to all modes + (cond ((and (derived-mode-p #'org-mode) + (org-invisible-p)) + (while (org-invisible-p) + (forward-char)) + (apply fn r)) + (t (apply fn r)))) + +;;; Faces + +;;; Better org faces +;; see `org-emphasis-alist' + +(defface org-bold '((t (:weight bold))) + "Bold face in `org-mode' documents.") + +(defface org-italic '((t (:slant italic))) + "Italic face in `org-mode' documents.") + +(defface org-underline '((t (:underline t))) + "Underline face in `org-mode' documents.") + +(defface org-strikethrough '((t (:strike-through t))) + "Strike-through face for `org-mode' documents.") + +;; `org-verbatim' and `org-code' are apparently already things, so we skip them +;; here. + (provide '+org) diff --git a/lisp/+tempo.el b/lisp/+tempo.el new file mode 100644 index 0000000..2324665 --- /dev/null +++ b/lisp/+tempo.el @@ -0,0 +1,44 @@ +;;; +tempo.el --- easier tempo definition -*- lexical-binding: t -*- + +(require 'tempo) + +;; TODO: I need to figure out where this function goes. +(defun delete2 (list &rest elems) + "Delete each element of ELEMS, and the next item, from LIST." + (let ((r nil)) + (while (consp list) + (if (member (car list) elems) + (setf list (cdr list)) + (setf r (cons (car list) r))) + (setf list (cdr list))) + (reverse r))) + +(defmacro define-tempo (tag doc &rest elements) + "Define a template and add its tag to MODE's abbrev-table. +TAG, DOC, and ELEMENTS are passed to `tempo-define-template', which see. +ABBREV, if given, is the abbrev string to use for template expansion +under MODE's abbrev-table. If ABBREV isn't given, TAG will be used." + (declare (indent 1)) + (let* ((template (gensym)) + (tag (cond ((stringp tag) tag) + ((symbolp tag) (symbol-name tag)) + (t (user-error "TAG must be a string or symbol: %S" tag)))) + (mode (or (plist-get elements :mode) nil)) + (abbrev (or (plist-get elements :abbrev) tag)) + (taglist (or (plist-get elements :taglist) nil)) + (table (let ((tname (and mode (derived-mode-abbrev-table-name mode)))) + (while (and tname (not (memq tname abbrev-table-name-list))) + (setq tname (and (get mode 'derived-mode-parent) + (derived-mode-abbrev-table-name + (get mode 'derived-mode-parent))))) + (or tname 'global-abbrev-table))) + (elements (delete2 elements :mode :abbrev :taglist))) + `(let ((,template (tempo-define-template ,tag + ',elements + ,tag + ,doc + ,taglist))) + (define-abbrev ,table ,tag "" ,template :system t) + (put ,template 'no-self-insert t)))) + +(provide '+tempo) diff --git a/lisp/+window.el b/lisp/+window.el new file mode 100644 index 0000000..52b3712 --- /dev/null +++ b/lisp/+window.el @@ -0,0 +1,130 @@ +;;; +window.el --- Fixes for Emacs's window.el -*- lexical-binding: t; -*- + +;;; Commentary: + +;; Do I want to propose this change in the Emacs ML? + +;;; Code: + +(require 'window) + +;;; Split windows based on `window-total-width', not `window-width' +;; I have to just redefine these functions because the check is really deep in +;; there. + +(defun window-splittable-p (window &optional horizontal) + "Return non-nil if `split-window-sensibly' may split WINDOW. +Optional argument HORIZONTAL nil or omitted means check whether +`split-window-sensibly' may split WINDOW vertically. HORIZONTAL +non-nil means check whether WINDOW may be split horizontally. + +WINDOW may be split vertically when the following conditions +hold: +- `window-size-fixed' is either nil or equals `width' for the + buffer of WINDOW. +- `split-height-threshold' is an integer and WINDOW is at least as + high as `split-height-threshold'. +- When WINDOW is split evenly, the emanating windows are at least + `window-min-height' lines tall and can accommodate at least one + line plus - if WINDOW has one - a mode line. + +WINDOW may be split horizontally when the following conditions +hold: +- `window-size-fixed' is either nil or equals `height' for the + buffer of WINDOW. +- `split-width-threshold' is an integer and WINDOW is at least as + wide as `split-width-threshold'. +- When WINDOW is split evenly, the emanating windows are at least + `window-min-width' or two (whichever is larger) columns wide." + (when (and (window-live-p window) + (not (window-parameter window 'window-side))) + (with-current-buffer (window-buffer window) + (if horizontal + ;; A window can be split horizontally when its width is not + ;; fixed, it is at least `split-width-threshold' columns wide + ;; and at least twice as wide as `window-min-width' and 2 (the + ;; latter value is hardcoded). + (and (memq window-size-fixed '(nil height)) + ;; Testing `window-full-width-p' here hardly makes any + ;; sense nowadays. This can be done more intuitively by + ;; setting up `split-width-threshold' appropriately. + (numberp split-width-threshold) + (>= (window-total-width window) + (max split-width-threshold + (* 2 (max window-min-width 2))))) + ;; A window can be split vertically when its height is not + ;; fixed, it is at least `split-height-threshold' lines high, + ;; and it is at least twice as high as `window-min-height' and 2 + ;; if it has a mode line or 1. + (and (memq window-size-fixed '(nil width)) + (numberp split-height-threshold) + (>= (window-height window) + (max split-height-threshold + (* 2 (max window-min-height + (if mode-line-format 2 1)))))))))) + +(defun split-window-sensibly (&optional window) + "Split WINDOW in a way suitable for `display-buffer'. +WINDOW defaults to the currently selected window. +If `split-height-threshold' specifies an integer, WINDOW is at +least `split-height-threshold' lines tall and can be split +vertically, split WINDOW into two windows one above the other and +return the lower window. Otherwise, if `split-width-threshold' +specifies an integer, WINDOW is at least `split-width-threshold' +columns wide and can be split horizontally, split WINDOW into two +windows side by side and return the window on the right. If this +can't be done either and WINDOW is the only window on its frame, +try to split WINDOW vertically disregarding any value specified +by `split-height-threshold'. If that succeeds, return the lower +window. Return nil otherwise. + +By default `display-buffer' routines call this function to split +the largest or least recently used window. To change the default +customize the option `split-window-preferred-function'. + +You can enforce this function to not split WINDOW horizontally, +by setting (or binding) the variable `split-width-threshold' to +nil. If, in addition, you set `split-height-threshold' to zero, +chances increase that this function does split WINDOW vertically. + +In order to not split WINDOW vertically, set (or bind) the +variable `split-height-threshold' to nil. Additionally, you can +set `split-width-threshold' to zero to make a horizontal split +more likely to occur. + +Have a look at the function `window-splittable-p' if you want to +know how `split-window-sensibly' determines whether WINDOW can be +split." + (let ((window (or window (selected-window)))) + (or (and (window-splittable-p window) + ;; Split window vertically. + (with-selected-window window + (split-window-below))) + (and (window-splittable-p window t) + ;; Split window horizontally. + (with-selected-window window + (split-window-right))) + (and + ;; If WINDOW is the only usable window on its frame (it is + ;; the only one or, not being the only one, all the other + ;; ones are dedicated) and is not the minibuffer window, try + ;; to split it vertically disregarding the value of + ;; `split-height-threshold'. + (let ((frame (window-frame window))) + (or + (eq window (frame-root-window frame)) + (catch 'done + (walk-window-tree (lambda (w) + (unless (or (eq w window) + (window-dedicated-p w)) + (throw 'done nil))) + frame nil 'nomini) + t))) + (not (window-minibuffer-p window)) + (let ((split-height-threshold 0)) + (when (window-splittable-p window) + (with-selected-window window + (split-window-below)))))))) + +(provide '+window) +;;; +window.el ends here diff --git a/lisp/acdw.el b/lisp/acdw.el index 444f249..f039540 100644 --- a/lisp/acdw.el +++ b/lisp/acdw.el @@ -30,20 +30,20 @@ the filesystem, unless INHIBIT-MKDIR is non-nil." ;;; Convenience functions -(defun define-keys (maps &rest keydefs) +(defun define-key* (maps &rest keydefs) "Define KEYDEFS in MAPS. Convenience wrapper around `define-key'." (unless (zerop (mod (length keydefs) 2)) (user-error "Wrong number of arguments: %S" (length keydefs))) (dolist (map (if (or (atom maps) (eq (car maps) 'keymap)) - (list maps) - maps)) + (list maps) + maps)) (cl-loop for (key def) on keydefs by #'cddr - do (let ((key (if (stringp key) (kbd key) key))) - (define-key (if (symbolp map) - (symbol-value map) - map) - key def))))) + do (let ((key (if (stringp key) (kbd key) key))) + (define-key (if (symbolp map) + (symbol-value map) + map) + key def))))) (unless (fboundp 'ensure-list) ;; Just in case we're using an old version of Emacs. @@ -57,10 +57,11 @@ not a list, return a one-element list containing OBJECT." (defun add-to-list* (lists &rest things) "Add THINGS to LISTS. -LISTS can be one list variable or a list. -Each thing of THINGS can be either a variablel (the thing), or a list of the form +LISTS can be one list variable or a list. Each thing of THINGS +can be either a variablel (the thing), or a list of the form (ELEMENT &optional APPEND COMPARE-FN), which is passed to `add-to-list'." + (declare (indent 1)) (dolist (l (ensure-list lists)) (dolist (thing things) (apply #'add-to-list l (ensure-list thing))))) @@ -69,26 +70,73 @@ Each thing of THINGS can be either a variablel (the thing), or a list of the for "Add FUNCTIONS to HOOKS. Each function in FUNCTIONS can be a singleton or a list of the form (FUNCTION &optional DEPTH LOCAL)." + (declare (indent 1)) (dolist (hook (ensure-list hooks)) (dolist (fn functions) (apply #'add-hook hook (ensure-list fn))))) +(defun +concat (&rest strings) + "Concat STRINGS separated by SEPARATOR. +SEPARATOR is \"\\n\" unless the keyword argument `:separator' is +given, followed by the separator to use. Each item in STRINGS is +either a string or a list or strings, which is concatenated +without any separator." + (let (ret + ;; I don't know why a `cl-defun' with + ;; (&rest strings &key (separator "\n")) doesn't work + (separator (or (cl-loop for i from 0 upto (length strings) + if (eq (nth i strings) :separator) + return (nth (1+ i) strings)) + "\n"))) + (while strings + (let ((string (pop strings))) + (cond ((eq string :separator) (pop strings)) + ((listp string) (push (apply #'concat string) ret)) + ((stringp string) (push string ret))))) + (mapconcat #'identity (nreverse ret) separator))) + +(defun require* (&rest features) + "Require FEATURES in order. +Each feature of FEATURES can also be a list of the arguments to +pass to `require', which see." + (condition-case e + (dolist (feature features) + (apply #'require (ensure-list feature))) + (:success (mapcar (lambda (f) (car (ensure-list f))) features)) + (t (signal (car e) (cdr e))))) + ;;; Convenience macros +(defmacro define-local-before-save-hook (mode-or-hook &rest body) + "Add a local `before-save-hook' to MODE-OR-HOOK." + (declare (indent 1)) + (let* ((name (format "%s" mode-or-hook)) + (external-name (intern (format "%s@before-save" name))) + (internal-name (intern (format "before-save@%s" name))) + (hook (if (string-suffix-p "-hook" name) + mode-or-hook + (intern (format "%s-hook" name))))) + `(progn + (defun ,internal-name () + ,@body) + (defun ,external-name () + (add-hook 'before-save-hook #',internal-name nil :local)) + (add-hook ',hook #',external-name)))) + (defmacro setq-local-hook (hook &rest args) "Run `setq-local' on ARGS when running HOOK." (declare (indent 1)) (let ((fn (intern (format "%s-setq-local" hook)))) (when (and (fboundp fn) - (functionp fn)) - (setq args (append (function-get fn 'setq-local-hook-settings) args))) + (functionp fn)) + (setf args (append (function-get fn 'setq-local-hook-settings) args))) (unless (and (< 0 (length args)) - (zerop (mod (length args) 2))) + (zerop (mod (length args) 2))) (user-error "Wrong number of arguments: %S" (length args))) `(progn (defun ,fn () - ,(format "Set local variables after `%s'." hook) - (setq-local ,@args)) + ,(format "Set local variables after `%s'." hook) + (setq-local ,@args)) (function-put ',fn 'setq-local-hook-settings ',args) (add-hook ',hook #',fn)))) @@ -103,3 +151,38 @@ If body executes without errors, MESSAGE...Done will be displayed." ,@body) (:success (message "%s...done" ,msg)) (t (signal (car e) (cdr e))))))) + +;; https://emacs.stackexchange.com/a/39324/37239 +;; XXX: This shit don't work rn +(defun ignore-invisible-overlays (fn) + "Execute FN, ignoring invisible overlays. +FN should return a point." + (let ((overlay nil) + (point nil)) + (setq point (and (funcall fn) (point))) + (setq overlay (car (overlays-at (point)))) + (while (and overlay (member 'invisible (overlay-properties overlay))) + (goto-char (overlay-end overlay)) + (setq point (and (funcall fn) (point))) + (setq overlay (car (overlays-at (point))))) + point)) + +;;; Extras +;; Trying to avoid a whole install of crux ... + +(defun kill-and-join-forward (&optional arg) + "Kill the line or, if at the end of a line, join with the next. +This command is `visual-line-mode'-aware. If ARG is provided, +it's passed on to kill a line, but not to delete indentation. +When joining, this command deletes whitespace." + (interactive "P") + (if (and (eolp) (not (bolp))) + (delete-indentation 1) + (funcall (if visual-line-mode #'kill-visual-line #'kill-line) arg))) + +(defun other-window|switch-buffer () + "Call `other-window' or `switch-buffer' depending on windows." + (interactive) + (if (one-window-p) + (switch-to-buffer nil) + (other-window 1))) diff --git a/lisp/pita.el b/lisp/pita.el new file mode 100644 index 0000000..92ebf1b --- /dev/null +++ b/lisp/pita.el @@ -0,0 +1,64 @@ +;;; pita.el --- wrappers making emacs less of a PITA -*- lexical-binding: t -*- +;; 🥙 + +(defmacro with-message (msg &rest body) + (declare (indent 1)) + (when (listp msg) + (setq msg (apply #'format (car msg) (cdr msg)))) + (when (string-match "[[:alnum:]]\\'" msg) + (setq msg (concat msg "..."))) + (let ((m (gensym)) + (r (gensym))) + `(let ((,m ,msg) + (,r nil)) + (condition-case e + (setq r (progn (message ,m) ,@body)) + (:success (message "%s done" ,m) r) + (t (signal (car e) (cdr e))))))) + +(defun walk-tree-replace (tree find replace) + (let ((r nil)) + (dolist (form tree) + (push (cond ((eq find form) replace) + ((listp form) + (walk-tree-replace form find replace)) + (t form)) + r)) + (reverse r))) + +(defmacro with-pr (msg &rest body) + (declare (indent 1)) + (when (listp msg) + (setq msg (apply #'format (car msg) (cdr msg)))) + (when (string-match "[[:alnum:]]\\'" msg) + (setq msg (concat msg "..."))) + (let ((pr (gensym)) + (m (gensym))) + `(let* ((,m ,msg) + (,pr (unless (minibufferp) + (make-progress-reporter ,m)))) + ,@(or (and pr (walk-tree-replace body '@ `(progress-reporter-update ,pr))) + body) + (and ,pr (progress-reporter-done ,pr))))) + + +;;; crux advices +;; these should all go :before the function they're advising. + +(defun with-region-or-buffer (&rest _) + (interactive (if mark-active + (list (region-beginning) (region-end)) + (list (point-min) (point-max))))) + +(defun with-region-or-line (&rest _) + (interactive (if mark-active + (list (region-beginning) (region-end)) + (list (line-beginning-position) (line-end-position))))) + +(defun with-region-or-to-eol (&rest _) + (interactive (if mark-active + (list (region-beginning) (region-end)) + (list (point) (line-end-position))))) + +(provide 'pita) +;;; pita.el ends here diff --git a/lisp/scule.el b/lisp/scule.el new file mode 100644 index 0000000..3ed58bb --- /dev/null +++ b/lisp/scule.el @@ -0,0 +1,61 @@ +;;; scule.el --- -scule twiddling -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Case Duckworth + +;; Author: Case Duckworth +;; Keywords: convenience + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; DWIM functions for twiddling "scule", or text case (a fancy word for "upper +;; case" is "magiscule", for example, and "lower case" is "miniscule"). + +;;; Code: + +(require 'thingatpt) + +;;; Utility macro +;;;###autoload +(defmacro defscule (name &optional region-fn word-fn) + (let ((fn-name (intern (format "scule-%s" name))) + (region-fn (or region-fn (intern (format "%s-region" name)))) + (word-fn (or word-fn (intern (format "%s-word" name))))) + `(defun ,fn-name (arg) + ,(concat (capitalize (symbol-name name)) " words in the region if active, or word at point.\n" + "If the region is active, call `" (symbol-name region-fn) "'.\n" + "Otherwise, it calls `" (symbol-name word-fn) "' on the word at point and\n" + "the following ARG - 1 words.") + (interactive "*p") + (if (use-region-p) + (,region-fn (region-beginning) (region-end) (region-noncontiguous-p)) + (let ((word-bound (save-excursion + (skip-chars-forward "^[:word:]") + (bounds-of-thing-at-point 'word)))) + (when (and (car word-bound) (cdr word-bound)) + (,region-fn (car word-bound) (cdr word-bound)) + (goto-char (cdr word-bound)) + (,word-fn (1- arg)))))))) + +;;;###autoload +(progn (defscule upcase) + (autoload 'scule-upcase "scule" nil t) + (defscule downcase) + (autoload 'scule-downcase "scule" nil t) + (defscule capitalize) + (autoload 'scule-capitalize "scule" nil t)) + +(provide 'scule) +;;; scule.el ends here diff --git a/lisp/yoke.el b/lisp/yoke.el index 4f40869..68b02c4 100644 --- a/lisp/yoke.el +++ b/lisp/yoke.el @@ -47,20 +47,20 @@ installed to `yoke-dir'." (let ((generated-autoload-file (expand-file-name (format "%s-autoloads.el" pkg) dir)) (backup-inhibited t) - (version-control 'never) - (message-log-max nil) - (inhibit-message t)) - (unless (file-exists-p generated-autoload-file) - (let ((find-file-hook nil) - (write-file-functions nil) - (debug-on-error nil) - (left-margin 0)) - (if (fboundp 'make-directory-autoloads) - (make-directory-autoloads dir generated-autoload-file) - (and (fboundp 'update-directory-autoloads) - (update-directory-autoloads dir))))) - (when-let ((buf (find-buffer-visiting generated-autoload-file))) - (kill-buffer buf)) + (version-control 'never) + (message-log-max nil) + (inhibit-message t)) + (unless (file-exists-p generated-autoload-file) + (let ((find-file-hook nil) + (write-file-functions nil) + (debug-on-error nil) + (left-margin 0)) + (if (fboundp 'make-directory-autoloads) + (make-directory-autoloads dir generated-autoload-file) + (and (fboundp 'update-directory-autoloads) + (update-directory-autoloads dir))))) + (when-let ((buf (find-buffer-visiting generated-autoload-file))) + (kill-buffer buf)) (load generated-autoload-file :noerror :nomessage))) (t (user-error "Directory \"%s\" doesn't exist." dir))) dir)) @@ -83,13 +83,13 @@ Similar-ish to `plist-get', but works on non-proper plists." ,g)))) (defun delete2 (list &rest elems) - "Delete ELEM and the next item from LIST." + "Delete each element of ELEMS, and the next item, from LIST." (let ((r nil)) (while (consp list) (if (member (car list) elems) - (setq list (cdr list)) - (setq r (cons (car list) r))) - (setq list (cdr list))) + (setf list (cdr list)) + (setf r (cons (car list) r))) + (setf list (cdr list))) (reverse r))) (defun eval-after-init (fn) @@ -105,17 +105,17 @@ FEATURES can be an atom or a list; as an atom it works like `with-eval-after-load'. The special feature `init' will evaluate BODY after Emacs is finished initializing." (declare (indent 1) - (debug (form def-body))) + (debug (form def-body))) (if (eq features 'init) `(eval-after-init (lambda () ,@body)) (unless (listp features) - (setq features (list features))) + (setf features (list features))) (if (null features) - (macroexp-progn body) + (macroexp-progn body) (let* ((this (car features)) - (rest (cdr features))) - `(with-eval-after-load ',this - (eval-after ,rest ,@body)))))) + (rest (cdr features))) + `(with-eval-after-load ',this + (eval-after ,rest ,@body)))))) (defun yoke-pkg-name (pkg) (intern (format "yoke:%s" pkg))) @@ -131,7 +131,7 @@ BODY after Emacs is finished initializing." (unless nil unlessp) ; :unless PREDICATE &allow-other-keys) "Yoke a PKG into your Emacs session." - (declare (indent defun)) + (declare (indent 2)) (let ((name (yoke-pkg-name pkg)) (body (delete2 body :depends :when :unless :after :load))) @@ -141,11 +141,11 @@ BODY after Emacs is finished initializing." (*yoke-repo* ,repo) (*yoke-dest* ,(when repo `(yoke-repo-dir ',pkg ,repo)))) ,@(cond - ((and whenp unlessp) - `((when (or (not ,when) ,unless) - (cl-return-from ,name nil)))) - (whenp `((unless ,when (cl-return-from ,name nil)))) - (unlessp `((when ,unless (cl-return-from ,name nil))))) + ((and whenp unlessp) + `((when (or (not ,when) ,unless) + (cl-return-from ,name nil)))) + (whenp `((unless ,when (cl-return-from ,name nil)))) + (unlessp `((when ,unless (cl-return-from ,name nil))))) ,@(cl-loop for (pkg* repo* load-path*) in depends collect `(or (yoke-lasso ',pkg* ,repo* ,load-path*) (cl-return-from ,name nil))) @@ -157,3 +157,15 @@ BODY after Emacs is finished initializing." body)) (:success ',pkg) (t (message "%s: %s" ',name e)))))) + +;;; Extras + +(defun yoke-imenu-insinuate () + "Insinuate `yoke' forms for `imenu'." + (require 'imenu) + (setf (alist-get "Yoke" imenu-generic-expression nil nil #'equal) + (list (rx (: "(yoke" (+ space) + (group (+ (not space))) + (+ space) + (group (+ (not space))))) + 1))) -- cgit 1.4.1-21-gabe81