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

;;; Code:

(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."
  (seq-find (lambda (x)
              (executable-find (car (ensure-list x))))
            programs))

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