mall_typeclass.clj

(ns src.dev.nocommit.malli-match
  (:require
   [malli.core :as mc]
   [clojure.set :as set]
   [clojure.string :as str]
   [clojure.walk :as walk]))

(defn underive-children [tag]
  "Remove all children of the given tag."
  (let [children (descendants tag)]
    (doseq [child children] (underive child tag))))

(defmacro defvariants
  "Define variants for a tag. Each variant is a keyword that maps to a schema.
   The schemas are used to validate the data passed to the `caze` macro."
  [tag & body]
  (when-not (even? (count body))
    (throw (ex-info "defvariants requires one schema per tag."
                    {:body body})))
  (let [kw+variants (partition 2 body)
        variants (mapv (fn [[kw schema]]
                         (let [full-kw (keyword (str *ns*) (name kw))]
                           `(derive ~full-kw ~tag)))
                       kw+variants)]
    `(do
       (underive-children ~tag)
       ~@(mapcat (fn [[kw schema]]
                   [`(derive ~kw ~tag)
                    `(def ~(symbol kw) ~schema)])
                 kw+variants))))

(comment

  (macroexpand-1
   '(defvariants ::Fish
      ::Starfish [:map
                  [:name :string]
                  [:favorite-color :string]]
      ::Jellyfish [:map
                   [:name :string]
                   [:jiggly :boolean]]))

  )

(def Starfish
  [:map
   [:name :string]
   [:favorite-color :string]])

(def Jellyfish
  [:map
   [:name :string]
   [:jiggly :boolean]])

(defn- resolve-var-from-kw
  [kw]
  (let [ns-name (namespace kw)
        var-name (name kw)]
    [kw @(requiring-resolve (symbol (str ns-name "/" var-name)))]))

(defn get-variants [tag]
  (->> tag
       descendants
       (map resolve-var-from-kw)
       (into {})))

(comment
  (get-variants ::Fish)
  ;; => {:src.dev.nocommit.malli-match/Jellyfish [:map [:name :string] [:jiggly :boolean]]
  ;;   , :src.dev.nocommit.malli-match/Starfish [:map [:name :string] [:favorite-color :string]]}
  )

(defmacro caze [tag & bindings+bodies]
  (let [variant->schemas  (get-variants tag)
        variants          (set (keys variant->schemas))
        bindings          (partition 2 bindings+bodies)
        covered-variants  (set (map ffirst bindings))
        missing           (vec (sort (remove covered-variants variants)))
        extra             (vec (sort (remove variants (set (map ffirst bindings)))))
        ;; TODO: is this a good design: has-fallthru? (some #(#{:_} (ffirst %)) bindings)
        ]

    (when-not (set/subset? variants covered-variants)
      ;; (not has-fallthru?)
      (let [missing (sort (remove covered-variants variants))]
        (throw (ex-info (str "Inexhaustive match! Missing: " (str/join ", " missing) ".")
                        {:missing missing}))))
    (when (seq extra)
      (throw (ex-info (str "Extra branches! " (str/join ", " extra) ".")
                      {:extra extra})))

    (let [vsdb (map (fn [[[variant-kw destructure] body]]
                      (let [schema (get variant->schemas variant-kw)]
                        [variant-kw schema destructure body]))
                    bindings)
          input (gensym "input")]
      `(fn [~input]
         (cond
           ~@(mapcat (fn [[variant schema destructure body]]
                       [`(mc/validate ~schema ~input)
                        `(let [~destructure ~input]
                           ~body)])
                     vsdb)
           :else
           (throw (ex-info "No matching variant found." {:input ~input
                                                         :tag ~tag
                                                         :variants ~variants})))))))

(defmacro defcaze
  "Define a function that expects a matching schema and matches against the variants.
   The body is a map of variant keywords to their schemas and bodies."
  [name tag & bindings+bodies]
  `(def ~name (caze ~tag ~@bindings+bodies)))


(defvariants ::Fish
  ::Starfish [:map
              [:name :string]
              [:favorite-color :string]]
  ::Jellyfish [:map
               [:name :string]
               [:jiggly :boolean]]
  ::Weirdfish [:cat :string [:alt :boolean :int]])

(defcaze
  fish-explainer
  ::Fish
  [::Starfish {:keys [name favorite-color]}] (str "Starfish: " name ", favorite color: " favorite-color)
  [::Jellyfish {:keys [name jiggly]}] (str "Jellyfish: " name ", jiggly: " jiggly)
  [::Weirdfish [name weirdness]] (str "Weird fish: " name ", it's a "
                                      (if (boolean? weirdness)
                                        (str "! boolean: " (not weirdness))
                                        (str "number + 1: " (inc weirdness)))))

(mapv fish-explainer [{:name "Nemo" :favorite-color "orange"}
                      {:name "Jelly" :jiggly true}
                      ["im weird" 42]
                      ["im weird" false]])
;; => ["Starfish: Nemo, favorite color: orange"
;;     "Jellyfish: Jelly, jiggly: true"
;;     "Weird fish: im weird, it's a number + 1: 43"
;;     "Weird fish: im weird, it's a ! boolean: true"]