Malli composite schema that reuses the values of the underlying values during data generation

kahn_sort.clj

;; Copy of https://gist.github.com/alandipert/1263783
;;
;; Copyright (c) Alan Dipert. All rights reserved.
;; The use and distribution terms for this software are covered by the
;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.

(ns alandipert.kahn
  (:require [clojure.set :refer [difference union intersection]]))

(defn without
  "Returns set s with x removed."
  [s x] (difference s #{x}))

(defn take-1
  "Returns the pair [element, s'] where s' is set s with element removed."
  [s] {:pre [(not (empty? s))]}
  (let [item (first s)]
    [item (without s item)]))

(defn no-incoming
  "Returns the set of nodes in graph g for which there are no incoming
  edges, where g is a map of nodes to sets of nodes."
  [g]
  (let [nodes (set (keys g))
        have-incoming (apply union (vals g))]
    (difference nodes have-incoming)))

(defn normalize
  "Returns g with empty outgoing edges added for nodes with incoming
  edges only.  Example: {:a #{:b}} => {:a #{:b}, :b #{}}"
  [g]
  (let [have-incoming (apply union (vals g))]
    (reduce #(if (get % %2) % (assoc % %2 #{})) g have-incoming)))

(defn kahn-sort
  "Proposes a topological sort for directed graph g using Kahn's
   algorithm, where g is a map of nodes to sets of nodes. If g is
   cyclic, returns nil."
  ([g]
     (kahn-sort (normalize g) [] (no-incoming g)))
  ([g l s]
     (if (empty? s)
       (when (every? empty? (vals g)) l)
       (let [[n s'] (take-1 s)
             m (g n)
             g' (reduce #(update-in % [n] without %2) g m)]
         (recur g' (conj l n) (union s' (intersection (no-incoming g') m)))))))

(comment
  (def acyclic-g
    {7 #{11 8}
     5 #{11}
     3 #{8 10}
     11 #{2 9}
     8 #{9}})

  (def cyclic-g
    {7 #{11 8}
     5 #{11}
     3 #{8 10}
     11 #{2 9}
     8 #{9}
     2 #{11}}) ;oops, a cycle!

  (kahn-sort acyclic-g) ;=> [3 5 7 8 10 11 2 9]
  (kahn-sort cyclic-g) ;=> nil

  )

malli_composite.clj

(ns malli.composite
  (:require
   [clojure.test.check.generators :as gen]
   [malli.core :as m]
   [malli.generator :as mg]
   [malli.util :as mu]
   [malli.registry :as mr]))


(def *registry
  (atom
   (merge
    (m/default-schemas)
    (mu/schemas))))


(def registry (mr/mutable-registry *registry))


(defn register! [type ?schema]
  (swap! *registry assoc type ?schema)
  :ok)


(defn generator [k]
  (mg/generator (m/schema k {:registry registry})))

(defn generate [k]
  (mg/generate (m/schema k {:registry registry})))


(defn k->props [k]
  (m/properties (m/deref (m/schema k {:registry registry}))))

;; Base types

(register! :composite
           (m/-simple-schema
            (fn [{:keys [schema fields compose]} _]
              (assert (and schema fields compose))
              {:type ::composite
               :pred (m/validator schema)
               ;; generator without context
               :type-properties {:fields fields
                                 :compose compose
                                 :gen/gen
                                 (gen/fmap (partial apply compose)
                                           (apply gen/tuple (map generator fields)))}})))


(defn composite-fields [k]
  (set (:fields (k->props k))))


(defn fields->tree [fields]
  (loop [tree {}
         visited #{}
         [field & left] fields]
    (if field
      (if (contains? visited field)
        (recur tree visited left)
        (let [deps (composite-fields field)]
          (recur (assoc tree field (set deps))
                 (conj visited field)
                 (concat left deps))))
      tree)))


(defn topo-sort [tree]
  (reverse (alandipert.kahn/kahn-sort tree)))


(defn ks->compose-fns [ks]
  (zipmap ks (map (comp :compose k->props) ks)))

(defn getx [m k]
  (let [v (get m k ::sentinel)]
    (if (= v ::sentinel)
      (throw (ex-info "Missing key" {:k k :ks (keys m)}))
      v)))

(defn entity-fields->generator [entity-fields]
  (let [tree (fields->tree entity-fields)
        order (topo-sort tree)
        no-deps (keys (filter (comp empty? val) tree))

        entity-gen (apply gen/hash-map (mapcat (fn [k] [k (generator k)]) no-deps))
        deps-order (remove (set no-deps) order)
        compose-fns (ks->compose-fns deps-order)

        entity-gen (reduce (fn [entity-gen field]
                             (gen/bind entity-gen
                                       (let [compose (get compose-fns field)]
                                         (fn [entity]
                                           (let [d (getx tree field)]
                                             (gen/return
                                              (assoc entity field
                                                    ; (pr-str d)
                                                     (apply compose (map (partial get entity) d)))))))))
                           entity-gen
                           deps-order)]
    (gen/fmap (fn [entity]
                (select-keys entity entity-fields))
              entity-gen)))


(defn register-entity! [type fields]
  (let [registry @*registry
        schema (into [:map {:gen/gen (entity-fields->generator fields)}]
                     fields)]
    (register! type schema)))


(comment
  (topo-sort (fields->tree [:user/name :email/address])))

malli_composite_test.clj

(require '[malli.composite :refer :all])

;; ## Data model

;; -- Basic types

(register! :user/first-name [:re {:min 5 :max 20} #"[a-z]+"])
(register! :user/last-name [:re {:min 5 :max 20} #"[a-z]+"])
(register! :user/webhost [:enum "gmail.com" "hotmail.com" "yahoo.com"])

;; -- Composite types

(register! :user/username
           [:composite {:schema string?
                        :compose (fn [first-name last-name]
                                   (str first-name "." last-name))
                        :fields [:user/first-name :user/last-name]}])


(register! :user/full-name
           [:composite {:schema string?
                        :compose (fn [first-name last-name]
                                   (str first-name " " last-name))
                        :fields [:user/first-name :user/last-name]}])

(register! :email/address
           [:composite {:schema string?
                        :compose (fn [name domain]
                                   (str name "@" domain)
                                   )
                        :fields [:user/username  :user/webhost]}])

(register-entity! ::user
                  [:user/first-name
                   :user/last-name
                   :user/full-name
                   :user/username
                   :email/address
                   :user/webhost
                   ])


(comment
  ;; All work individually:

  (generate :user/username)
  (generate :user/webhost)
  (generate :email/address)


  ;; All work together:

  (generate ::user)
  ;;=>
  {:user/first-name "azdfbprmxxpkwlqnusxjlajc",
   :user/last-name "kptobaobrexnjwarfafsoavey",
   :user/full-name "azdfbprmxxpkwlqnusxjlajc kptobaobrexnjwarfafsoavey",
   :user/username "azdfbprmxxpkwlqnusxjlajc.kptobaobrexnjwarfafsoavey",
   :email/address
   "azdfbprmxxpkwlqnusxjlajc.kptobaobrexnjwarfafsoavey@gmail.com",
   :user/webhost "gmail.com"})

Main idea is to easily create a data model through malli that will help you in generating consistent test and seed data.