path: root/lisp/acdw.el

;;; acdw.el --- My Emacs extras  -*- lexical-binding: t; -*-

;;; Code:

(require 'cl-lib)
(require 'seq)

(defmacro defdir (name directory &optional docstring makedir)
  "Define a variable and a function NAME expanding to DIRECTORY.
DOCSTRING is applied to the variable; its default is DIRECTORY's
path.  If MAKEDIR is non-nil, the directory and its parents will
be created."
  (declare (indent 2) (doc-string 3))
  `(progn
     (defvar ,name (expand-file-name ,directory)
       ,(concat (or docstring (format "%s" directory)) "\n"
                "Defined by `defdir'."))
     (defun ,name (file &optional mkdir)
       ,(concat "Expand FILE relative to variable `" (symbol-name name) "'.\n"
                "If MKDIR is non-nil, parent directories are created.\n"
                "Defined by `defdir'.")
       (let ((file-name (expand-file-name
                         (convert-standard-filename file) ,name)))
         (when mkdir
           (make-directory (file-name-directory file-name) :parents))
         file-name))
     ,(if makedir
          `(make-directory ,directory :parents)
        `(unless (file-exists-p ,directory)
           (warn "Directory `%s' doesn't exist." ,directory)))))

(defun choose-executable (&rest programs)
  "Return the first of PROGRAMS that exists in the system's $PATH.
Each of PROGRAMS can be a single string, or a list.  If it's a list then its car
will be tested with `executable-find', and the entire list returned.  This
enables passing arguments to a calling function."
  (catch 'found
    (dolist (prog programs)
      (let ((exec (executable-find (car (ensure-list prog))))
            (args (cdr-safe prog)))
        (when exec
         (throw 'found (if args (cons exec args) exec)))))))

(defun file-string (file)
  "Return the contents of FILE as a string."
  (with-current-buffer (find-file-noselect file)
    (buffer-string)))

(defun unsmartify-region (begin end)
  "Replace \"smart\" punctuation with \"dumb\" counterparts."
  (interactive "*r")
  (save-excursion
    (goto-char begin)
    (while (re-search-forward  "[“”‘’–—]" end t)
      (let ((replace (pcase (match-string 0)
                       ((or "“" "”") "\"")
                       ((or "‘" "’") "'")
                       ("–" "--")
                       ("—" "---"))))
        (replace-match replace nil nil)))))

(defun ++concat (func strings)
  "Concat STRINGS processed by FUNC.
Each of STRINGS can be a bare string or a list.  Strings are
passed through as-is, but lists are passed to FUNC first as
arguments.  Finally, all the resulting strings are `mapconcat'-ed
together.

As a special case, if `:separator' is the first of STRINGS, the
string following will be used as a separator.  Otherwise, a
newline will be used."
  (let (separator)
    (when (eq (car strings) :separator)
      (setq separator (cadr strings)
            strings (cddr strings)))
    (mapconcat (lambda (s)
                 (cond
                  ((listp s) (apply func s))
                  ((stringp s) s)
                  (t (user-error "Bad argument: %S" s))))
               strings
               (or separator "\n"))))

(defun format-concat (&rest strings)
  "Concatenate formatted STRINGS.
Each of STRINGS can be a bare string or a list.  Bare strings are passed as-is
to `mapconcat' for concatenation and separation.  Lists, however, are passed to
`format' first.

If `:separator' is the first of STRINGS, the next string will be
used as a separator."
  (++concat #'format strings))

(defun list-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))))

(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)))))



;;; 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
                           (list-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))


;;; 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))))


;;; Random shit

(defun insert-iso-date (&optional arg)
  "Insert current date formatted ISO-8601 style.
When called with \\[universal-argument] \\[insert-iso-date],
include the time.  When called with \\[universal-argument]
\\[universal-argument] \\[insert-iso-date], prompt the user for the
`format-time-string' format to use."
  (interactive "P")
  (insert (format-time-string (pcase arg
                                ('nil "%F")
                                ('(4) "%FT%T%z")
                                (_ (read-string "Time format: "))))))

(defun unfill-paragraph ()
  "Unfill the current paragraph."
  (interactive)
  (let ((fill-column most-positive-fixnum)
        (fill-paragraph-function nil))
    (fill-paragraph)))

(provide 'acdw)
;;; acdw.el ends here