;;; ement-macros.el --- Ement macros                 -*- lexical-binding: t; -*-

;; Copyright (C) 2022-2023  Free Software Foundation, Inc.

;; Author: Adam Porter <adam@alphapapa.net>
;; Maintainer: Adam Porter <adam@alphapapa.net>

;; 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 <https://www.gnu.org/licenses/>.

;;; Commentary:

;;

;;; Code:

;;;; Requirements

(require 'map)

;;;; Debugging

(require 'warnings)

;; NOTE: Uncomment this form and `emacs-lisp-byte-compile-and-load' the file to enable
;; `ement-debug' messages.  This is commented out by default because, even though the
;; messages are only displayed when `warning-minimum-log-level' is `:debug' at runtime, if
;; that is so at expansion time, the expanded macro calls format the message and check the
;; log level at runtime, which is not zero-cost.

;; (eval-and-compile
;;   (setq-local warning-minimum-log-level nil)
;;   (setq-local warning-minimum-log-level :debug))

(cl-defmacro ement-debug (&rest args)
  "Display a debug warning showing the runtime value of ARGS.
The warning automatically includes the name of the containing
function, and it is only displayed if `warning-minimum-log-level'
is `:debug' at expansion time (otherwise the macro expands to a
call to `ignore' with ARGS and is eliminated by the
byte-compiler).  When debugging, the form also returns nil so,
e.g. it may be used in a conditional in place of nil.

Each of ARGS may be a string, which is displayed as-is, or a
symbol, the value of which is displayed prefixed by its name, or
a Lisp form, which is displayed prefixed by its first symbol.

Before the actual ARGS arguments, you can write keyword
arguments, i.e. alternating keywords and values.  The following
keywords are supported:

  :buffer BUFFER   Name of buffer to pass to `display-warning'.
  :level  LEVEL    Level passed to `display-warning', which see.
                   Default is :debug."
  ;; TODO: Can we use a compiler macro to handle this more elegantly?
  (pcase-let* ((fn-name (when byte-compile-current-buffer
                          (with-current-buffer byte-compile-current-buffer
                            ;; This is a hack, but a nifty one.
                            (save-excursion
                              (beginning-of-defun)
                              (cl-second (read (current-buffer)))))))
               (plist-args (cl-loop while (keywordp (car args))
                                    collect (pop args)
                                    collect (pop args)))
               ((map (:buffer buffer) (:level level)) plist-args)
               (level (or level :debug))
               (string (cl-loop for arg in args
                                concat (pcase arg
                                         ((pred stringp) "%S ")
                                         ((pred symbolp)
                                          (concat (upcase (symbol-name arg)) ":%S "))
                                         ((pred listp)
                                          (concat "(" (upcase (symbol-name (car arg)))
                                                  (pcase (length arg)
                                                    (1 ")")
                                                    (_ "...)"))
                                                  ":%S "))))))
    (if (eq :debug warning-minimum-log-level)
        `(let ((fn-name ,(if fn-name
                             `',fn-name
                           ;; In an interpreted function: use `backtrace-frame' to get the
                           ;; function name (we have to use a little hackery to figure out
                           ;; how far up the frame to look, but this seems to work).
                           `(cl-loop for frame in (backtrace-frames)
                                     for fn = (cl-second frame)
                                     when (not (or (subrp fn)
                                                   (special-form-p fn)
                                                   (eq 'backtrace-frames fn)))
                                     return (make-symbol (format "%s [interpreted]" fn))))))
           (display-warning fn-name (format ,string ,@args) ,level ,buffer)
           nil)
      `(ignore ,@args))))

;;;; Macros

(defmacro ement-alist (&rest pairs)
  "Expand to an alist of the keys and values in PAIRS."
  `(list ,@(cl-loop for (key value) on pairs by #'cddr
                    collect `(cons ,key ,value))))

;;;;; Anaphoric

;; We could just depend on dash.el and use --first, and anaphora.el (only
;; on MELPA, not ELPA) has aprog1, but in order to reduce dependencies...

(defmacro ement-afirst (form list)
  ;; Sometimes checkdoc is really annoying.  If I use "FORM returns" or
  ;; "FORM evaluates", it complains, so I can't have a clean linting.
  "Return the first element of LIST for which FORM is non-nil.
In FORM, `it' is bound to the element being tested."
  (declare (indent 1))
  `(cl-loop for it in ,list
            ;; Avoid the `when' clause's implicit binding of `it'.
            do (when ,form
                 (cl-return it))))

(defmacro ement-aprog1 (first &rest body)
  "Like `prog1', but FIRST's value is bound to `it' around BODY."
  (declare (indent 1))
  `(let ((it ,first))
     ,@body
     it))

(defmacro ement-singly (place-form &rest body)
  "If PLACE-FORM is nil, set it non-nil and eval BODY.
BODY should set PLACE-FORM to nil when BODY is eligible to run
again."
  (declare (indent defun))
  `(unless ,place-form
     (setf ,place-form t)
     ,@body))

;;;;; Progress reporters

;; MAYBE: Submit a `with-progress-reporter' macro to Emacs.

(defalias 'ement-progress-update #'ignore
  "By default, this function does nothing.  But inside
`ement-with-progress-reporter', it's bound to a function that
updates the current progress reporter.")

(defmacro ement-with-progress-reporter (args &rest body)
  "Eval BODY with a progress reporter according to ARGS.
ARGS is a plist of these values:

  :when  If specified, a form evaluated at runtime to determine
         whether to make and update a progress reporter.  If not
         specified, the reporter is always made and updated.

  :reporter  A list of arguments passed to
             `make-progress-reporter', which see.

Around BODY, the function `ement-progress-update' is set to a
function that calls `progress-reporter-update' on the progress
reporter (or if the :when form evaluates to nil, the function is
set to `ignore').  It optionally takes a VALUE argument, and
without one, it automatically updates the value from the
reporter's min-value to its max-value."
  (declare (indent defun))
  (pcase-let* ((progress-reporter-sym (gensym))
               (progress-value-sym (gensym))
               (start-time-sym (gensym))
               ((map (:when when-form) (:reporter reporter-args)) args)
               (`(,_message ,min-value ,_max-value) reporter-args)
               (update-fn `(cl-function
                            (lambda (&optional (value (cl-incf ,progress-value-sym)))
                              (ement-debug "Updating progress reporter to" value)
                              (progress-reporter-update ,progress-reporter-sym value)))))
    `(let* ((,start-time-sym (current-time))
            (,progress-value-sym (or ,min-value 0))
            (,progress-reporter-sym ,(if when-form
                                         `(when ,when-form
                                            (make-progress-reporter ,@reporter-args))
                                       `(make-progress-reporter ,@reporter-args))))
       ;; We use `cl-letf' rather than `cl-labels', because labels expand to lambdas and funcalls,
       ;; so other functions that call `ement-progress-update' wouldn't call this definition.
       (cl-letf (((symbol-function 'ement-progress-update)
                  ,(if when-form
                       `(if ,when-form
                            ,update-fn
                          #'ignore)
                     update-fn)))
         ,@body
         (ement-debug (format "Ement: Progress reporter done (took %.2f seconds)"
                              (float-time (time-subtract (current-time) ,start-time-sym))))))))

;;;;; Room-related macros

;; Prevent compiler from complaining that `value' is an unknown slot.
(require 'magit-section)

(cl-defmacro ement-with-room-and-session (&rest body)
  "Eval BODY with `ement-room' and `ement-session' bound.
If in an `ement-room-list-mode' buffer and `current-prefix-arg'
is nil, use the room and session at point.  If in an `ement-room'
buffer and `current-prefix-arg' is nil, use buffer-local value of
`ement-room' and `ement-session'.  Otherwise, prompt for them
with `ement-complete-room' or that given with :prompt-form.

BODY may begin with property list arguments, including:

  :prompt-form  A Lisp form evaluated for the binding of
                `ement-room'."
  (declare (indent defun))
  (pcase-let* ((plist (cl-loop while (keywordp (car body))
                               append (list (car body) (cadr body))
                               and do (setf body (cddr body))))
               (prompt-form (or (plist-get plist :prompt-form)
                                '(ement-complete-room :suggest t))))
    `(pcase-let* ((`[,list-room ,list-session] (if (eq 'ement-room-list-mode major-mode)
                                                   (oref (magit-current-section) value)
                                                 [nil nil]))
                  (ement-room (or list-room ement-room))
                  (ement-session (or list-session ement-session)))
       (when (or current-prefix-arg (not ement-room))
         (pcase-let ((`(,room ,session) ,prompt-form))
           (setf ement-room room
                 ement-session session)))
       ,@body)))

(defmacro ement-propertize (string &rest properties)
  "Like `propertize', but auto-set `font-lock-face' property.
If the `face' property is set, also set the `font-lock-face' property to
the same value."
  ;; This is a workaround for a change in `magit-section'; see
  ;; <https://github.com/alphapapa/ement.el/issues/331>.  By setting both face properties,
  ;; we should preserve backward compatibility.  Someday this can be removed and we'll
  ;; just call `propertize' again.
  (declare (indent defun))
  (when (and (member ''face properties)
             (not (member ''font-lock-face properties)))
    (pcase (plist-get properties ''face #'equal)
      ((or (pred atom) `(quote ,(pred atom)))
       `(propertize ,string ,@properties
                    'font-lock-face ,(plist-get properties ''face #'equal)))
      (_
       ;; Avoid evaluating the 'face property's form twice.
       (let ((value-form (plist-get properties ''face #'equal))
             (value-var (gensym "ement-propertize-")))
         (setf (plist-get properties ''face #'equal) value-var
               (plist-get properties ''font-lock-face #'equal) value-var)
         `(let ((,value-var ,value-form))
            (propertize ,string ,@properties)))))))

;;;; Variables


;;;; Customization


;;;; Commands


;;;; Functions


;;;; Footer

(provide 'ement-macros)

;;; ement-macros.el ends here
