diff --git a/el-patch-template.el b/el-patch-template.el index efaa652..f1b963a 100644 --- a/el-patch-template.el +++ b/el-patch-template.el @@ -148,8 +148,8 @@ TABLE is a hashtable containing the bindings of `el-patch-let'" (mapcar (lambda (kv) (unless (symbolp (car kv)) - (error "Non-symbol (%s) as binding for `el-patch-let'" - (car kv))) + (user-error "Non-symbol (%s) as binding for `el-patch-let'" + (car kv))) (list (car kv) (cons (cadr kv) ;; The cdr is the resolution, nil for @@ -373,7 +373,7 @@ remaining unmatched forms." (cons match template) template) remainder-form) - ('no-match + (no-match ;; Ultimately, the matching did not ;; work, so undo the symbol resolution (puthash template old-entry table) @@ -474,7 +474,7 @@ matched to a form in DEFINITION." (plist-get ptemplate :old)))) (when matched (when matched-ptemplate - (error "A form matches multiple templates")) + (user-error "A form matches multiple templates")) (setq matched-forms-count matched matched-ptemplate ptemplate)))) (cond @@ -486,7 +486,7 @@ matched to a form in DEFINITION." ptemplates)) definition)) ((plist-get matched-ptemplate :matched) - (error "A template matches multiple forms")) + (user-error "A template matches multiple forms")) ((and (consp definition) (or (el-patch--any-template-p (car definition) @@ -496,7 +496,7 @@ matched to a form in DEFINITION." (el-patch--any-template-p (cdr definition) ptemplates (1- matched-forms-count))))) - (error "A form matching a template has subforms matching\ + (user-error "A form matching a template has subforms matching\ other templates")) (t ;; The old resolution of the template uniquely matches the definition @@ -571,21 +571,28 @@ being patched; TYPE is a symbol `defun', `defmacro', etc." (templates (cdr template-def)) (old-name (car (el-patch--resolve unresolved-name nil)))) (unless template-def - (error "The template definition of %S was not found" name)) + (user-error "Resolving `%s' template failed -- \ + Cannot find template definition" name)) (let* ((definition (or (el-patch--locate (list type old-name)) - (error "Cannot find definition for `%s'" - name))) + (user-error "Resolving `%s' template failed --\ + Cannot find definition" name))) (ptemplates (mapcar (lambda (template) (list :template template :old (el-patch--partial-old-resolve template) :matched nil)) templates)) - (patch (prog1 (el-patch--apply-template definition ptemplates) + (patch (prog1 + (condition-case err-handle + (el-patch--apply-template definition ptemplates) + (error + (user-error "Resolving `%s' template failed -- %s" + name (cdr err-handle)))) (cl-dolist (ptemplate ptemplates) (unless (plist-get ptemplate :matched) - (error - "At least one template did not match any form"))))) + (user-error + "Resolving `%s' template failed -- at least \ +one template did not match any form in" name))))) (props (alist-get type el-patch-deftype-alist))) (cons (intern (or (plist-get props :macro-name) @@ -699,8 +706,10 @@ if `el-patch-warn-on-eval-template' is non-nil, print a warning." (when el-patch-warn-on-eval-template (display-warning 'el-patch "Runtime evaluation of el-patch templates \ can be slow, consider byte-compiling.")) - (el-patch-eval-template resolved-name - (car qtype-name))))) + (condition-case-unless-debug err + (el-patch-eval-template resolved-name + (car qtype-name)) + (error (display-warning 'el-patch (error-message-string err))))))) ;; Stolen from `el-patch-validate' @@ -745,8 +754,8 @@ See also `el-patch-validate-all'." (error (progn (display-warning 'el-patch - (format "`%S' failed -- %s" name - (cadr err-handle))) + (format "`%s' failed -- %s" name + (error-message-string err-handle))) nil))) (when run-hooks (run-hooks 'el-patch-post-validate-hook)))) diff --git a/el-patch.el b/el-patch.el index 9cff914..46c5de7 100644 --- a/el-patch.el +++ b/el-patch.el @@ -151,6 +151,10 @@ loaded. You can toggle the `use-package' integration later using "Non-nil means to validate patches when byte-compiling." :type 'boolean) +(defcustom el-patch-use-advice nil + "Non-nil causes el-patch to use Emacs' advice system for patching." + :type 'list) + ;;;; Internal variables (defvar el-patch-variant nil @@ -222,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 @@ -536,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 @@ -565,9 +598,27 @@ PATCH-DEFINITION is an unquoted list starting with `defun', ;; wrong). ,register-patch ;; Now we actually overwrite the current definition. - (el-patch--stealthy-eval - ,definition - "This function was patched by `el-patch'.")))))) + ,(if advise + ;; Use advice system + (let ((advice-name (el-patch--advice-name name + el-patch-variant))) + `(progn + (el-patch--stealthy-eval + ,(append + (list (car definition) ;; Same type + advice-name) ;; Different name + ;; Rest is the same + (cddr definition)) + ,(format + ;; 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)))) + `(el-patch--stealthy-eval + ,definition + "This function was patched by `el-patch'."))))))) ;;;;; Removing patches @@ -579,10 +630,16 @@ 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))) - (eval `(el-patch--stealthy-eval - ,(el-patch--resolve-definition - patch-definition nil) - "This function was patched and then unpatched by `el-patch'.")) + (if (car variant) + ;; an advice, remove it + (advice-remove name + (el-patch--advice-name name (cdr variant))) + ;; Otherwise just re-evaluate original definition + (eval + `(el-patch--stealthy-eval + ,(el-patch--resolve-definition + patch-definition nil) + "This function was patched and then unpatched by `el-patch'."))) (error "There is no patch for %S %S" type name))) ;;;; Defining patch types @@ -933,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")) @@ -1019,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)