diff --git a/el-patch.el b/el-patch.el index 35b7841..46c5de7 100644 --- a/el-patch.el +++ b/el-patch.el @@ -226,6 +226,13 @@ This function lives halfway between `copy-sequence' and (cons (car tree) (el-patch--copy-semitree (cdr tree))) tree)) +(defun el-patch--advice-name (name variant) + "Return advice name for a given NAME, TYPE and VARIANT." + (intern + (format "%S@%s@el-patch--advice" + name + (if variant (format "%S" el-patch-variant) "")))) + (defun el-patch--resolve (form new &optional table) "Resolve a patch FORM. Return a list of forms to be spliced into the surrounding @@ -540,28 +547,50 @@ PATCH-DEFINITION is an unquoted list starting with `defun', (let ((definition (el-patch--resolve-definition patch-definition t))) ;; Then we parse out the definition type and symbol name. (cl-destructuring-bind (type name . body) definition - (let ((register-patch - `(let ((table (or (bound-and-true-p el-patch--patches) - (make-hash-table :test #'eq)))) - (setq el-patch--patches table) - (setq table - (puthash ',name - (gethash - ',name table - (make-hash-table :test #'eq)) - table)) - (setq table - (puthash ',type - (gethash - ',type table - (make-hash-table :test #'eq)) - table)) - (puthash el-patch-variant ',patch-definition table)))) + (let* ((advise (and el-patch-use-advice + ;; Only advice functions + (let* ((props (alist-get type + el-patch-deftype-alist)) + (classifier (plist-get props :classify))) + (and classifier + (equal + (caar (funcall classifier definition)) + 'function))) + ;; Patches must have the same name and + ;; same number of arguments + (let ((orig-def (el-patch--resolve-definition + (cl-subseq patch-definition 0 3) + nil))) + ;; Same name and same argument count + (and (equal name (nth 1 orig-def)) + (equal (length (nth 2 definition)) + (length (nth 2 orig-def))))) + 'advice)) + (register-patch + `(let ((table (or (bound-and-true-p el-patch--patches) + (make-hash-table :test #'eq)))) + (setq el-patch--patches table) + (setq table + (puthash ',name + (gethash + ',name table + (make-hash-table :test #'eq)) + table)) + (setq table + (puthash ',type + (gethash + ',type table + (make-hash-table :test #'equal)) + table)) + (puthash (cons ,(when advise `(quote ,advise)) + el-patch-variant) + ',patch-definition table)))) ;; If we need to validate the patch, then we also need to ;; register it at compile-time, not just at runtime. (when (and el-patch-validate-during-compile byte-compile-current-file) (eval register-patch t) - (el-patch-validate name type 'nomsg nil el-patch-variant)) + (el-patch-validate name type 'nomsg nil + (cons advise el-patch-variant))) `(progn ;; Register the patch in our hash. We want to do this right ;; away so that if there is an error then at least the user @@ -569,24 +598,10 @@ PATCH-DEFINITION is an unquoted list starting with `defun', ;; wrong). ,register-patch ;; Now we actually overwrite the current definition. - ,(if (and el-patch-use-advice - ;; Only advice functions - (let* ((props (alist-get type el-patch-deftype-alist)) - (classifier (plist-get props :classify))) - (and classifier - (equal - (car (funcall classifier definition)) - 'function))) - (let ((orig-def (el-patch--resolve-definition - (cl-subseq patch-definition 0 3) - nil))) - ;; Same name and same argument count - (and (equal name (nth orig-def 1)) - (equal (length (nth definition 2)) - (length (nth orig-def 2)))))) + ,(if advise ;; Use advice system - (let ((advice-name (intern (format "%S@el-patch--advice" - name)))) + (let ((advice-name (el-patch--advice-name name + el-patch-variant))) `(progn (el-patch--stealthy-eval ,(append @@ -595,7 +610,9 @@ PATCH-DEFINITION is an unquoted list starting with `defun', ;; Rest is the same (cddr definition)) ,(format - "This advice was defined by `el-patch' for `%S'." + ;; The new line before the name is to avoid + ;; long doc strings + "This advice was defined by `el-patch' for\n`%S'." name)) (advice-add (quote ,name) :override (quote ,advice-name)))) @@ -613,13 +630,11 @@ patched. NAME, TYPE, and VARIANT are as returned by `el-patch-get'." (interactive (el-patch--select-patch)) (if-let ((patch-definition (el-patch-get name type variant))) - (if (and el-patch-use-advice - (eq (cadr (el-patch--resolve-definition - (cl-subseq patch-definition 0 2) - t)) - name)) + (if (car variant) + ;; an advice, remove it (advice-remove name - (intern (format "%S@el-patch--advice" name))) + (el-patch--advice-name name (cdr variant))) + ;; Otherwise just re-evaluate original definition (eval `(el-patch--stealthy-eval ,(el-patch--resolve-definition @@ -975,9 +990,9 @@ See `el-patch-validate'." (let ((type-hash (gethash type patch-hash))) (dolist (variant (hash-table-keys type-hash)) (setq patch-count (1+ patch-count)) - (let ((el-patch-variant variant)) - (unless (el-patch-validate name type 'nomsg) - (setq warning-count (1+ warning-count))))))))) + (unless (el-patch-validate name type 'nomsg nil + variant) + (setq warning-count (1+ warning-count)))))))) (cond ((zerop patch-count) (user-error "No patches defined")) @@ -1061,17 +1076,27 @@ nil; see `el-patch-variant')." nil 'require-match))))) (type-hash (gethash type patch-hash)) - (options (mapcar #'symbol-name - (hash-table-keys type-hash))) - (variant (intern - (pcase (length options) - (0 (error "Internal `el-patch' error")) - (1 (car options)) - (_ (completing-read - "Which variant? " - options - nil - 'require-match)))))) + (options (hash-table-keys type-hash)) + (variant (pcase (length options) + (0 (error "Internal `el-patch' error")) + (1 (car options)) + (_ (let ((completing-options + (mapcar (lambda (x) + (cons (format "%s%S" + (or (and (car x) + "Advice: ") + "") + (cdr x)) + x)) + (hash-table-keys type-hash)))) + (alist-get + (completing-read + "Which variant? " + completing-options + nil + 'require-match) + completing-options + nil nil 'equal)))))) (list name type variant))) (defun el-patch--ediff-forms (name1 form1 name2 form2)