Malli open, lazy multi schema

malli_lazy.clj

(require '[malli.registry :as mr]
           '[malli.core])


(do
  (def cfn-registry*
    (atom {}))

  
  (def registry
    (malli.registry/composite-registry
     m/default-registry
     (mr/mutable-registry cfn-registry*)))

  
  (defn open-multi-schema []
    ^{:type ::into-schema}
    (reify malli.core/IntoSchema
      (-into-schema [_ properties children options]
        (let [{:keys [children entries forms]} (malli.core/-parse-entries children false options)
              validator-lookup (:children properties)
              form (malli.core/-create-form :multi properties forms)
              dispatch (malli.core/eval (:dispatch properties))

              ;; TODO get rid of dispatch-map, needed for transformers
              dispatch-map (->> (for [[k s] entries] [k s]) (into {}))]
          (when-not dispatch
            (malli.core/-fail! ::missing-property {:key :dispatch}))
          ^{:type ::schema}
          (reify
            malli.core/Schema
            (-type [_] :multi)
            (-validator [_]
              (fn [x]
                (if-let [validator (validator-lookup (dispatch x))]
                  (validator x)
                  false)))
            (-explainer [this path]
              (let [explainers (reduce
                                (fn [acc [key schema]]
                                  (let [explainer (malli.core/-explainer schema (conj path key))]
                                    (assoc acc key (fn [x in acc] (explainer x in acc)))))
                                {} entries)]
                (fn [x in acc]
                  (if-let [explainer (explainers (dispatch x))]
                    (explainer x in acc)
                    (conj acc (malli.core/-error path in this x ::invalid-dispatch-value))))))
            (-transformer [this transformer method options]
              (let [this-transformer (malli.core/-value-transformer transformer this method options)
                    child-transformers (reduce-kv
                                        (fn [acc k s] (assoc acc k (malli.core/-transformer s transformer method options)))
                                        {} dispatch-map)
                    build (fn [phase]
                            (let [->this (phase this-transformer)
                                  ->children (->> child-transformers
                                                  (keep (fn [[k v]] (if-let [t (phase v)] [k t])))
                                                  (into {}))
                                  ->child (if (seq ->children) (fn [x] (if-let [t (->children (dispatch x))] (t x) x)))]
                              (malli.core/-chain phase [->this ->child])))]
                {:enter (build :enter)
                 :leave (build :leave)}))
            (-walk [this walker path options]
              (if (malli.core/-accept walker this path options)
                (malli.core/-outer walker this path (malli.core/-inner-entries walker path entries options) options)))
            (-properties [_] properties)
            (-options [_] options)
            (-children [_] children)
            (-form [_] form)
            malli.core/MapSchema
            (-entries [_] entries)
            malli.core/LensSchema
            (-keep [_])
            (-get [this key default] (malli.core/-get-entries this key default))
            (-set [this key value] (malli.core/-set-entries this key value)))))))

  (swap! cfn-registry* assoc :open-multi (open-multi-schema))


  ;; -- Simple test
  (let [lookup-fn (fn [t]
                    ;; TODO add lookup logic here
                    (malli.core/validator [:map [:type [:= t]]]))]
    (m/validate [:open-multi
                 {:dispatch :type
                  :children (let [*cache (atom {})]
                              (fn [t]
                                (let [cache (swap! *cache update t (fnil identity (delay (lookup-fn t))))]
                                  (force (get cache t) ))))}
                 ]

                {:type :foo}

                {:registry registry}))

  )