diff --git a/dynamic-mixins/dynamic-mixins-swm.asd b/dynamic-mixins/dynamic-mixins-swm.asd index 8073d8e..b20a72c 100644 --- a/dynamic-mixins/dynamic-mixins-swm.asd +++ b/dynamic-mixins/dynamic-mixins-swm.asd @@ -15,4 +15,5 @@ :components ((:file "package") + (:file "sorting") (:file "dynamic-mixins"))) diff --git a/dynamic-mixins/src/dynamic-mixins.lisp b/dynamic-mixins/src/dynamic-mixins.lisp index ed799d4..1b0f22c 100644 --- a/dynamic-mixins/src/dynamic-mixins.lisp +++ b/dynamic-mixins/src/dynamic-mixins.lisp @@ -33,12 +33,16 @@ instance; further elements must be class names or classes." (slot-value (class-of object-or-class) 'classes)) (t (list (class-of object-or-class)))))) (make-mix-list - :list (remove-duplicates - (append (mapcar #'%find-class class-list) - class0))))) + :list (sort (remove-duplicates + (append (mapcar #'%find-class class-list) + class0)) + 'symbol-before-p + :key 'class-name)))) (defun mix (&rest classes) - (make-mix-list :list (remove-duplicates (mapcar #'%find-class classes)))) + (make-mix-list :list (sort (remove-duplicates (mapcar #'%find-class classes)) + 'symbol-before-p + :key 'class-name))) (defun set-superclasses (class list) (reinitialize-instance class :direct-superclasses list)) diff --git a/dynamic-mixins/src/package.lisp b/dynamic-mixins/src/package.lisp index af3a063..ebd7ca4 100644 --- a/dynamic-mixins/src/package.lisp +++ b/dynamic-mixins/src/package.lisp @@ -2,4 +2,5 @@ (:use #:cl #:alexandria) (:export #:mixin-class #:mixin-object #:mixin-classes #:ensure-mix #:delete-from-mix #:mix - #:replace-class #:replace-class-in-mixin)) + #:replace-class #:replace-class-in-mixin + #:set-rule #:*class-ordering-rules*)) diff --git a/dynamic-mixins/src/sorting.lisp b/dynamic-mixins/src/sorting.lisp new file mode 100644 index 0000000..eb5b9f6 --- /dev/null +++ b/dynamic-mixins/src/sorting.lisp @@ -0,0 +1,43 @@ +(in-package :dynamic-mixins-swm) + +(defvar *class-ordering-rules* nil + "A plist of rules for how to order classes for mixing. Keys are the class +names. Rules have the following shape: + +(:before ((string-1 . package-designator-1) + (string-2 . package-designator-2) + ... + (string-n . package-designator-n)) + :after ((string-1 . package-designator-1) + (string-2 . package-designator-2) + ... + (string-n . package-designator-n)))") + +(defun set-rule (symbol before after) + "Add or replace a class ordering rule for SYMBOL." + (setf (getf *class-ordering-rules* symbol) (list :before before :after after))) + +(defun symbol-ordering-rules (symbol) + (getf *class-ordering-rules* symbol)) + +(defun symbol-ordering-rules-before-list (symbol &optional rules) + (getf (or rules (symbol-ordering-rules symbol)) :before)) + +(defun symbol-ordering-rules-after-list (symbol &optional rules) + (getf (or rules (symbol-ordering-rules symbol)) :after)) + +(defun symbol-spec-match (symbol spec) + (let ((p (find-package (cdr spec)))) + (when p + (eq (find-symbol (string (car spec)) p) + symbol)))) + +(defun symbol-before-p (s1 s2) + "Return truthy if S1 should be before S2." + (or (find s2 (symbol-ordering-rules-before-list s1) :test #'symbol-spec-match) + (find s1 (symbol-ordering-rules-after-list s2) :test #'symbol-spec-match))) + +(defun symbol-after-p (s1 s2) + "Return truthy if S1 should be after S2." + (or (find s2 (symbol-ordering-rules-after-list s1) :test #'symbol-spec-match) + (find s1 (symbol-ordering-rules-before-list s2) :test #'symbol-spec-match))) diff --git a/minor-modes.lisp b/minor-modes.lisp index 88eb07d..1697999 100644 --- a/minor-modes.lisp +++ b/minor-modes.lisp @@ -601,7 +601,9 @@ ROOT-MAP-SPEC." (:enable-when . t) (:make-hooks . 1) (:default-initargs . t) - (:define-command-definer . 1))) + (:define-command-definer . 1) + (:mix-before . t) + (:mix-after . t))) (all-vals '()) (other-opts '())) (flet ((collect-values (option) @@ -1017,6 +1019,24 @@ are active only when the minor mode is active. Commands defined with this macro have the special variable *MINOR-MODE* bound to the minor mode object in their body. The generated macro is called DEFINE-MODE-COMMAND. This option defaults to T. + +@item +(:MIX-BEFORE &REST RULES)@* +The :MIX-BEFORE option defines rules on the order this class should be mixed in +relative to other minor modes. This allows the implementer of a minor mode to +make the mixing process aware of dependencies that dont otherwise make sense as +a class hierarchy; If minor modes FOO and BAR both define around methods for the +same method, but FOO's method must be called first, FOO can add a rule stating +that it must come before BAR in the mixin list. RULES must be a set of conses +which have the form (SYMBOL-DESIGNATOR . PACKAGE-DESIGNATOR). SYMBOL-DESIGNATOR +must be a valid argument to #'STRING, and PACKAGE-DESIGNATOR must be a valid +argument to #'FIND-PACKAGE. Together these shall form a single symbol which +should be the class name of the minor mode being referred to by the rule. + +@item +(:MIX-AFTER &REST RULES)@* +The :MIX-AFTER option is similar to the :MIX-BEFORE option, except it specifies +classes that this minor mode should occur after in the mixin list. @end itemize Example: @@ -1043,7 +1063,7 @@ Example: (destructuring-bind (&key top-map root-map (expose-keymaps t) rebind lighter lighter-make-clickable lighter-on-click (scope :unscoped) interactive global - (enable-when nil ewpp) + (enable-when nil ewpp) mix-before mix-after (make-hooks t) (define-command-definer t) default-initargs) mm-opts @@ -1087,6 +1107,18 @@ Example: ,@slots) (:default-initargs ,@default-initargs) ,@other-opts) + + ,@(when (or mix-after mix-before) + (flet ((mkc (s) + (list 'cons (car s) (cdr s)))) + (let ((mix-a (mapcar #'mkc mix-after)) + (mix-b (mapcar #'mkc mix-before))) + ;; Convert to explicit #'CONS calls to allow destructive + ;; modification of data at runtime. + `((dynamic-mixins-swm::set-rule ',mode + (list ,@mix-b) + (list ,@mix-a)))))) + ,(if global `(defmethod minor-mode-global-p ((mode (eql ',mode))) t) `(let ((method (ignore-errors