Fancy derive types for clojure

demo.clj

(ns demo
  (:require [fancyclass :as fancy :refer [derives?]]))

(defprotocol SomeParentType)
(fancy/derived-type CustomMap [SomeParentType :base/map :arbitrary/tag])

;; demo> (def m (->CustomMap :name "Bilbo" :occupation "Burglar"))
;; #'demo/m
;; demo> m
;; {:occupation "Burglar", :name "Bilbo"}
;; demo> (derives? m :base/map)
;; true
;; demo> (derives? m :arbitrary/tag)
;; true
;; demo> (derives? m SomeParentType)
;; true

fancyclass.clj

(ns fancyclass
  (:refer-clojure :exclude [isa? derive]))

;;the problem with clojure.core/derive is that it
;;does not allow classes to be parents.
;;They can be child tags, but only qualified
;;symbols/keys can be parents in the hierarchy.
;;To sidestep that, we will define our own entrypoint
;;and protocols for handling tags, and project
;;classes onto a keyword that is compatible with derive.
;;We have a lifted variant of derive and isa? .

(defn class-name [c]
  (->> (clojure.string/split (str c) #" ")
       second))

(defprotocol ITag
  (as-tag [this]))

;;let's bypass clojure for now, was getting weird errors
;;with extend-type.
(defn extends-via-meta? [obj]
  (some-> obj meta (get 'fancyclass/as-tag)))

(extend-type java.lang.Class
  ITag
  (as-tag [this] (keyword "class" (class-name this))))

(extend-type clojure.lang.IPersistentMap
  ITag
  (as-tag [this]
    (if-let [f (extends-via-meta? this)]
      (f this)
      (some-> this :on-interface as-tag))))

(extend-type clojure.lang.Keyword
  ITag
  (as-tag [this]
    (if (namespace this)
      this
      (throw (ex-info "keywords must be qualified" {:in this})))))

(extend-type clojure.lang.Symbol
  ITag
  (as-tag [this]
    (if (namespace this)
      this
      (throw (ex-info "symbols must be qualified" {:in this})))))

;;alias, maybe use this as primary...
(defn  derives?  [this parent]
  (clojure.core/isa? (as-tag this) (as-tag parent)))

;;like clojure.core/derive, except we allow classes as parents,
;;and project them into a ns qualified keyword :class/classname
;;for taggging purposes.
(defn derive [child parent]
  (let [parent (if (class? parent)
                 (as-tag parent)
                 parent)]
    (clojure.core/derive child parent)))

;;This is not possible with existing semantics, but we can do it!
(comment
  (derive :custom/object java.lang.String)
  (isa? :custom/object java.lang.String)) ;;true

(defn ensure-tag [x]
  (or (class? x)
      (cond (or (symbol? x) (keyword? x))
              (or (namespace x)
                  (throw (ex-info "symbol and keyword tags must be fully qualified" {:in x})))
            (map? x) (or (as-tag x)
                         (throw (ex-info "plain map cannot be a derive tag, try a protocol var"
                                         {:in x})))
            :else (throw (ex-info "tags must be qualified symbols/keywords, classes, or protocol maps" {:in x})))))

(def constructors
  {:base/vector clojure.core/vector
   :base/map    clojure.core/hash-map
   :base/set    clojure.core/hash-set
   :base/sorted-set clojure.core/sorted-set
   :base/sorted-map  clojure.core/sorted-map})

(defn find-ctor [xs]
  (let [base (->> xs
                  (map (fn [x]
                         (if-let [res (constructors x)]
                           res
                           (let [fs (->> (ancestors x)
                                         (filter constructors)
                                         set)]
                             (when (seq fs)
                               (if (= (count fs) 1) (first fs)
                                   (throw (ex-info (str "ambiguous base detected " [x :-> fs]) {:in x :bases fs}))))))))
                  (filter identity)
                  set)]
    (cond (= (count base) 1) (first base)
          (> (count base) 1) (throw (ex-info (str "ambiguous base detected " [xs :-> base]) {:in xs :bases base}))
          :else (throw (ex-info "no constructors derived!" {:in xs})))))

(defmacro derived-type
  "Define a macro that allows us to create pseudo types.
   These are based one meta data and tag hierarchies.
   They allow us to extend existing clojure collections and
   have them participate in a hierarchy where they inherit
   from other marker protocols or tags."
  ([id ancestors]
   (let [ctor (symbol (str "->" (name id)))]
     `(let [qual# (symbol (str (ns-name ~'*ns*)) ~(name id))
            ancestors# ~ancestors
            tags# (mapv fancyclass/as-tag ancestors#)
            ctor# (find-ctor tags#)]
        (assert (every? ensure-tag tags#) "detected invalid derive tags!")
        (doseq [tag# tags#]
          (fancyclass/derive qual# tag#))
        (defn ~ctor [~'& ~'keyvals]
          (with-meta (apply ctor# ~'keyvals) {~''fancyclass/as-tag (~'fn [obj#] qual#)})))))
  ([id] `(derived-type ~id nil)))