Last active
January 20, 2022 18:16
-
-
Save jeroenvandijk/5e0785f25f7fdfeac7bc7a0be72cb62a to your computer and use it in GitHub Desktop.
Malli composite schema that reuses the values of the underlying values during data generation
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; 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 | |
) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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]))) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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"}) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Main idea is to easily create a data model through malli that will help you in generating consistent test and seed data.