1 files changed, 129 insertions, 0 deletions

@@ -85,5 +85,134 @@ If `:separator' is the first of STRINGS, the next string will be
 used as a separator."
   (++concat #'format strings))
 
+(defun mapc-buffers (func &optional predicate)
+  "Map FUNC over buffers matching PREDICATE.
+Both FUNC and PREDICATE will be executed with no arguments and in
+the context of each buffer.
+
+If PREDICATE is nil or not given, map FUNC over all buffers."
+  (cl-loop for buf being the buffers
+           do (with-current-buffer buf
+                (when (and predicate
+                           (funcall predicate))
+                  (funcall func)))))
+
+(defun mapc-buffers-modes (func &rest modes)
+  "Map FUNC over buffers derived from MODES.
+FUNC will be executed with no arguments and in the context of
+each buffer."
+  (mapc-buffers func
+                (lambda ()
+                  (apply #'derived-mode-p modes))))
+
+(defun find-font (&rest fonts)
+  "Return the first font of FONTS that is installed."
+  (cl-loop with ffl = (font-family-list)
+           for font in fonts
+           if (member font ffl)
+           return font))
+
+(defmacro progress@around (fn message &optional name)
+  "Define :around advice for functions adding a simple progress reporter."
+  (let ((orig (gensym))
+        (args (gensym))
+        (prog (gensym)))
+    `(define-advice ,fn (:around (,orig &rest ,args) ,(or name 'progress))
+       ,(format "Add a simple progress reporter to %s." fn)
+       (let ((,prog (make-progress-reporter
+                     ,(format "%s..." (string-remove-suffix "..." message)))))
+         (apply ,orig ,args)
+         (progress-reporter-done ,prog)))))
+
+
+;;; Comment-or-uncomment-sexp
+;; from https://endlessparentheses.com/a-comment-or-uncomment-sexp-command.html
+
+(defun +lisp-uncomment-sexp (&optional n)
+  "Uncomment N sexps around point."
+  (interactive "P")
+  (let* ((initial-point (point-marker))
+         (inhibit-field-text-motion t)
+         (p)
+         (end (save-excursion
+                (when (elt (syntax-ppss) 4)
+                  (re-search-backward comment-start-skip
+                                      (line-beginning-position)
+                                      t))
+                (setq p (point-marker))
+                (comment-forward (point-max))
+                (point-marker)))
+         (beg (save-excursion
+                (forward-line 0)
+                (while (and (not (bobp))
+                            (= end (save-excursion
+                                     (comment-forward (point-max))
+                                     (point))))
+                  (forward-line -1))
+                (goto-char (line-end-position))
+                (re-search-backward comment-start-skip
+                                    (line-beginning-position)
+                                    t)
+                (ignore-errors
+                  (while (looking-at-p comment-start-skip)
+                    (forward-char -1)))
+                (point-marker))))
+    (unless (= beg end)
+      (uncomment-region beg end)
+      (goto-char p)
+      ;; Indentify the "top-level" sexp inside the comment.
+      (while (and (ignore-errors (backward-up-list) t)
+                  (>= (point) beg))
+        (skip-chars-backward (rx (syntax expression-prefix)))
+        (setq p (point-marker)))
+      ;; Re-comment everything before it.
+      (ignore-errors
+        (comment-region beg p))
+      ;; And everything after it.
+      (goto-char p)
+      (forward-sexp (or n 1))
+      (skip-chars-forward "\r\n[:blank:]")
+      (if (< (point) end)
+          (ignore-errors
+            (comment-region (point) end))
+        ;; If this is a closing delimiter, pull it up.
+        (goto-char end)
+        (skip-chars-forward "\r\n[:blank:]")
+        (when (eq 5 (car (syntax-after (point))))
+          (delete-indentation))))
+    ;; Without a prefix, it's more useful to leave point where
+    ;; it was.
+    (unless n
+      (goto-char initial-point))))
+
+(defun +lisp-comment-sexp--raw ()
+  "Comment the sexp at point or ahead of point."
+  (pcase (or (bounds-of-thing-at-point 'sexp)
+             (save-excursion
+               (skip-chars-forward "\r\n[:blank:]")
+               (bounds-of-thing-at-point 'sexp)))
+    (`(,l . ,r)
+     (goto-char r)
+     (skip-chars-forward "\r\n[:blank:]")
+     (save-excursion
+       (comment-region l r))
+     (skip-chars-forward "\r\n[:blank:]"))))
+
+(defun +lisp-comment-or-uncomment-sexp (&optional n)
+  "Comment the sexp at point and move past it.
+If already inside (or before) a comment, uncomment instead.
+With a prefix argument N, (un)comment that many sexps."
+  (interactive "P")
+  (if (or (elt (syntax-ppss) 4)
+          (< (save-excursion
+               (skip-chars-forward "\r\n[:blank:]")
+               (point))
+             (save-excursion
+               (comment-forward 1)
+               (point))))
+      (+lisp-uncomment-sexp n)
+    (dotimes (_ (or n 1))
+      (+lisp-comment-sexp--raw))))
+
 (provide 'acdw)
 ;;; acdw.el ends here