ADTs with compile-time arity / type checking in Clojure --wip!

adts.clj

(ns adts
  (:require [clojure.string :as str]))
 
(defn type->kw [ty]
  (keyword (str *ns* "/" ty)))
 
(defn capitalized? [s]
  (= (str s) (str/capitalize s)))
 
(defn adt? [s]
  (:adt (meta s)))
 
(defn is-a? [ty obj]
  (isa? (:hierarchy ty)
        (:constructor obj)
        (:id ty)))
 
(defn validate [validators values]
  (let [errors (->> values
                    (map-indexed (fn [n e]
                                   (let [spec (nth validators n)]
                                     (println spec)
                                     (cond
                                       (= ::dynamic e)
                                       nil
 
                                       (and
                                        (capitalized? spec)
                                        (class? (eval spec)))
                                       (when-not (instance? (eval spec) e)
                                         (str e " is not a " spec))
 
                                       (and (capitalized? spec)
                                            (adt? (eval spec)))
                                       (when-not (is-a? (eval spec) e)
                                         (str e " is not a " spec))
 
                                       :else
                                       nil
                                       ))))
                    (remove nil?))]
    (when (seq errors)
      errors)))
 
(defn validate! [validators values]
  (let [errors (validate validators values)]
    (assert (nil? errors)
            (apply str (interpose ", " errors)))))
 
(defmacro defadt [name & definitions]
  (let [ty (type->kw name)
        hierarchy-atom (atom (make-hierarchy))
        cts (map (fn [[ct & args]]
                   (let [ch-ty (type->kw ct)]
                     {:id ch-ty
                      :type ty
                      :constructor ct
                      :args args}))
                 definitions)
        macros (doall (map
                       (fn [{:keys [id constructor args]}]
                         (swap! hierarchy-atom #(derive % id ty))
                         (let [arguments (mapv
                                          (fn [a]
                                            (cond
                                              (capitalized? a)
                                              (symbol (gensym (str a)))
                                              :else a))
                                          args)
                               vargs (mapv identity args)
                               validate-fn-name (symbol (str "validate-" constructor))
                               ]
                           `(do
                              (defn ~validate-fn-name [& args#]
                                (validate '~vargs args#))
                              (defmacro ~constructor ~arguments
                                (validate! '~vargs (map
                                                    (fn [a#]
                                                      (try (eval a#)
                                                           (catch Throwable e#
                                                             ::dynamic)))
                                                    ~arguments))
                                {:constructor ~id
                                 :type ~ty
                                 :args ~arguments}))))
                       cts))
        metainf (mapv
                 (fn [{:keys [id type]}]
                   {:id id
                    :type type})
                 cts)]
    `(do
       (def ~name ^:adt {:id ~ty
                         :hierarchy ~(deref hierarchy-atom)
                         :constructors ~metainf})
       ~@macros)))
 
(deftype Width [x])
 
(defadt Shape
  (Square x)
  (Rectangle x y))
 
(defadt Shape
  (Square x)
  (Rectangle Width Width))
 
(defadt Bag
  (BShape Shape))