Introduce custom FnWithMeta to attach metadata to functions

camsaul · Aug 2, 2024 · 4093795 · 4093795
1 parent 5888005
commit 4093795
Show file tree

Hide file tree

Showing 15 changed files with 83 additions and 50 deletions.
diff --git a/build.clj b/build.clj
@@ -62,9 +62,18 @@
 (pprint/pprint (dissoc default-options :basis))
 (println)
 
+(defn javac [opts]
+  (let [opts (merge default-options opts)]
+    (b/delete {:path target})
+    (printf "\nCompiling Java classes...")
+    (b/javac (assoc opts
+                    :src-dirs ["src"]
+                    :javac-opts ["-source" "8" "-target" "8"]))))
+
 (defn build [opts]
   (let [opts (merge default-options opts)]
     (b/delete {:path target})
+    (javac opts)
     (println "\nWriting pom.xml...")
     (b/write-pom opts)
     (println "\nCopying source...")

diff --git a/deps.edn b/deps.edn
@@ -1,5 +1,5 @@
 {:paths
- ["src" "resources"]
+ ["src" "resources" "target/classes"]
 
  :deps
  {mvxcvi/puget      {:mvn/version "1.3.2"}

diff --git a/src/methodical/impl/combo/common.clj b/src/methodical/impl/combo/common.clj
@@ -1,5 +1,6 @@
 (ns methodical.impl.combo.common
-  "Utility functions for implementing method combinations.")
+  "Utility functions for implementing method combinations."
+  (:require [methodical.util :as u]))
 
 (defn combine-primary-methods
   "Combine all `primary-methods` into a single combined method. Each method is partially bound with a `next-method`
@@ -8,7 +9,7 @@
   (when (seq primary-methods)
     (reduce
      (fn [next-method primary-method]
-       (with-meta (partial primary-method next-method) (meta primary-method)))
+       (u/fn-with-meta (partial primary-method next-method) (meta primary-method)))
      nil
      (reverse primary-methods))))
 
@@ -19,7 +20,7 @@
   [combined-method around-methods]
   (reduce
    (fn [combined-method around-method]
-     (with-meta (partial around-method combined-method) (meta around-method)))
+     (u/fn-with-meta (partial around-method combined-method) (meta around-method)))
    combined-method
    around-methods))
 

diff --git a/src/methodical/impl/combo/threaded.clj b/src/methodical/impl/combo/threaded.clj
@@ -4,6 +4,7 @@
    [clojure.core.protocols :as clojure.protocols]
    [methodical.impl.combo.common :as combo.common]
    [methodical.interface]
+   [methodical.util :as u]
    [methodical.util.describe :as describe]
    [pretty.core :as pretty])
   (:import
@@ -44,7 +45,7 @@
               ([a b c]          (threaded-fn a b c))
               ([a b c d]        (threaded-fn a b c d))
               ([a b c d & more] (apply threaded-fn a b c d more)))
-            (vary-meta assoc :methodical/combined-method? true))
+            (u/fn-vary-meta assoc :methodical/combined-method? true))
         around)))))
 
 (defmulti threading-invoker

diff --git a/src/methodical/impl/dispatcher/everything.clj b/src/methodical/impl/dispatcher/everything.clj
@@ -4,6 +4,7 @@
    [clojure.core.protocols :as clojure.protocols]
    [methodical.impl.dispatcher.common :as dispatcher.common]
    [methodical.interface :as i]
+   [methodical.util :as u]
    [methodical.util.describe :as describe]
    [pretty.core :as pretty])
   (:import
@@ -43,15 +44,15 @@
     (let [primary-methods (i/primary-methods method-table)
           comparatorr     (dispatcher.common/domination-comparator (deref hierarchy-var) prefs)]
       (for [[dispatch-value method] (sort-by first comparatorr primary-methods)]
-        (vary-meta method assoc :dispatch-value dispatch-value))))
+        (u/fn-vary-meta method assoc :dispatch-value dispatch-value))))
 
   (matching-aux-methods [_ method-table _]
     (let [aux-methods (i/aux-methods method-table)
           comparatorr (dispatcher.common/domination-comparator (deref hierarchy-var) prefs)]
       (into {} (for [[qualifier dispatch-value->methods] aux-methods]
                  [qualifier (for [[dispatch-value methods] (sort-by first comparatorr dispatch-value->methods)
                                   method                   methods]
-                              (vary-meta method assoc :dispatch-value dispatch-value))]))))
+                              (u/fn-vary-meta method assoc :dispatch-value dispatch-value))]))))
 
   (default-dispatch-value [_]
     nil)

diff --git a/src/methodical/impl/dispatcher/standard.clj b/src/methodical/impl/dispatcher/standard.clj
@@ -6,6 +6,7 @@
    [clojure.core.protocols :as clojure.protocols]
    [methodical.impl.dispatcher.common :as dispatcher.common]
    [methodical.interface :as i]
+   [methodical.util :as u]
    [methodical.util.describe :as describe]
    [pretty.core :as pretty])
   (:import
@@ -71,10 +72,10 @@
                          (get (i/primary-methods method-table) default-value))]
     (concat
      (for [[dispatch-value method] pairs]
-       (vary-meta method assoc :dispatch-value dispatch-value))
+       (u/fn-vary-meta method assoc :dispatch-value dispatch-value))
      (when (and default-method
                 (not (contains? (set (map first pairs)) default-value)))
-       [(vary-meta default-method assoc :dispatch-value default-value)]))))
+       [(u/fn-vary-meta default-method assoc :dispatch-value default-value)]))))
 
 (defn- matching-aux-pairs-excluding-default
   "Return pairs of `[dispatch-value method]` of applicable aux methods, *excluding* default aux methods. Pairs are
@@ -106,7 +107,7 @@
                  :let        [pairs (matching-aux-pairs qualifier opts)]
                  :when       (seq pairs)]
              [qualifier (for [[dispatch-value method] pairs]
-                          (vary-meta method assoc :dispatch-value dispatch-value))])))
+                          (u/fn-vary-meta method assoc :dispatch-value dispatch-value))])))
 
 (deftype StandardDispatcher [dispatch-fn hierarchy-var default-value prefs]
   pretty/PrettyPrintable

diff --git a/src/methodical/impl/method_table/standard.clj b/src/methodical/impl/method_table/standard.clj
@@ -3,9 +3,11 @@
    [clojure.core.protocols :as clojure.protocols]
    [methodical.impl.method-table.common :as method-table.common]
    [methodical.interface]
+   [methodical.util :as u]
    [methodical.util.describe :as describe]
    [pretty.core :as pretty])
   (:import
+   (methodical FnWithMeta)
    (methodical.interface MethodTable)))
 
 (set! *warn-on-reflection* true)
@@ -49,7 +51,7 @@
     aux)
 
   (add-primary-method [this dispatch-val method]
-    (let [new-primary (assoc primary dispatch-val (vary-meta method assoc :dispatch-value dispatch-val))]
+    (let [new-primary (assoc primary dispatch-val (u/fn-vary-meta method assoc :dispatch-value dispatch-val))]
       (if (= primary new-primary)
         this
         (StandardMethodTable. new-primary aux))))
@@ -67,15 +69,18 @@
                                (if (contains? (set existing-methods) method)
                                  existing-methods
                                  (conj (vec existing-methods)
-                                       (vary-meta method assoc :dispatch-value dispatch-value)))))]
+                                       (u/fn-vary-meta method assoc :dispatch-value dispatch-value)))))]
       (if (= aux new-aux)
         this
         (StandardMethodTable. primary new-aux))))
 
   (remove-aux-method [this qualifier dispatch-value method]
     (let [xforms  [(fn [aux]
                      (update-in aux [qualifier dispatch-value] (fn [defined-methods]
-                                                                 (remove #(= % method) defined-methods))))
+                                                                 (remove #(if (instance? FnWithMeta method)
+                                                                            (= % method)
+                                                                            (= (.fn ^FnWithMeta %) method))
+                                                                         defined-methods))))
                    (fn [aux]
                      (cond-> aux
                        (empty? (get-in aux [qualifier dispatch-value]))

diff --git a/src/methodical/impl/multifn/standard.clj b/src/methodical/impl/multifn/standard.clj
@@ -5,6 +5,7 @@
    [clojure.datafy :as datafy]
    [methodical.impl.dispatcher.common :as dispatcher.common]
    [methodical.interface :as i]
+   [methodical.util :as u]
    [methodical.util.describe :as describe]
    [pretty.core :as pretty])
   (:import
@@ -102,7 +103,7 @@
   (let [primary-methods (i/matching-primary-methods dispatcher method-table dispatch-value)
         aux-methods     (i/matching-aux-methods dispatcher method-table dispatch-value)]
     (some-> (i/combine-methods method-combination primary-methods aux-methods)
-            (with-meta {:dispatch-value (effective-dispatch-value dispatcher dispatch-value primary-methods aux-methods)}))))
+            (u/fn-with-meta {:dispatch-value (effective-dispatch-value dispatcher dispatch-value primary-methods aux-methods)}))))
 
 (deftype StandardMultiFnImpl [^MethodCombination combo
                               ^Dispatcher dispatcher

diff --git a/src/methodical/macros.clj b/src/methodical/macros.clj
@@ -322,7 +322,7 @@
          ~@(when docstring
              [docstring])
          ~@(i/transform-fn-tail multifn nil fn-tail))
-       (u/add-primary-method! (var ~multifn-symb) ~dispatch-value (vary-meta ~fn-symb merge (meta (var ~fn-symb)))))))
+       (u/add-primary-method! (var ~multifn-symb) ~dispatch-value (u/fn-vary-meta ~fn-symb merge (meta (var ~fn-symb)))))))
 
 (defn- emit-aux-method
   "Impl for [[defmethod]] for aux methods."
@@ -337,7 +337,7 @@
        (u/add-aux-method-with-unique-key! (var ~multifn-symb)
                                           ~qualifier
                                           ~dispatch-value
-                                          (vary-meta ~fn-symb merge (meta (var ~fn-symb)))
+                                          (u/fn-vary-meta ~fn-symb merge (meta (var ~fn-symb)))
                                           ~unique-key))))
 
 (defn- defmethod-args-spec [multifn]

diff --git a/src/methodical/util.clj b/src/methodical/util.clj
@@ -5,7 +5,8 @@
   (:require
    [methodical.impl.standard :as impl.standard]
    [methodical.interface :as i]
-   [methodical.util.describe :as describe]))
+   [methodical.util.describe :as describe])
+  (:import methodical.FnWithMeta))
 
 (set! *warn-on-reflection* true)
 
@@ -14,6 +15,15 @@
   [x]
   (impl.standard/multifn? x))
 
+(defn fn-with-meta [fn meta]
+  (FnWithMeta. (if (instance? FnWithMeta fn)
+                 (.fn ^FnWithMeta fn)
+                 fn)
+               meta))
+
+(defn fn-vary-meta [fn f & args]
+  (fn-with-meta fn (apply f (meta fn) args)))
+
 (defn primary-method
   "Get the primary method *explicitly specified* for `dispatch-value`. This function does not return methods that would
   otherwise still be applicable (e.g., methods for ancestor dispatch values) -- just the methods explicitly defined
@@ -51,7 +61,7 @@
   [multifn dispatch-val]
   (let [[most-specific-primary-method :as primary-methods] (matching-primary-methods multifn dispatch-val)]
     (some-> (i/combine-methods multifn primary-methods nil)
-            (with-meta (meta most-specific-primary-method)))))
+            (fn-with-meta (meta most-specific-primary-method)))))
 
 (defn aux-methods
   "Get all auxiliary methods *explicitly specified* for `dispatch-value`. This function does not include methods that

diff --git a/src/methodical/util/trace.clj b/src/methodical/util/trace.clj
@@ -92,19 +92,19 @@
 
 (defn- trace-primary-method [primary-method]
   (-> (trace-method primary-method)
-      (with-meta (meta primary-method))))
+      (u/fn-with-meta (meta primary-method))))
 
 (defn- trace-primary-methods [primary-methods]
   (map trace-primary-method primary-methods))
 
 (defn- trace-aux-method [aux-method]
   (-> (trace-method aux-method)
-      (with-meta (meta aux-method))))
+      (u/fn-with-meta (meta aux-method))))
 
 (defn- trace-aux-methods [qualifier->ms]
   (into {} (for [[qualifier aux-methods] qualifier->ms]
              [qualifier (for [aux-method aux-methods]
-                          (trace-aux-method (vary-meta aux-method assoc :qualifier qualifier)))])))
+                          (trace-aux-method (u/fn-vary-meta aux-method assoc :qualifier qualifier)))])))
 
 (defn trace*
   "Function version of [[trace]] macro. The only difference is this doesn't capture the form of `multifn` passed to
@@ -114,7 +114,7 @@
         primary-methods (trace-primary-methods (u/matching-primary-methods multifn dispatch-value))
         aux-methods     (trace-aux-methods (u/matching-aux-methods multifn dispatch-value))
         combined        (-> (i/combine-methods multifn primary-methods aux-methods)
-                            (with-meta (meta multifn))
+                            (u/fn-with-meta (meta multifn))
                             trace-method)]
     (apply combined args)))
 

diff --git a/test/methodical/impl/dispatcher/standard_test.clj b/test/methodical/impl/dispatcher/standard_test.clj
@@ -3,7 +3,8 @@
    [clojure.test :as t]
    [methodical.core :as m]
    [methodical.impl :as impl]
-   [methodical.interface :as i])
+   [methodical.interface :as i]
+   [methodical.test-utils :refer :all])
   (:import
    (methodical.interface MethodTable)))
 
@@ -32,10 +33,10 @@
     (t/testing "matching-primary-methods should return all matches in order of specificity."
       (let [method-table (method-table {:child 'child, :parent 'parent, :grandparent 'grandparent} nil)]
         (t/is (= '[child parent grandparent]
-                 (i/matching-primary-methods dispatcher method-table :child)))
+                 (unwrap-fn-with-metas (i/matching-primary-methods dispatcher method-table :child))))
 
         (t/is (= '[parent grandparent]
-                 (i/matching-primary-methods dispatcher method-table :parent)))))
+                 (unwrap-fn-with-metas (i/matching-primary-methods dispatcher method-table :parent))))))
 
     (t/testing "default primary methods"
       (let [method-table (method-table {:child       'child
@@ -44,14 +45,14 @@
                                         :default     'default} nil)]
         (t/testing "default methods should be included if they exist"
           (t/is (= '[parent grandparent default]
-                   (i/matching-primary-methods dispatcher method-table :parent)))
+                   (unwrap-fn-with-metas (i/matching-primary-methods dispatcher method-table :parent))))
           (t/testing "should return ^:dispatch-value metadata"
             (t/is (= [{:dispatch-value :parent} {:dispatch-value :grandparent} {:dispatch-value :default}]
                      (map meta (i/matching-primary-methods dispatcher method-table :parent))))))
 
         (t/testing "If there are otherwise no matches, default should be returned (but nothing else)"
           (t/is (= '[default]
-                   (i/matching-primary-methods dispatcher method-table :cousin)))
+                   (unwrap-fn-with-metas (i/matching-primary-methods dispatcher method-table :cousin))))
           (t/testing "should return ^:dispatch-value metadata"
             (t/is (= [{:dispatch-value :default}]
                      (map meta (i/matching-primary-methods dispatcher method-table :cousin))))))
@@ -61,7 +62,7 @@
                                                  :hierarchy #'basic-hierarchy
                                                  :default-value :grandparent)]
             (t/is (= '[parent grandparent]
-                     (i/matching-primary-methods dispatcher-with-custom-default method-table :parent)))
+                     (unwrap-fn-with-metas (i/matching-primary-methods dispatcher-with-custom-default method-table :parent))))
             (t/testing "should return ^:dispatch-value metadata"
               (t/is (= [{:dispatch-value :parent} {:dispatch-value :grandparent}]
                        (map meta (i/matching-primary-methods
@@ -82,7 +83,7 @@
         (let [dispatcher (impl/standard-dispatcher keyword
                                                    :hierarchy #'basic-hierarchy)]
           (t/is (= {:before '[default]}
-                   (i/matching-aux-methods dispatcher method-table :cousin)))
+                   (unwrap-fn-with-metas (i/matching-aux-methods dispatcher method-table :cousin))))
           (t/testing "should return ^:dispatch-value metadata"
             (t/is (= {:before [{:dispatch-value :default}]}
                      (aux-methods-metadata (i/matching-aux-methods dispatcher method-table :cousin)))))))
@@ -92,7 +93,7 @@
                                                    :hierarchy #'basic-hierarchy
                                                    :default-value :grandparent)]
           (t/is (= {:before '[parent grandparent]}
-                   (i/matching-aux-methods dispatcher method-table :parent)))
+                   (unwrap-fn-with-metas (i/matching-aux-methods dispatcher method-table :parent))))
           (t/testing "should return ^:dispatch-value metadata"
             (t/is (= {:before [{:dispatch-value :parent} {:dispatch-value :grandparent}]}
                      (aux-methods-metadata (i/matching-aux-methods dispatcher method-table :parent))))))))))
@@ -130,10 +131,10 @@
         (catch Exception e
           (t/is (= {:method-1 {:ns             (the-ns 'methodical.impl.dispatcher.standard-test)
                                :file           "methodical/impl/dispatcher/standard_test.clj"
-                               :line           106
+                               :line           107
                                :dispatch-value ::parrot}
                     :method-2 {:ns             (the-ns 'methodical.impl.dispatcher.standard-test)
                                :file           "methodical/impl/dispatcher/standard_test.clj"
-                               :line           110
+                               :line           111
                                :dispatch-value ::friend}}
                    (ex-data e))))))))
diff --git a/test/methodical/impl/method_table/standard_test.clj b/test/methodical/impl/method_table/standard_test.clj
@@ -3,7 +3,8 @@
    [clojure.test :as t]
    [clojure.tools.reader.edn :as edn]
    [methodical.impl.method-table.standard :as method-table.standard]
-   [methodical.interface :as i]))
+   [methodical.interface :as i]
+   [methodical.test-utils :refer :all]))
 
 (t/deftest print-test
   (t/is (= "(standard-method-table)"
@@ -32,16 +33,16 @@
                     (i/add-aux-method :before :x 'f))]
       (t/testing "primary method"
         (t/is (= {[:x :y] 'f}
-                 (i/primary-methods table)))
-        (let [method (-> (i/primary-methods table) vals first)]
+                 (unwrap-fn-with-metas (i/primary-methods table))))
+        (let [method (-> (i/primary-methods table) vals first unwrap-fn-with-metas)]
           (t/is (= 'f
                    method))
           (t/is (= {:dispatch-value [:x :y]}
                    (meta method)))))
       (t/testing "aux method"
-        (let [method (-> (i/aux-methods table) :before vals ffirst)]
+        (let [method (-> (i/aux-methods table) :before vals ffirst unwrap-fn-with-metas)]
           (t/is (= {:before {:x ['f]}}
-                   (i/aux-methods table)))
+                   (unwrap-fn-with-metas (i/aux-methods table))))
           (t/is (= 'f
                    method))
           (t/is (= {:dispatch-value :x}