├── dev └── .gitkeep ├── .gitignore ├── boot.properties ├── .travis.yml ├── src ├── speculate │ ├── render.clj │ ├── spec │ │ └── combine.clj │ ├── transform │ │ ├── state.clj │ │ ├── maybe.clj │ │ ├── extract.clj │ │ └── combine.clj │ ├── transform.clj │ ├── util.clj │ ├── swagger.clj │ ├── json_schema.clj │ ├── ast.clj │ └── spec.clj └── clojure │ └── spec │ └── override.clj ├── Makefile ├── test └── speculate │ ├── ensure_req_key_present_in_target_test.clj │ ├── spec │ ├── tariff.clj │ └── rate_card.clj │ └── rate_card_tariff_test.clj ├── test-resources └── rate-card.edn ├── README.md └── LICENSE /dev/.gitkeep: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .nrepl-history 2 | .nrepl-port 3 | target 4 | swagger.json 5 | dev/ 6 | -------------------------------------------------------------------------------- /boot.properties: -------------------------------------------------------------------------------- 1 | BOOT_CLOJURE_NAME=org.clojure/clojure 2 | BOOT_CLOJURE_VERSION=1.8.0 3 | BOOT_VERSION=2.7.1 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: java 2 | install: make deps 3 | script: make clean test 4 | deploy: 5 | provider: script 6 | on: 7 | branch: master 8 | script: make deploy 9 | jdk: 10 | - oraclejdk8 11 | -------------------------------------------------------------------------------- /src/speculate/render.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.render) 2 | 3 | (defmulti render (fn [renderer x] [renderer (:speculate.ast/type x)])) 4 | 5 | (defmethod render [::abbrev 'clojure.core/set?] 6 | [_ {:keys [form]}] 7 | (str (first form))) 8 | 9 | (defmethod render :default 10 | [renderer x] 11 | (cond (string? x) x 12 | :default x)) 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # .PHONY: deps build test clean 2 | 3 | SHELL := /usr/bin/env bash 4 | export PATH := bin:$(PATH) 5 | 6 | clean: 7 | (rm -Rfv bin) 8 | (rm -Rfv target) 9 | 10 | mkdirs: 11 | mkdir -p bin 12 | mkdir -p dev 13 | 14 | bin/boot: mkdirs 15 | curl -fsSLo bin/boot https://github.com/boot-clj/boot-bin/releases/download/latest/boot.sh 16 | chmod 755 bin/boot 17 | 18 | deps: bin/boot 19 | export BOOT_EMIT_TARGET=no && ./bin/boot -V 20 | 21 | build: bin/boot 22 | export BOOT_EMIT_TARGET=no && ./bin/boot build 23 | 24 | test: bin/boot 25 | ./bin/boot test 26 | 27 | deploy: bin/boot 28 | ./bin/boot deploy 29 | -------------------------------------------------------------------------------- /test/speculate/ensure_req_key_present_in_target_test.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.ensure-req-key-present-in-target-test 2 | (:require 3 | [clojure.edn :as edn] 4 | [clojure.spec.alpha :as s] 5 | [clojure.test :refer [deftest is]] 6 | [speculate.transform :as tx] 7 | [clojure.future :refer :all])) 8 | 9 | (s/def ::a (s/nilable int?)) 10 | (s/def ::b (s/nilable int?)) 11 | 12 | (s/def ::from (s/keys :opt-un [::a ::b])) 13 | (s/def ::to (s/keys :req-un [::a ::b])) 14 | 15 | (deftest make-sure-req-key-present-in-target-when-missing-in-source 16 | (let [from {:a nil}] 17 | (is (s/valid? ::from from)) 18 | (is (= {:a nil :b nil} 19 | (tx/transform ::from ::to from)))) 20 | 21 | (let [from {:a 2}] 22 | (is (s/valid? ::from from)) 23 | (is (= {:a 2 :b nil} 24 | (tx/transform ::from ::to from)))) 25 | 26 | (let [from {}] 27 | (is (s/valid? ::from from)) 28 | (is (= {:a nil :b nil} 29 | (tx/transform ::from ::to from))))) 30 | 31 | (comment 32 | (make-sure-req-key-present-in-target-when-missing-in-source)) 33 | -------------------------------------------------------------------------------- /src/speculate/spec/combine.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.spec.combine 2 | (:require 3 | [clojure.spec.alpha :as s] 4 | [clojure.future :refer :all])) 5 | 6 | (s/def ::label keyword?) 7 | (s/def ::value any?) 8 | (s/def ::category (s/nilable (s/map-of keyword? (s/nilable any?)))) 9 | (s/def ::categorize (s/nilable (s/map-of keyword? (s/nilable set?)))) 10 | (s/def ::coll-indexes (s/nilable (s/map-of keyword? nat-int?))) 11 | (s/def ::index-value 12 | (s/keys :req-un [::label ::value] 13 | :opt-un [::categorize ::coll-indexes])) 14 | (s/def ::value-index (s/coll-of ::index-value)) 15 | 16 | (s/def ::categorized ::categorize) 17 | (s/def ::pathset-union set?) 18 | (s/def ::from-nodeset set?) 19 | (s/def ::index-meta 20 | (s/keys :req-un [::categorized ::pathset-union ::from-nodeset])) 21 | 22 | (s/fdef combine 23 | :args (s/cat :value-index ::value-index :index-meta any? :ast any?) 24 | :ret any?) 25 | 26 | (s/fdef coll-combine 27 | :args (s/cat :value-index ::value-index :index-meta any? :ast any?) 28 | :ret any?) 29 | 30 | (s/fdef expand-value-index 31 | :args (s/cat :categorized ::categorized) 32 | :ret (s/coll-of ::category)) 33 | -------------------------------------------------------------------------------- /src/speculate/transform/state.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.transform.state 2 | (:refer-clojure :exclude [concat map map-indexed merge]) 3 | (:require [speculate.util :as util])) 4 | 5 | (alias 'c 'clojure.core) 6 | 7 | (defn update-value [value f & args] 8 | (apply update value 0 f args)) 9 | 10 | (defn update-state [value f & args] 11 | (apply update value 1 f args)) 12 | 13 | (defn reset [value state & ks] 14 | (update value 1 c/merge (zipmap ks (c/map state ks)))) 15 | 16 | (defn merge [& state-maps] 17 | (reduce (fn [[a sa] [b sb]] 18 | [(c/merge a b) (util/deep-merge sa sb)]) 19 | state-maps)) 20 | 21 | (defn concat [& state-colls] 22 | (reduce (fn [[a sa] [b sb]] 23 | [(c/concat a b) (util/deep-merge sa sb)]) 24 | state-colls)) 25 | 26 | (defn map [state f & colls] 27 | (let [heads (c/map first colls)] 28 | (if (every? some? heads) 29 | (let [[value state'] (apply f state heads)] 30 | (let [[values state''] (apply map state' f (c/map rest colls))] 31 | (if values 32 | [(c/concat value values) state''] 33 | [value state']))) 34 | [nil state]))) 35 | 36 | (defn map-indexed [state f & colls] 37 | (apply map state f (range) colls)) 38 | -------------------------------------------------------------------------------- /src/speculate/transform/maybe.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.transform.maybe 2 | (:refer-clojure :exclude [keep or seq some some->>])) 3 | 4 | (alias 'c 'clojure.core) 5 | 6 | (def Nothing (reify Object (toString [_] "Nothing"))) 7 | 8 | (defn seq [x] 9 | (if (coll? x) 10 | (if (empty? x) Nothing x) 11 | x)) 12 | 13 | (defn nothing? [x] 14 | (= Nothing x)) 15 | 16 | (defmacro some->> 17 | "When expr is not Nothing, threads it into the first form (via ->>), 18 | and when that result is not Nothing, through the next etc" 19 | [expr & forms] 20 | (let [g (gensym) 21 | steps (map (fn [step] `(if (nothing? ~g) Nothing (->> ~g ~step))) 22 | forms)] 23 | `(let [~g ~expr 24 | ~@(interleave (repeat g) (butlast steps))] 25 | ~(if (empty? steps) 26 | g 27 | (last steps))))) 28 | 29 | (defn keep 30 | "Like keep, but removes Nothing rather than nil." 31 | [f coll] 32 | (lazy-seq 33 | (when-let [s (c/seq coll)] 34 | (if (chunked-seq? s) 35 | (let [c (chunk-first s) 36 | size (count c) 37 | b (chunk-buffer size)] 38 | (dotimes [i size] 39 | (let [x (f (.nth c i))] 40 | (when-not (nothing? x) 41 | (chunk-append b x)))) 42 | (chunk-cons (chunk b) (keep f (chunk-rest s)))) 43 | (let [x (f (first s))] 44 | (if (nothing? x) 45 | (keep f (rest s)) 46 | (cons x (keep f (rest s))))))))) 47 | 48 | (defn some 49 | "Like some, but ignores Nothing rather than nil. Returns Nothing if none" 50 | [pred coll] 51 | (if (c/seq coll) 52 | (let [x (pred (first coll))] 53 | (if (nothing? x) 54 | (recur pred (next coll)) 55 | x)) 56 | Nothing)) 57 | 58 | (defmacro or 59 | ([] nil) 60 | ([x] x) 61 | ([x & next] 62 | `(let [or# ~x] 63 | (if (nothing? or#) (or ~@next) or#)))) 64 | 65 | -------------------------------------------------------------------------------- /test/speculate/spec/tariff.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.spec.tariff 2 | (:require 3 | [clojure.spec.alpha :as s] 4 | [speculate.spec :as u] 5 | [speculate.util :as util] 6 | [speculate.spec.rate-card :as rate-card])) 7 | 8 | (s/def ::fuel-type ::rate-card/fuel) 9 | 10 | (s/def :tariff.rate/type 11 | (u/spec 12 | :spec #{"unit-rate" "night-rate" "tiered-rate"} 13 | :alias {::rate-card/rate #(cond (:night-rate %) "night-rate" 14 | (:threshold %) "tiered-rate" 15 | :default "unit-rate")})) 16 | 17 | (s/def ::rate 18 | (s/keys :req-un [:tariff.rate/type 19 | ::rate-card/price 20 | ::rate-card/threshold])) 21 | 22 | (s/def ::rates 23 | (s/coll-of ::rate)) 24 | 25 | (s/def ::standing-charge ::rate-card/annual-standing-charge) 26 | 27 | (s/def ::fuel 28 | (s/keys :req-un [::fuel-type ::rate-card/variant ::standing-charge ::rates])) 29 | 30 | (s/def ::electricity 31 | (u/spec 32 | :spec ::fuel 33 | :select {:meter #{["Electricity" "Standard"] ["Electricity" "Economy 7"]} 34 | :fuel #{"electricity"} 35 | ::rate-card/available-for #{"dual-fuel" "electricity"}})) 36 | 37 | (s/def ::gas 38 | (u/spec 39 | :spec ::fuel 40 | :select {:meter #{["Gas" "Standard"]} 41 | :fuel #{"gas"} 42 | ::rate-card/available-for #{"dual-fuel" "gas"}})) 43 | 44 | (s/def ::period ::rate-card/duration) 45 | 46 | (s/def ::date ::rate-card/end-date) 47 | 48 | (s/def :tariff-ends/type 49 | (u/spec 50 | :spec #{"period" "date"} 51 | :alias {::rate-card/duration #(if % "period" "date")})) 52 | 53 | (s/def ::tariff-ends 54 | (s/keys :req-un [:tariff-ends/type] :opt-un [::period ::date])) 55 | 56 | (s/def ::price-guarantee 57 | (s/keys :req-un [:tariff-ends/type] :opt-un [::period ::date])) 58 | 59 | (s/def ::tariff-id ::rate-card/uuid) 60 | 61 | (s/def ::tariff-type 62 | (u/spec 63 | :spec #{"fixed" "variable"} 64 | :alias {::rate-card/fixed #(if % "fixed" "variable")})) 65 | 66 | (s/def ::id ::rate-card/supplier-name-key) 67 | (s/def ::name ::rate-card/supplier-name) 68 | (s/def ::supplier 69 | (s/keys :req-un [::id ::name])) 70 | 71 | (s/def ::variant 72 | (u/spec 73 | :spec ::rate-card/variant 74 | :select {:fuel #{"electricity"}})) 75 | 76 | (defn restrict-availability 77 | [{categorize :categorize}] 78 | (let [{:keys [::rate-card/available-for ::rate-card/fuel]} categorize] 79 | (or (= available-for "dual-fuel") 80 | (= available-for fuel) 81 | (= available-for (:fuel categorize))))) 82 | 83 | (s/def ::tariff 84 | (u/spec 85 | :spec (s/keys :req-un [::tariff-id 86 | ::rate-card/name 87 | ::rate-card/payment-method 88 | ::tariff-type 89 | ::rate-card/supplier-name-key 90 | ::supplier 91 | ::rate-card/region 92 | ::variant 93 | ::rate-card/available-for] 94 | :opt-un [::electricity 95 | ::gas 96 | ::tariff-ends 97 | ::price-guarantee]) 98 | :categorize {::rate-card/payment-method nil 99 | ::rate-card/region nil 100 | :electricity.variant nil 101 | ::rate-card/available-for nil} 102 | :select {::rate-card/available-for restrict-availability})) 103 | 104 | (s/def ::tariffs (s/coll-of ::tariff)) 105 | -------------------------------------------------------------------------------- /src/speculate/transform.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.transform 2 | (:refer-clojure :exclude [alias *]) 3 | (:require 4 | [clojure.pprint :refer [pprint]] 5 | [clojure.set :as set] 6 | [clojure.spec.alpha :as s] 7 | [clojure.spec.override] 8 | [clojure.string :as string] 9 | [clojure.walk :as walk] 10 | [speculate.ast :as ast] 11 | [speculate.transform.extract :as tx] 12 | [speculate.transform.combine :as tc] 13 | [speculate.transform.maybe :as maybe] 14 | [speculate.util :as util])) 15 | 16 | (defn state [f] 17 | (with-meta (fn [state & args] (apply f state args)) 18 | {:name 'state-fn})) 19 | 20 | (defn assert-transformable! [from-spec to-spec to-leaves include value-index] 21 | (let [from-leaf-set (set (map :label value-index)) 22 | from-leaf-set (set (concat (map from-leaf-set include) 23 | from-leaf-set)) 24 | to-leaf-set (set (map #(or (from-leaf-set (:alias %)) 25 | (some-> % :alias-map first key from-leaf-set) 26 | (from-leaf-set (:label %)) 27 | (throw 28 | (ex-info (format "From leaf set can't find leaf: %s" (:label %)) 29 | {:spec to-spec :leaf %}))) to-leaves))] 30 | (assert 31 | (set/subset? to-leaf-set from-leaf-set) 32 | (format "Cannot transform %s to %s, because the from-spec's 33 | leaf-set does not contain all the required keys. 34 | missing: %s" 35 | from-spec 36 | to-spec 37 | (with-out-str 38 | (pprint (set/difference to-leaf-set from-leaf-set))))))) 39 | 40 | (defn strip-keys-categorizations [ast] 41 | (walk/postwalk 42 | (fn [ast] 43 | (or (when (map? ast) 44 | (let [{:keys [::ast/type categorize]} ast] 45 | (when (and type (= type 'speculate.spec/spec) categorize) 46 | (let [c (some->> categorize 47 | (remove (comp #{keys} second)) 48 | (seq) 49 | (into {}))] 50 | (if c 51 | (assoc ast :categorize c) 52 | (dissoc ast :categorize)))))) 53 | ast)) 54 | ast)) 55 | 56 | (defn format-problems [explaination] 57 | (->> explaination 58 | (:clojure.spec.alpha/problems) 59 | (map (fn [{:keys [path pred val in]}] 60 | (format "path: %s\npred: %s\n in: %s\n val:\n%s\n" 61 | path pred in (with-out-str (clojure.pprint/pprint val))))) 62 | (string/join "\n"))) 63 | 64 | (defn transform 65 | [from-spec to-spec value] 66 | (assert (s/valid? from-spec value) 67 | (format "Value does not conform to spec: %s\n%s" from-spec 68 | (s/explain from-spec value))) 69 | (let [to-ast (strip-keys-categorizations (ast/parse to-spec)) 70 | to-leaves (ast/leaves to-ast) 71 | to-nodeset (ast/nodeset to-ast) 72 | include (->> to-leaves (keep (comp first first :alias-map)) set) 73 | from-ast (ast/parse from-spec) 74 | min-from-ast (ast/shake to-nodeset from-ast) 75 | from-nodeset (ast/nodeset min-from-ast) 76 | [value-index s] (tx/run-walk min-from-ast value include to-nodeset) 77 | extract-meta (-> s 78 | (select-keys [:categorized :pathset-union :pulled]) 79 | (assoc :from-nodeset from-nodeset)) 80 | to-value (tc/combine value-index extract-meta to-ast)] 81 | (assert (s/valid? to-spec to-value) 82 | (format "Transformed value does not conform to spec: %s\n%s" 83 | to-spec 84 | (format-problems (s/explain-data to-spec to-value)))) 85 | to-value)) 86 | -------------------------------------------------------------------------------- /test/speculate/spec/rate_card.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.spec.rate-card 2 | (:require 3 | [clj-time.coerce :refer [to-date]] 4 | [clj-time.format :refer [formatter parse]] 5 | [clojure.spec.alpha :as s] 6 | [speculate.spec :as u] 7 | [speculate.util :as util] 8 | [clojure.future :refer :all])) 9 | 10 | (def dfmt (formatter "dd/MM/yyyy")) 11 | (defn coerce [pred coerce-fn] 12 | (s/conformer (comp #(when (pred %) %) 13 | #(try (coerce-fn %) (catch Throwable _ %))) 14 | identity)) 15 | 16 | (def coerce-date? 17 | (coerce #(instance? java.util.Date %) #(to-date (parse dfmt %)))) 18 | 19 | (s/def ::region 20 | (coerce #{10 11 12 13 14 15 16 17 18 19 20 21 22 23} 21 | #(Integer. (if (keyword? %) (name %) %)))) 22 | 23 | (def coerce-uuid? 24 | (coerce uuid? #(if (string? %) (java.util.UUID/fromString %) %))) 25 | 26 | (s/def ::uuid coerce-uuid?) 27 | 28 | ;;; ::tariff 29 | 30 | (s/def ::payment-method 31 | #{"Monthly Direct Debit" 32 | "Variable Direct Debit" 33 | "Pay On Receipt Of Bill" 34 | "Pay on Receipt of Bill" 35 | "Prepayment"}) 36 | 37 | (s/def ::payment-methods (s/coll-of ::payment-method)) 38 | 39 | (s/def ::variant #{"Standard" "Economy 7"}) 40 | 41 | (s/def ::meter (s/keys :req-un [::fuel ::variant])) 42 | 43 | (s/def ::tariff 44 | (u/spec 45 | :spec (s/keys :req-un [::regional-rates ::meter ::payment-methods]) 46 | :categorize {:meter (comp set list (juxt :fuel :variant) :meter) 47 | :fuel (comp set list util/hyphenate :fuel :meter) 48 | :electricity.variant (fn [{{:keys [fuel variant]} :meter}] 49 | (when (= fuel "Electricity") #{variant})) 50 | ::payment-method (comp set :payment-methods)})) 51 | 52 | (s/def ::tariffs (s/coll-of ::tariff)) 53 | 54 | (s/def ::night-rate boolean?) 55 | 56 | (s/def ::threshold (s/nilable nat-int?)) 57 | 58 | (def coerce-decimal? (coerce decimal? bigdec)) 59 | 60 | (s/def ::price coerce-decimal?) 61 | 62 | (s/def ::rate (s/keys :req-un [::night-rate ::price ::threshold])) 63 | 64 | (s/def ::rates (s/coll-of ::rate :max-count 3)) 65 | 66 | (s/def ::annual-standing-charge (s/nilable coerce-decimal?)) 67 | 68 | (s/def ::rate-guaranteed-until 69 | (s/nilable (s/or :date coerce-date? :months nat-int?))) 70 | 71 | (s/def ::fuel 72 | (coerce #{"electricity" "gas"} util/hyphenate)) 73 | 74 | (s/def ::supplier-name-key string?) 75 | (s/def ::supplier-name string?) 76 | (s/def ::supplier string?) 77 | (s/def ::name-key string?) 78 | (s/def ::name string?) 79 | 80 | (s/def ::regional-rate (s/keys :req-un [::annual-standing-charge ::rates])) 81 | 82 | (s/def ::11 ::regional-rate) 83 | (s/def ::12 ::regional-rate) 84 | (s/def ::14 ::regional-rate) 85 | (s/def ::18 ::regional-rate) 86 | 87 | (s/def ::regional-rates 88 | (u/spec 89 | :spec (s/keys :opt-un [::11 ::12 ::14 ::18]) 90 | :categorize {::region keys})) 91 | 92 | (s/def ::status #{"draft" "published" "historical" "archived"}) 93 | 94 | (s/def ::end-date coerce-date?) 95 | (s/def ::duration (s/nilable nat-int?)) 96 | (s/def ::available (s/nilable (s/or :date coerce-date? :months nat-int?))) 97 | (s/def ::fixed (s/or :date coerce-date? :bool boolean?)) 98 | (s/def ::rate-guarantee 99 | (s/keys :req-un [::end-date ::duration ::fixed ::available])) 100 | 101 | (s/def ::unfulfillable-payment-methods vector?) 102 | 103 | (s/def ::available-until (s/nilable nat-int?)) 104 | 105 | (s/def ::available-for 106 | (coerce #{"dual-fuel" "electricity" "gas"} util/hyphenate)) 107 | 108 | (s/def ::availability (s/coll-of ::available-for)) 109 | 110 | (s/def ::rate-card 111 | (u/spec 112 | :spec (s/keys :req-un [::uuid 113 | ::tariffs 114 | ::status 115 | ::supplier-name 116 | ::supplier-name-key 117 | ::name-key 118 | ::name 119 | ::rate-guarantee 120 | ::unfulfillable-payment-methods 121 | ::availability] 122 | :opt-un [::available-until]) 123 | :categorize {::available-for (fn [{:keys [availability]}] 124 | (->> availability 125 | (map #(s/conform ::available-for %)) 126 | (remove #{::s/invalid}) 127 | (set)))})) 128 | -------------------------------------------------------------------------------- /test/speculate/rate_card_tariff_test.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.rate-card-tariff-test 2 | (:require 3 | [clojure.edn :as edn] 4 | [clojure.test :refer [deftest is]] 5 | [speculate.spec.rate-card :as rate-card] 6 | [speculate.spec.tariff :as tariff] 7 | [speculate.transform :as tx])) 8 | 9 | (defn k= [k & [k2]] 10 | (let [fields {:rate-guarantee {:end-date nil 11 | :fixed true 12 | :duration 24 13 | :available 24} 14 | :name "Energy Supplier Energy Plan 1" 15 | :name-key "energy-supplier-energy-plan-1" 16 | :supplier-name "Energy Supplier Name" 17 | :supplier-name-key "energy-supplier-name-key" 18 | :supplier {:id "energy-supplier-name-key", :name "Energy Supplier Name"} 19 | :status "published" 20 | :uuid #uuid "29e5d2e5-e073-4a58-9c33-6c358bc7e1e1"} 21 | k2 (or k2 k)] 22 | (fn [val] 23 | (= (k fields) (k2 val))))) 24 | 25 | (defn matches-fuels? [{:keys [available-for electricity gas]}] 26 | (case available-for 27 | "electricity" (and electricity (not gas)) 28 | "gas" (and gas (not electricity)) 29 | "dual-fuel" (and electricity gas))) 30 | 31 | (defn matches-region-price? [{:keys [region] :as tariff}] 32 | (letfn [(matches? [{:keys [standing-charge rates]}] 33 | (let [[unit-rate] (filter (comp #{"unit-rate"} :type) rates) 34 | [night-rate] (filter (comp #{"night-rate"} :type) rates)] 35 | (and (= region (int (/ standing-charge 100))) 36 | (= region (int (/ (:price unit-rate) 1000))) 37 | (if night-rate 38 | (= region (int (/ (:price night-rate) 1000))) 39 | true))))] 40 | (and (if-let [e (:electricity tariff)] (matches? e) true) 41 | (if-let [e (:gas tariff)] (matches? e) true)))) 42 | 43 | (defn matches-unit-night-rate-price? [tariff] 44 | (letfn [(matches? [{:keys [rates]}] 45 | (let [[unit-rate] (filter (comp #{"unit-rate"} :type) rates) 46 | [night-rate] (filter (comp #{"night-rate"} :type) rates)] 47 | (and (zero? (int (mod (:price unit-rate) 10))) 48 | (if night-rate 49 | (= 1 (int (mod (:price night-rate) 10))) 50 | true))))] 51 | (and (if-let [e (:electricity tariff)] (matches? e) true) 52 | (if-let [e (:gas tariff)] (matches? e) true)))) 53 | 54 | (def fuel-payment-method-index 55 | {"Monthly Direct Debit" {"Gas" {"Standard" 0} 56 | "Electricity" {"Economy 7" 1 57 | "Standard" 2}} 58 | "Variable Direct Debit" {"Gas" {"Standard" 0} 59 | "Electricity" {"Economy 7" 1 60 | "Standard" 2}} 61 | "Pay on Receipt of Bill" {"Gas" {"Standard" 3} 62 | "Electricity" {"Economy 7" 4 63 | "Standard" 5}}}) 64 | 65 | (defn matches-fuel-payment-method-price? [{:keys [payment-method] :as tariff}] 66 | (letfn [(matches? [fuel {:keys [standing-charge rates variant]}] 67 | (let [[unit-rate] (filter (comp #{"unit-rate"} :type) rates) 68 | [night-rate] (filter (comp #{"night-rate"} :type) rates) 69 | index (get-in fuel-payment-method-index 70 | [payment-method fuel variant])] 71 | (and (= index (mod (int (/ standing-charge 10)) 10)) 72 | (= index (mod (int (/ (:price unit-rate) 100)) 10)) 73 | (if night-rate 74 | (= index (mod (int (/ (:price night-rate) 100)) 10)) 75 | true))))] 76 | (and (if-let [e (:electricity tariff)] (matches? "Electricity" e) true) 77 | (if-let [e (:gas tariff)] (matches? "Gas" e) true)))) 78 | 79 | (deftest rate-card-tx-tariffs-test 80 | (let [simple-rate-card (-> (slurp "test-resources/rate-card.edn") 81 | (edn/read-string)) 82 | tariffs (tx/transform ::rate-card/rate-card 83 | ::tariff/tariffs 84 | simple-rate-card)] 85 | (is (every? (k= :uuid :tariff-id) tariffs)) 86 | (is (every? (k= :name) tariffs)) 87 | (is (every? (k= :supplier-name-key) tariffs)) 88 | (is (every? (k= :supplier) tariffs)) 89 | (is (every? matches-fuels? tariffs)) 90 | (is (every? matches-region-price? tariffs)) 91 | (is (every? matches-unit-night-rate-price? tariffs)) 92 | (is (every? matches-fuel-payment-method-price? tariffs)))) 93 | -------------------------------------------------------------------------------- /test-resources/rate-card.edn: -------------------------------------------------------------------------------- 1 | {:availability ["electricity" "dual_fuel"], 2 | :unfulfillable-payment-methods [], 3 | :rate-guarantee 4 | {:end-date nil, :fixed true, :duration 24, :available 24}, 5 | :name "Energy Supplier Energy Plan 1", 6 | :name-key "energy-supplier-energy-plan-1", 7 | :supplier-name "Energy Supplier Name", 8 | :supplier-name-key "energy-supplier-name-key", 9 | :status "published", 10 | :tariffs 11 | [{:regional-rates 12 | {:14 13 | {:annual-standing-charge 1401.05, 14 | :rates [{:threshold nil, :price 14020.05, :night-rate false}]}, 15 | :18 16 | {:rates [{:night-rate false, :threshold nil, :price 18020.05}], 17 | :annual-standing-charge 1801.05}, 18 | :12 19 | {:rates [{:price 12020.05, :threshold nil, :night-rate false}], 20 | :annual-standing-charge 1201.05}, 21 | :11 22 | {:rates [{:night-rate false, :price 11020.05, :threshold nil}], 23 | :annual-standing-charge 1101.05}}, 24 | :payment-methods ["Monthly Direct Debit" "Variable Direct Debit"], 25 | :meter {:variant "Standard", :fuel "Gas"}} 26 | {:regional-rates 27 | {:14 28 | {:rates 29 | [{:night-rate false, :threshold nil, :price 14120.05} 30 | {:threshold nil, :price 14121.05, :night-rate true}], 31 | :annual-standing-charge 1411.05}, 32 | :18 33 | {:rates 34 | [{:night-rate false, :threshold nil, :price 18120.05} 35 | {:price 18121.05, :threshold nil, :night-rate true}], 36 | :annual-standing-charge 1811.05}, 37 | :12 38 | {:rates 39 | [{:night-rate false, :price 12120.05, :threshold nil} 40 | {:night-rate true, :price 12121.05, :threshold nil}], 41 | :annual-standing-charge 1211.05}, 42 | :11 43 | {:annual-standing-charge 1111.05, 44 | :rates 45 | [{:night-rate false, :price 11120.05, :threshold nil} 46 | {:price 11121.05, :threshold nil, :night-rate true}]}}, 47 | :meter {:fuel "Electricity", :variant "Economy 7"}, 48 | :payment-methods ["Monthly Direct Debit" "Variable Direct Debit"]} 49 | {:regional-rates 50 | {:14 51 | {:annual-standing-charge 1421.05, 52 | :rates [{:price 14220.05, :threshold nil, :night-rate false}]}, 53 | :18 54 | {:rates [{:night-rate false, :threshold nil, :price 18220.05}], 55 | :annual-standing-charge 1821.05}, 56 | :12 57 | {:annual-standing-charge 1221.05, 58 | :rates [{:night-rate false, :price 12220.05, :threshold nil}]}, 59 | :11 60 | {:rates [{:threshold nil, :price 11220.05, :night-rate false}], 61 | :annual-standing-charge 1121.05}}, 62 | :payment-methods ["Monthly Direct Debit" "Variable Direct Debit"], 63 | :meter {:variant "Standard", :fuel "Electricity"}} 64 | {:payment-methods ["Pay on Receipt of Bill"], 65 | :meter {:variant "Standard", :fuel "Gas"}, 66 | :regional-rates 67 | {:14 68 | {:annual-standing-charge 1431.05, 69 | :rates [{:night-rate false, :price 14320.05, :threshold nil}]}, 70 | :18 71 | {:rates [{:night-rate false, :price 18320.05, :threshold nil}], 72 | :annual-standing-charge 1831.05}, 73 | :12 74 | {:rates [{:night-rate false, :threshold nil, :price 12320.05}], 75 | :annual-standing-charge 1231.05}, 76 | :11 77 | {:annual-standing-charge 1131.05, 78 | :rates [{:price 11320.05, :threshold nil, :night-rate false}]}}} 79 | {:regional-rates 80 | {:14 81 | {:annual-standing-charge 1441.05, 82 | :rates 83 | [{:night-rate false, :threshold nil, :price 14420.05} 84 | {:night-rate true, :price 14421.05, :threshold nil}]}, 85 | :18 86 | {:annual-standing-charge 1841.05, 87 | :rates 88 | [{:night-rate false, :threshold nil, :price 18420.05} 89 | {:night-rate true, :price 18421.05, :threshold nil}]}, 90 | :12 91 | {:rates 92 | [{:night-rate false, :price 12420.05, :threshold nil} 93 | {:night-rate true, :price 12421.05, :threshold nil}], 94 | :annual-standing-charge 1241.05}, 95 | :11 96 | {:rates 97 | [{:threshold nil, :price 11420.05, :night-rate false} 98 | {:price 11421.05, :threshold nil, :night-rate true}], 99 | :annual-standing-charge 1141.05}}, 100 | :payment-methods ["Pay on Receipt of Bill"], 101 | :meter {:fuel "Electricity", :variant "Economy 7"}} 102 | {:meter {:variant "Standard", :fuel "Electricity"}, 103 | :payment-methods ["Pay on Receipt of Bill"], 104 | :regional-rates 105 | {:14 106 | {:annual-standing-charge 1451.05, 107 | :rates [{:night-rate false, :threshold nil, :price 14520.05}]}, 108 | :18 109 | {:rates [{:night-rate false, :price 18520.05, :threshold nil}], 110 | :annual-standing-charge 1851.05}, 111 | :12 112 | {:annual-standing-charge 1251.05, 113 | :rates [{:night-rate false, :threshold nil, :price 12520.05}]}, 114 | :11 115 | {:annual-standing-charge 1151.05, 116 | :rates [{:night-rate false, :price 11520.05, :threshold nil}]}}}], 117 | :uuid "29e5d2e5-e073-4a58-9c33-6c358bc7e1e1"} 118 | -------------------------------------------------------------------------------- /src/speculate/util.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.util 2 | (:refer-clojure :exclude [set]) 3 | (:require 4 | [clojure.string :as string] 5 | [clojure.walk :as walk] 6 | [clojure.set :as set] 7 | [clojure.spec.alpha :as s] 8 | [clojure.spec.gen.alpha :as gen])) 9 | 10 | (defn deep-merge [& xs] 11 | (cond (every? map? xs) 12 | (apply merge-with deep-merge xs) 13 | (every? set? xs) 14 | (apply set/union xs) 15 | :else 16 | (last xs))) 17 | 18 | (def clojure-spec-symbol? 19 | '#{clojure.spec.alpha/& 20 | clojure.spec.alpha/* 21 | clojure.spec.alpha/+ 22 | clojure.spec.alpha/? 23 | clojure.spec.alpha/alt 24 | clojure.spec.alpha/and 25 | clojure.spec.alpha/cat 26 | clojure.spec.alpha/coll-of 27 | clojure.spec.alpha/double-in 28 | clojure.spec.alpha/every 29 | clojure.spec.alpha/every-kv 30 | clojure.spec.alpha/fspec 31 | clojure.spec.alpha/inst-in 32 | clojure.spec.alpha/int-in 33 | clojure.spec.alpha/int-in-range? 34 | clojure.spec.alpha/keys 35 | clojure.spec.alpha/keys* 36 | clojure.spec.alpha/map-of 37 | clojure.spec.alpha/map-spec 38 | clojure.spec.alpha/nilable 39 | clojure.spec.alpha/or 40 | clojure.spec.alpha/regex? 41 | clojure.spec.alpha/spec 42 | clojure.spec.alpha/tuple}) 43 | 44 | (def speculate-symbol? 45 | '#{speculate.spec/override 46 | speculate.spec/spec 47 | speculate.spec/strict}) 48 | 49 | (def spec-symbol? 50 | (set/union clojure-spec-symbol? speculate-symbol?)) 51 | 52 | (defn un-ns [k] 53 | (keyword (name k))) 54 | 55 | (defn spec? [x] 56 | (or (s/spec? x) 57 | (and (seq? x) 58 | (spec-symbol? (first x))))) 59 | 60 | (defn set [& xs] 61 | (clojure.core/set xs)) 62 | 63 | (defn pascal-case [s] 64 | (->> (string/split s #"-|_|(?=[A-Z])") 65 | (map string/capitalize) 66 | (string/join))) 67 | 68 | (defn hyphenate [s] 69 | (some-> s 70 | (string/split #"_| |(?=[A-Z])") 71 | (->> (string/join "-")) 72 | (string/lower-case))) 73 | 74 | (defn ->keyword [s] 75 | (let [[n ns] (reverse (string/split s #"/"))] 76 | (keyword (when ns (hyphenate ns)) (hyphenate n)))) 77 | 78 | (defn category [label] 79 | (cond (sequential? label) 80 | (keyword (string/join \. (map #(hyphenate (if (keyword? %) (name %) %)) label))) 81 | (string? label) 82 | (keyword (hyphenate label)) 83 | :default 84 | label)) 85 | 86 | (defn snake-case [s] 87 | (let [[h & more] (string/split s #"-|_|(?=[A-Z])")] 88 | (->> (map string/capitalize more) 89 | (cons (string/lower-case h)) 90 | (string/join)))) 91 | 92 | (defn snake-case-keys [m] 93 | (->> m 94 | (map (fn [[k v]] [(snake-case (cond-> k (keyword? k) name)) v])) 95 | (into {}))) 96 | 97 | (defn camel-case [s] 98 | (let [[h & tail] (string/split s #"-|_|(?=[A-Z])")] 99 | (string/join (cons (string/lower-case h) (map string/capitalize tail))))) 100 | 101 | (defn camel-case-keys [m] 102 | (->> m 103 | (map (fn [[k v]] [(camel-case (cond-> k (keyword? k) name)) v])) 104 | (into {}))) 105 | 106 | (defn ->sym 107 | "Returns a symbol from a symbol or var" 108 | [x] 109 | (if (var? x) 110 | (let [^clojure.lang.Var v x] 111 | (symbol (str (.name (.ns v))) 112 | (str (.sym v)))) 113 | x)) 114 | 115 | (defn unfn [expr] 116 | (if (and (seq? expr) 117 | (symbol? (first expr)) 118 | (= "fn*" (name (first expr)))) 119 | (let [[[s] & form] (rest expr)] 120 | (conj (walk/postwalk-replace {s '%} form) '[%] 'fn)) 121 | expr)) 122 | 123 | (defn res [form] 124 | (cond 125 | (keyword? form) form 126 | (symbol? form) (or (-> form resolve ->sym) form) 127 | (sequential? form) (walk/postwalk #(if (symbol? %) (res %) %) (unfn form)) 128 | :else form)) 129 | 130 | (defn named? [x] 131 | (instance? clojure.lang.Named x)) 132 | 133 | (defn cartesian-product 134 | "All the ways to take one item from each sequence" 135 | [& seqs] 136 | (let [v-original-seqs (vec seqs) 137 | step 138 | (fn step [v-seqs] 139 | (let [increment 140 | (fn [v-seqs] 141 | (loop [i (dec (count v-seqs)), v-seqs v-seqs] 142 | (if (= i -1) nil 143 | (if-let [rst (next (v-seqs i))] 144 | (assoc v-seqs i rst) 145 | (recur (dec i) (assoc v-seqs i (v-original-seqs i)))))))] 146 | (when v-seqs 147 | (cons (map first v-seqs) 148 | (lazy-seq (step (increment v-seqs)))))))] 149 | (when (every? seq seqs) 150 | (lazy-seq (step v-original-seqs))))) 151 | 152 | (defn kvs-cartesian-product [m] 153 | (->> m 154 | (keep (fn [[k vs]] (when (seq vs) (map (fn [v] [k v]) vs)))) 155 | (apply cartesian-product) 156 | (map (partial into {})))) 157 | 158 | (defn rlookup [f] 159 | (some (fn [[k v]] (and (var? v) (= @v f) k)) 160 | (ns-publics *ns*))) 161 | 162 | (defn soft-alias [alias-sym namespace-sym] 163 | (clojure.core/alias alias-sym 164 | (clojure.lang.Namespace/findOrCreate namespace-sym))) 165 | 166 | (defmacro ns-alias 167 | ([alias] 168 | `(ns-alias ~alias ~alias)) 169 | ([alias namespace-sym] 170 | `(soft-alias '~alias '~(symbol (format "%s.%s" 171 | (name (.getName *ns*)) 172 | (name namespace-sym)))))) 173 | -------------------------------------------------------------------------------- /src/speculate/swagger.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.swagger 2 | (:refer-clojure :exclude [derive find]) 3 | (:require 4 | [clojure.set :as set] 5 | [clojure.spec.alpha :as s] 6 | [clojure.walk :as walk] 7 | [speculate.ast :as ast] 8 | [speculate.render :as render] 9 | [speculate.json-schema :as json] 10 | [speculate.spec :as spec] 11 | [speculate.util :as util])) 12 | 13 | (defn find 14 | "Performs a depth-first search in `x` for key `k`, returns `val` for 15 | the first found `k`." 16 | [x k] 17 | (if (and (associative? x) (contains? x k)) 18 | (x k) 19 | (cond (map? x) 20 | (some #(find % k) (vals x)) 21 | (sequential? x) 22 | (some #(find % k) x)))) 23 | 24 | (defn match 25 | "Performs a depth-first search in `x` for key `k`, where `val` 26 | matches predicate function pred. returns `val` for the first matched 27 | `k` -> `(pred val)`." 28 | [x pred & preds] 29 | (or (when (pred x) 30 | (if (seq preds) 31 | (apply match x preds) 32 | x)) 33 | (cond (map? x) 34 | (some #(apply match % pred preds) (vals x)) 35 | (sequential? x) 36 | (some #(apply match % pred preds) x)))) 37 | 38 | 39 | ;;; Responses 40 | 41 | (defn response [{:keys [form description] :as response}] 42 | [(render/render ::render/abbrev (find form :status)) 43 | {:description (render/render ::json/renderer description) 44 | :schema (render/render ::json/renderer (find form :body))}]) 45 | 46 | (def -responses nil) 47 | (defmulti -responses ::ast/type) 48 | 49 | (defmethod -responses `spec/spec [{:keys [form] :as spec}]) 50 | 51 | (defmethod -responses `s/or [{:keys [form]}] 52 | (->> form 53 | (sort-by key) 54 | (map (fn [[k v]] (response v))) 55 | (into (array-map)))) 56 | 57 | (defmethod -responses :default [x]) 58 | 59 | (defn responses [{:keys [form] :as spec}] 60 | (some-> form 61 | (match (comp #{`s/fspec} ::ast/type) #(get % :ret)) 62 | (:ret) 63 | (-responses))) 64 | 65 | 66 | ;;; Produces 67 | 68 | (defn produce [form] 69 | (-> form (find :headers) (find "Content-Type") :form)) 70 | 71 | (def -produces nil) 72 | (defmulti -produces ::ast/type) 73 | 74 | (defmethod -produces `s/or [{:keys [form]}] 75 | (->> form 76 | (map (fn [[_ v]] (produce v))) 77 | (apply set/union))) 78 | 79 | (defn produces [{:keys [form] :as spec}] 80 | (some-> form 81 | (match (comp #{`s/fspec} ::ast/type) #(get % :ret)) 82 | (:ret) 83 | (-produces))) 84 | 85 | 86 | ;;; Parameters 87 | 88 | (defn parameter []) 89 | (def -parameters nil) 90 | (defmulti -parameters ::ast/type) 91 | (defmethod -parameters `map? [{:keys [form]}] 92 | (->> form 93 | (map (fn [[k v]] 94 | [(name k) 95 | (render/render ::json/renderer (:form v))])) 96 | (into {}))) 97 | 98 | (defmethod -parameters `s/keys [{:keys [form]}] 99 | (->> form 100 | (map (fn [[k v]] 101 | [(name k) 102 | (render/render ::json/renderer (:form v))])) 103 | (into {}))) 104 | 105 | (defmethod render/render [::parameters `map?] 106 | [_ {:keys [form]}] 107 | (->> form 108 | ; param type if either query or path 109 | (mapcat (fn [[param-type {:keys [form]}]] 110 | (->> form 111 | (map (fn [[k v]] 112 | (-> (render/render ::json/renderer v) 113 | (assoc :name (name k)) 114 | (assoc :in param-type) 115 | (dissoc :schema-name))))))))) 116 | 117 | (defn parameters [{:keys [form] :as spec}] 118 | (clojure.pprint/pprint form) 119 | (let [query-params (match form 120 | (fn [x] 121 | (when-let [pname (::ast/name x)] 122 | (and (keyword? pname) 123 | (= "query-params" (name pname)))))) 124 | route-params (match form 125 | (fn [x] 126 | (when-let [pname (::ast/name x)] 127 | (and (keyword? pname) (= "route-params" (name pname))))))] 128 | (concat (map (fn [spec] 129 | (-> (render/render ::json/renderer spec) 130 | (assoc :name (name (::ast/name spec))) 131 | (assoc :in "query") 132 | (dissoc :schema-name))) 133 | (find query-params :req-un)) 134 | (map (fn [spec] 135 | (-> (render/render ::json/renderer spec) 136 | (assoc :name (name (::ast/name spec))) 137 | (assoc :in "path") 138 | (dissoc :schema-name))) 139 | (find route-params :req-un))))) 140 | 141 | 142 | ;;; Rendering 143 | (defn render-method [[k {:keys [handler] :as v}]] 144 | (let [base (dissoc v :handler) 145 | method (name k) 146 | ast (ast/parse handler) 147 | responses (some-> ast responses) 148 | parameters (some-> ast parameters) 149 | produces nil;(some-> ast produces) 150 | ] 151 | [method (assoc base 152 | :responses responses 153 | :parameters parameters 154 | :produces produces)])) 155 | 156 | (s/def ::swagger string?) 157 | (s/def ::basePath string?) 158 | (s/def ::info map?) 159 | 160 | (s/def ::swagger-template 161 | (s/keys :req-un [::swagger ::base-path] 162 | :opt-un [::info])) 163 | 164 | (defn derive [paths swagger-template] 165 | ;{:pre [(s/valid? ::swagger-template swagger-template)]} 166 | (s/assert* ::swagger-template swagger-template) 167 | (let [defs (atom {}) 168 | extract (partial json/extract-definitions defs) 169 | paths (->> paths 170 | (map (fn [[path {:keys [methods] :as resource}]] 171 | [path (->> methods 172 | (map render-method) 173 | (into {}))])) 174 | (into {}) 175 | (walk/postwalk extract))] 176 | (merge (util/camel-case-keys swagger-template) 177 | {:paths paths 178 | :definitions @defs}))) 179 | -------------------------------------------------------------------------------- /src/clojure/spec/override.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.spec.override 2 | (:require 3 | [clojure.spec.alpha :refer :all])) 4 | 5 | (alias 'c 'clojure.core) 6 | 7 | (in-ns 'clojure.spec.alpha) 8 | 9 | (defn ^:skip-wiki every-impl 10 | "Do not call this directly, use 'every', 'every-kv', 'coll-of' or 'map-of'" 11 | ([form pred opts] (every-impl form pred opts nil)) 12 | ([form pred {gen-into :into 13 | :keys [kind ::kind-form count max-count min-count distinct gen-max ::kfn 14 | conform-keys ::conform-all] 15 | :or {gen-max 20} 16 | :as opts} 17 | gfn] 18 | (let [conform-into gen-into 19 | check? #(valid? pred %) 20 | kfn (c/or kfn (fn [i v] i)) 21 | addcv (fn [ret i v cv] (conj ret cv)) 22 | cfns (fn [x] 23 | ;;returns a tuple of [init add complete] fns 24 | (cond 25 | (c/and (vector? x) (c/or (not conform-into) (vector? conform-into))) 26 | [identity 27 | (fn [ret i v cv] 28 | (if (identical? v cv) 29 | ret 30 | (assoc ret i cv))) 31 | identity] 32 | 33 | (c/and (map? x) (c/or (c/and kind (not conform-into)) (map? conform-into))) 34 | [(if conform-keys empty identity) 35 | (fn [ret i v cv] 36 | (if (c/and (identical? v cv) (not conform-keys)) 37 | ret 38 | (assoc ret (nth (if conform-keys cv v) 0) (nth cv 1)))) 39 | identity] 40 | 41 | (c/or (list? conform-into) (c/and (not conform-into) (list? x))) 42 | [(constantly ()) addcv reverse] 43 | 44 | :else [#(empty (c/or conform-into %)) addcv identity]))] 45 | (reify 46 | Spec 47 | (conform* [_ x] 48 | (cond 49 | (coll-prob x kind kind-form distinct count min-count max-count 50 | nil nil nil) 51 | ::invalid 52 | 53 | conform-all 54 | (let [[init add complete] (cfns x)] 55 | (loop [ret (init x), i 0, [v & vs :as vseq] (seq x)] 56 | (if vseq 57 | (let [cv (dt pred v nil)] 58 | (if (= ::invalid cv) 59 | ::invalid 60 | (recur (add ret i v cv) (inc i) vs))) 61 | (complete ret)))) 62 | 63 | 64 | :else 65 | (if (indexed? x) 66 | (let [step (max 1 (long (/ (c/count x) *coll-check-limit*)))] 67 | (loop [i 0] 68 | (if (>= i (c/count x)) 69 | x 70 | (if (check? (nth x i)) 71 | (recur (c/+ i step)) 72 | ::invalid)))) 73 | (c/or (c/and (every? check? (take *coll-check-limit* x)) x) 74 | ::invalid)))) 75 | (unform* [_ x] 76 | ;; Presume this is a collection for ease 77 | (letfn [(maybe-unform [x] 78 | (cond (and (not (fn? pred)) 79 | (contains? (registry) pred)) 80 | (unform pred x) 81 | (satisfies? clojure.spec.alpha/Spec pred) 82 | (unform pred x) 83 | :else x))] 84 | (cond (vector? x) 85 | (mapv maybe-unform x) 86 | (seq? x) 87 | (map maybe-unform x) 88 | (set? x) 89 | (set (map maybe-unform x)) 90 | :default x))) 91 | (explain* [_ path via in x] 92 | (c/or (coll-prob x kind kind-form distinct count min-count max-count 93 | path via in) 94 | (apply concat 95 | ((if conform-all identity (partial take *coll-error-limit*)) 96 | (keep identity 97 | (map (fn [i v] 98 | (let [k (kfn i v)] 99 | (when-not (check? v) 100 | (let [prob (explain-1 form pred path via (conj in k) v)] 101 | prob)))) 102 | (range) x)))))) 103 | (gen* [_ overrides path rmap] 104 | (if gfn 105 | (gfn) 106 | (let [pgen (gensub pred overrides path rmap form)] 107 | (gen/bind 108 | (cond 109 | gen-into (gen/return (empty gen-into)) 110 | kind (gen/fmap #(if (empty? %) % (empty %)) 111 | (gensub kind overrides path rmap form)) 112 | :else (gen/return [])) 113 | (fn [init] 114 | (gen/fmap 115 | #(if (vector? init) % (into init %)) 116 | (cond 117 | distinct 118 | (if count 119 | (gen/vector-distinct pgen {:num-elements count :max-tries 100}) 120 | (gen/vector-distinct pgen {:min-elements (c/or min-count 0) 121 | :max-elements (c/or max-count (max gen-max (c/* 2 (c/or min-count 0)))) 122 | :max-tries 100})) 123 | 124 | count 125 | (gen/vector pgen count) 126 | 127 | (c/or min-count max-count) 128 | (gen/vector pgen (c/or min-count 0) (c/or max-count (max gen-max (c/* 2 (c/or min-count 0))))) 129 | 130 | :else 131 | (gen/vector pgen 0 gen-max)))))))) 132 | 133 | (with-gen* [_ gfn] (every-impl form pred opts gfn)) 134 | (describe* [_] `(every ~form ~@(mapcat identity opts))))))) 135 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Speculate 2 | 3 | Speculate is a library that extends `clojure.spec` and interprets what 4 | `clojure.spec`s mean. It can translate specs into different formats, 5 | whilst retaining all the features and power of `clojure.spec`. 6 | 7 | It does this by analysing `clojure.spec` forms, and building an 8 | abstract syntax tree (AST) as an intermediary form, which can then be 9 | rendered into different formats. Included formats are `json-schema` 10 | and swagger's "openapi specification". 11 | 12 | Speculate understands regular `clojure.spec` specs, but currently 13 | `clojure.spec`s do not provide enough informtation to render highly 14 | descriptive `json-schema` documents, or swagger-like formats. 15 | 16 | Speculate provides a way to decorate existing `clojure.spec` forms 17 | with arbitrary information, giving control of what is output to the 18 | user. 19 | 20 | Speculate produces Clojure datastructures that can be serialized to 21 | any serialization format (such as json), with a relevant library 22 | (such as [cheshire](https://github.com/dakrone/cheshire)). 23 | 24 | ## Status 25 | 26 | The status of this project is pre-alpha. It works for our case. the 27 | API is subject to change. We're working towards a stable API. 28 | 29 | ## Artifacts 30 | 31 | `speculate` artifacts are [released to Clojars](https://clojars.org/speculate). 32 | 33 | If you are using Maven, add the following repository definition to your `pom.xml`: 34 | 35 | ``` xml 36 | 37 | clojars.org 38 | http://clojars.org/repo 39 | 40 | ``` 41 | 42 | ### The Most Recent Release 43 | 44 | With Leiningen/Boot: 45 | 46 | ``` clj 47 | ;; In active development 48 | [speculate "0.3.0-SNAPSHOT"] 49 | 50 | ``` 51 | 52 | ## Usage 53 | 54 | ### Usage with default `clojure.spec`s 55 | 56 | ``` clojure 57 | 58 | (require '[clojure.spec :as s]) 59 | 60 | (s/def ::color #{"red" "green" "yellow"}) 61 | (s/def ::diameter pos-int?) 62 | (s/def ::description string?) 63 | (s/def ::apple (s/keys :req-un [::color ::diameter] :opt-un [::description])) 64 | 65 | (require '[speculate.json-schema :as js]) 66 | (require '[speculate.ast :as ast]) 67 | 68 | (js/schema (ast/parse ::apple)) 69 | 70 | => {:type object, 71 | :properties {"color" {:enum #{"yellow" "green" "red"}, 72 | :type {:type string}}, 73 | "diameter" {:type integer, :format int32, :minimum 1}, 74 | "description" {:type string}}, 75 | :required ["color" "diameter"], 76 | :title "Apple"} 77 | 78 | ``` 79 | 80 | ### Generating detailed `json-schema` 81 | 82 | 83 | ``` clojure 84 | 85 | (require '[clojure.spec :as s]) 86 | (require '[speculate.spec :as u]) 87 | 88 | (s/def ::color #{"red" "green" "yellow"}) 89 | 90 | (s/def ::diameter 91 | (u/spec 92 | :description "Diameter of an apple in millimetres." 93 | :spec pos-int? 94 | :maximum 300)) 95 | 96 | (s/def ::description string?) 97 | 98 | (s/def ::apple 99 | (u/spec 100 | :description "The fruit of the apple tree." 101 | :spec (s/keys :req-un [::color ::diameter] :opt-un [::description]))) 102 | 103 | (s/def ::apples (u/set-of ::apple)) 104 | 105 | (s/def ::apple-tree 106 | (u/spec 107 | :description "The apple tree (Malus pumila, commonly and 108 | erroneously called Malus domestica) is a deciduous 109 | tree in the rose family best known for its sweet, 110 | pomaceous fruit, the apple." 111 | :spec (s/keys :req-un [::apples]))) 112 | 113 | (require '[speculate.json-schema :as js]) 114 | (require '[speculate.ast :as ast]) 115 | 116 | (js/schema (ast/parse ::apple)) 117 | 118 | => {:properties {"apples" {:type array 119 | :items {:properties {"color" {:enum #{"yellow" "green" "red"} 120 | :type {:type string}} 121 | "diameter" {:type integer 122 | :minimum 1 123 | :title "Diameter" 124 | :description "Diameter of an apple in millimetres." 125 | :maximum 300} 126 | "description" {:type string}} 127 | :type object 128 | :required ["color" "diameter"] 129 | :title "Apple" 130 | :description "The fruit of the apple tree."}}} 131 | :type object 132 | :required ["apples"] 133 | :title "AppleTree" 134 | :description "The apple tree (Malus pumila commonly and erroneously 135 | called Malus domestica) is a deciduous tree in the 136 | rose family best known for its sweet pomaceous fruit 137 | the apple."} 138 | 139 | (js/schema (ast/parse ::apple-tree) :extract-definitions? true) 140 | 141 | => {"AppleTree" {:properties {"apples" {:type array 142 | :items {"$ref" "#!/definitions/Apple"}}} 143 | :type object 144 | :required ["apples"] 145 | :title "AppleTree" 146 | :description "The apple tree (Malus pumila commonly and 147 | erroneously called Malus domestica) is a 148 | deciduous tree in the rose family best 149 | known for its sweet pomaceous fruit the apple."} 150 | :definitions {"Diameter" {:type integer 151 | :minimum 1 152 | :title "Diameter" 153 | :description "Diameter of an apple in millimetres." 154 | :maximum 300} 155 | "Apple" {:properties {"color" {:enum #{"yellow" "green" "red"} 156 | :type {:type string}} 157 | "diameter" {"$ref" "#!/definitions/Diameter"} 158 | "description" {:type string}} 159 | :type object 160 | :required ["color" "diameter"] 161 | :title "Apple" 162 | :description "The fruit of the apple tree."}}} 163 | 164 | ``` 165 | 166 | ## License 167 | 168 | Distributed under the Eclipse Public License, the same as Clojure. 169 | -------------------------------------------------------------------------------- /src/speculate/json_schema.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.json-schema 2 | (:refer-clojure :exclude [type]) 3 | (:require 4 | [clojure.set :as set] 5 | [clojure.string :as string] 6 | [clojure.walk :as walk] 7 | [speculate.util :as util] 8 | [speculate.ast :as ast] 9 | [speculate.render :refer [render]])) 10 | 11 | (def description-keys 12 | #{:clojure.spec.alpha/name :name :type :title :description}) 13 | 14 | (def validation-keys 15 | {;; number 16 | :minimum 'number 17 | :exclusive-minimum 'number 18 | :maximum 'number 19 | :exclusive-maximum 'number 20 | :multiple-of 'number 21 | ;; string 22 | :max-length 'string 23 | :min-length 'string 24 | :pattern 'string 25 | ;; array 26 | :min-items 'array 27 | :max-items 'array 28 | :items 'array 29 | :additional-items 'array 30 | :unique-items 'array 31 | ;; objects 32 | :properties 'object 33 | :max-properties 'object 34 | :min-properties 'object 35 | :pattern-properties 'object 36 | :additional-properties 'object 37 | :required 'object 38 | :dependencies 'object 39 | ;; enum 40 | :enum 'enum}) 41 | 42 | (def schema-keys 43 | (set/union description-keys (set (keys validation-keys)))) 44 | 45 | (defmulti type identity) 46 | 47 | ;; Simple Types 48 | (defmethod type nil [_] {:type 'null}) 49 | (defmethod type `nil? [_] {:type 'null}) 50 | (defmethod type `boolean? [_] {:type 'boolean}) 51 | (defmethod type `string? [_] {:type 'string}) 52 | 53 | ;; Named 54 | (defmethod type `keyword? [_] {:type 'string}) 55 | (defmethod type `symbol? [_] {:type 'string}) 56 | 57 | ;; Numbers 58 | (defmethod type `char? [_] {:type 'string}) 59 | (defmethod type `int? [_] {:type 'integer :format 'int32}) 60 | (defmethod type `integer? [_] {:type 'integer :format 'int32}) 61 | (defmethod type `pos-int? [_] {:type 'integer :format 'int32 :minimum 1}) 62 | (defmethod type `nat-int? [_] {:type 'integer :format 'int32 :minimum 0}) 63 | (defmethod type `bigdec? [_] {:type 'long :format 'int64}) 64 | (defmethod type `decimal? [_] {:type 'double}) 65 | (defmethod type `double? [_] {:type 'double}) 66 | (defmethod type `float? [_] {:type 'float}) 67 | (defmethod type `number? [_] {:type 'float}) 68 | (defmethod type `ratio? [_] {:type 'float}) 69 | (defmethod type `rational? [_] {:type 'float}) 70 | 71 | ;; Domain Types 72 | (defmethod type `uri? [_] {:type 'string :format 'url}) 73 | (defmethod type `uuid? [_] {:type 'string :format 'uuid}) 74 | 75 | ;; Sequences 76 | (defmethod type `coll? [_] {:type 'array}) 77 | (defmethod type `list? [_] {:type 'array}) 78 | (defmethod type `seq? [_] {:type 'array}) 79 | (defmethod type `sequential? [_] {:type 'array}) 80 | (defmethod type `vector? [_] {:type 'array}) 81 | 82 | ;; Sets 83 | (defmethod type `set? [_] {:type 'array}) 84 | 85 | ;; Maps 86 | (defmethod type `map? [_] {:type 'object}) 87 | 88 | ;; Clojure Classes 89 | (defmethod type clojure.lang.Keyword [_] {:type 'string}) 90 | (defmethod type clojure.lang.Symbol [_] {:type 'string}) 91 | 92 | ;; Java Classes 93 | (defmethod type java.lang.Integer [_] {:type 'integer :format 'int32}) 94 | (defmethod type java.lang.Long [_] {:type 'long :format 'int64}) 95 | (defmethod type java.lang.Double [_] {:type 'number :format 'double}) 96 | (defmethod type java.lang.Number [_] {:type 'number :format 'double}) 97 | (defmethod type java.lang.String [_] {:type 'string}) 98 | (defmethod type java.lang.Boolean [_] {:type 'boolean}) 99 | (defmethod type java.util.UUID [_] {:type 'string :format 'uuid}) 100 | (defmethod type java.util.Date [_] {:type 'string :format 'date-time}) 101 | (defmethod type java.util.regex.Pattern [_] {:type 'string :format 'regex}) 102 | 103 | (defmethod type :default [_]) 104 | 105 | (defn derive-set-type [s] 106 | (let [[t :as ts] (map class s)] 107 | (if (every? (partial = t) ts) 108 | (type t) 109 | (distinct (remove nil? (map type ts)))))) 110 | 111 | (defmethod render [::renderer 'clojure.core/set?] 112 | [_ {:keys [form] :as x}] 113 | (merge {:enum form 114 | :type (derive-set-type form)} 115 | (select-keys x schema-keys))) 116 | 117 | (defmethod render [::renderer 'clojure.core/map?] 118 | [_ {:keys [form] :as x}] 119 | (->> form 120 | (map (fn [[k v]] [k (render ::renderer v)])) 121 | (into {}))) 122 | 123 | (defmethod render [::renderer 'clojure.core/symbol?] 124 | [_ {:keys [form] :as x}] 125 | (merge (type form) (select-keys x schema-keys))) 126 | 127 | (defmethod render [::renderer 'clojure.spec.alpha/keys] 128 | [_ {{:keys [req req-un opt opt-un]} :form :as spec}] 129 | (let [pname (::ast/name spec) 130 | title (some-> pname name util/pascal-case) 131 | properties (->> (concat req req-un opt opt-un) 132 | (map (juxt (comp name ::ast/name) 133 | (partial render ::renderer))) 134 | (into {})) 135 | base (cond-> {:type 'object 136 | :properties properties 137 | :required (mapv (comp name ::ast/name) 138 | (concat req req-un))} 139 | pname (assoc :schema-name pname) 140 | title (assoc :title title))] 141 | (merge base (select-keys spec schema-keys)))) 142 | 143 | (defmethod render [::renderer 'clojure.spec.alpha/every] 144 | [_ {:keys [form] :as spec}] 145 | ;; this could also be a map-of 146 | ;; (and (form? form) (= `s/tuple (first form))) 147 | ;; (merge-spec-meta {:type 'object :properties }) 148 | (let [base {:type 'array 149 | :items (render ::renderer form)}] 150 | (merge base (select-keys spec schema-keys)))) 151 | 152 | (defmethod render [::renderer 'clojure.spec.alpha/coll-of] 153 | [_ {:keys [form] :as spec}] 154 | ;; this could also be a map-of 155 | ;; (and (form? form) (= `s/tuple (first form))) 156 | ;; (merge-spec-meta {:type 'object :properties }) 157 | (let [base {:type 'array 158 | :items (render ::renderer form)}] 159 | (merge base (select-keys spec schema-keys)))) 160 | 161 | (defmethod render [::renderer 'clojure.spec.alpha/and] 162 | [_ {:keys [form] :as spec}] 163 | (merge (reduce merge {} (map (partial render ::renderer) form)) spec)) 164 | 165 | (defmethod render [::renderer 'clojure.spec.alpha/or] 166 | [_ {:keys [form]}] 167 | {:one-of (map (comp (partial render ::renderer) second) form)}) 168 | 169 | (defmethod render [::renderer 'speculate.spec/spec] 170 | [_ {:keys [form] :as m}] 171 | (let [pname (::ast/name m) 172 | title (some-> pname name util/pascal-case) 173 | base (cond-> (render ::renderer form) 174 | :trim (select-keys schema-keys) 175 | pname (assoc :schema-name pname) 176 | title (assoc :title title))] 177 | (merge base (select-keys m schema-keys)))) 178 | 179 | (defmethod render [::renderer ::URI] 180 | [_ {:keys [::base-uri] :as ast}] 181 | (let [pname (::ast/name ast)] 182 | {"$ref" (format "%s/%s/%s" 183 | base-uri 184 | (some-> pname namespace (string/replace #"\." "/")) 185 | (name pname))})) 186 | 187 | (defmethod render [::renderer ::root] 188 | [_ {:keys [::base-uri form] :as ast}] 189 | (let [pname (::ast/name form) 190 | sub (render ::renderer form)] 191 | (merge sub 192 | {"$schema" (format "%s/%s/%s" 193 | base-uri 194 | (some-> pname namespace (string/replace #"\." "/")) 195 | (name pname))}))) 196 | 197 | (defn extract-definitions [atom x] 198 | (if (and (map? x) (contains? x :schema-name)) 199 | (let [{title :title} x 200 | x (dissoc x :schema-name)] 201 | (swap! atom assoc title x) 202 | {"$ref" (format "#/definitions/%s" title)}) 203 | x)) 204 | 205 | (defn schema [ast & {:keys [extract-definitions?]}] 206 | (let [rendered (render ::renderer ast)] 207 | (if extract-definitions? 208 | (let [defs (atom {}) 209 | extract (partial extract-definitions defs) 210 | base (->> (dissoc rendered :schema-name) 211 | (map (fn [[k v]] [k (walk/postwalk extract v)])) 212 | (into {}))] 213 | (if (seq @defs) 214 | (assoc {(:title base) base} :definitions @defs) 215 | base)) 216 | (walk/postwalk #(cond-> % (map? %) (dissoc :schema-name)) rendered)))) 217 | -------------------------------------------------------------------------------- /src/speculate/ast.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.ast 2 | (:refer-clojure :exclude [alias]) 3 | (:require 4 | [clojure.spec.alpha :as s] 5 | [speculate.util :as util] 6 | [clojure.future :refer :all])) 7 | 8 | (defn alias [spec] 9 | (when-let [s (get (s/registry) spec)] 10 | (when (keyword? s) s))) 11 | 12 | (defn node-value 13 | [{:keys [::name] :as ast}] 14 | (if name 15 | [{:label name 16 | :alias (alias name) 17 | :alias-map (:alias ast)}] 18 | [])) 19 | 20 | (defrecord Walked [value]) 21 | 22 | (defn walked [value] 23 | (->Walked value)) 24 | 25 | (defn walk [f ast] 26 | (let [value (f ast)] 27 | (if (instance? Walked value) 28 | (:value value) 29 | (concat 30 | value 31 | (case (::type ast) 32 | 33 | clojure.spec.alpha/keys 34 | (let [{:keys [req req-un opt opt-un]} (:form ast)] 35 | (mapcat (partial walk f) (concat req req-un opt opt-un))) 36 | 37 | clojure.spec.alpha/every 38 | (walk f (:form ast)) 39 | 40 | clojure.spec.alpha/coll-of 41 | (walk f (:form ast)) 42 | 43 | clojure.spec.alpha/or 44 | (mapcat (comp (partial walk f) val) (:form ast)) 45 | 46 | clojure.spec.alpha/and 47 | (mapcat (partial walk f) (:form ast)) 48 | 49 | speculate.spec/spec 50 | (let [{:keys [::name alias leaf form]} ast] 51 | (cond alias 52 | (f ast) 53 | (not leaf) 54 | (walk f form) 55 | leaf 56 | (f ast))) 57 | 58 | []))))) 59 | 60 | (defn leaves [ast] 61 | (distinct (walk (fn [{:keys [leaf] :as ast}] 62 | (if leaf (node-value ast) [])) 63 | ast))) 64 | 65 | (defn leafset [ast] 66 | (->> ast 67 | (leaves) 68 | (mapcat (juxt (comp ffirst :alias-map) :alias :label)) 69 | (remove nil?) 70 | (set))) 71 | 72 | (defn nodes [ast] 73 | (walk node-value ast)) 74 | 75 | (defn nodeset [ast] 76 | (->> ast 77 | (nodes) 78 | (mapcat (juxt (comp ffirst :alias-map) :alias :label)) 79 | (remove nil?) 80 | (set))) 81 | 82 | (defn shake [keepset {:keys [::name] :as ast}] 83 | (if (and name 84 | (or (contains? keepset name) 85 | (contains? keepset (ffirst (::alias ast))) 86 | (contains? keepset (alias name)))) 87 | ast 88 | (case (::type ast) 89 | clojure.spec.alpha/keys 90 | (let [{:keys [req req-un opt opt-un]} (:form ast) 91 | req (seq (keep (partial shake keepset) req)) 92 | req-un (seq (keep (partial shake keepset) req-un)) 93 | opt (seq (keep (partial shake keepset) opt)) 94 | opt-un (seq (keep (partial shake keepset) opt-un)) 95 | form (cond-> nil 96 | req (assoc :req req) 97 | req-un (assoc :req-un req-un) 98 | opt (assoc :opt opt) 99 | opt-un (assoc :opt-un opt-un))] 100 | (when form 101 | (assoc ast :form form))) 102 | clojure.spec.alpha/or 103 | (some->> (:form ast) 104 | (keep (juxt first (comp (partial shake keepset) second))) 105 | (seq) 106 | (into {}) 107 | (assoc ast :form)) 108 | clojure.spec.alpha/and 109 | (let [spec? #(or (util/spec-symbol? (::type %)) 110 | (s/spec? (::name %)))] 111 | (some->> (:form ast) 112 | (filter spec?) 113 | (keep (partial shake keepset)) 114 | (seq) 115 | (assoc ast :form))) 116 | speculate.spec/spec 117 | (let [{:keys [leaf]} ast] 118 | (some->> ast :form (shake keepset) (assoc ast :form))) 119 | (if (:leaf ast) 120 | (let [name (::name ast)] 121 | (when (or (contains? keepset name) 122 | (contains? keepset (alias name))) 123 | ast)) 124 | (some->> ast :form (shake keepset) (assoc ast :form)))))) 125 | 126 | (defn categorize [form] 127 | (cond (map? form) 128 | `map? 129 | (seq? form) 130 | (first form) 131 | (s/spec? form) 132 | `s/spec? 133 | (var? form) 134 | `var? 135 | (set? form) 136 | `set? 137 | (util/named? form) 138 | `util/named?)) 139 | 140 | (defn search 141 | [pred form] 142 | (let [rpred #(if (pred %) % (search pred %))] 143 | (cond 144 | (list? form) (some rpred form) 145 | (instance? clojure.lang.IMapEntry form) (rpred (val form)) 146 | (seq? form) (some rpred form) 147 | (instance? clojure.lang.IRecord form) 148 | (some rpred form) 149 | (coll? form) (some rpred form)))) 150 | 151 | (defmulti parse categorize) 152 | 153 | (defmethod parse `s/keys [[t & pairs]] 154 | (let [form (apply hash-map pairs)] 155 | {::type t 156 | :form (-> form 157 | (update :req (partial mapv parse)) 158 | (update :req-un (partial mapv parse)) 159 | (update :opt (partial mapv parse)) 160 | (update :opt-un (partial mapv parse)))})) 161 | 162 | (defn kv-form [[t & pairs]] 163 | {::type t 164 | :form (->> pairs 165 | (partition 2) 166 | (map (juxt first (comp parse second))) 167 | (into {}))}) 168 | 169 | (defmethod parse `s/alt [x] (kv-form x)) 170 | (defmethod parse `s/cat [x] (kv-form x)) 171 | (defmethod parse `s/fspec [x] (kv-form x)) 172 | (defmethod parse `s/or [x] (assoc (kv-form x) :spec x)) 173 | 174 | (defn pred-forms [[t & preds]] 175 | {::type t 176 | :form (map parse preds)}) 177 | 178 | (s/def ::nilable-if 179 | (s/and seq? 180 | (s/cat :if #{'if} 181 | :nil? (s/and seq? 182 | (s/cat :nil? #{`nil?} 183 | :gensym symbol?)) 184 | :nil #{[::s/nil nil]} 185 | :pred (s/tuple #{::s/pred} any?)))) 186 | 187 | (s/def ::nilable-conformer 188 | (s/and seq? 189 | (s/cat :conformer #{`s/conformer} 190 | :second #{`second} 191 | :fn* (s/and seq? 192 | (s/cat :fn* #{'fn*} 193 | :vector (s/coll-of symbol? 194 | :max-count 1 195 | :min-count 1 196 | :kind vector?) 197 | :if ::nilable-if))))) 198 | 199 | (s/def ::nilable-form 200 | (s/cat :and #{`s/and} 201 | :or (s/and seq? 202 | (s/cat :or #{`s/or} 203 | :nil #{::s/nil} 204 | :nil? #{`nil?} 205 | :pred #{::s/pred} 206 | :sym any?)) 207 | :conformer ::nilable-conformer)) 208 | 209 | (defn matches-nilable? [x] 210 | (s/valid? ::nilable-form x)) 211 | 212 | (defn nilable-pred [x] 213 | (-> x second (nth 4))) 214 | 215 | (defmethod parse `s/and [x] 216 | (if (matches-nilable? x) 217 | (parse (second x)) 218 | (pred-forms x))) 219 | 220 | (defmethod parse `s/tuple [x] (pred-forms x)) 221 | 222 | (defn pred-opts-form [[t pred & {:as opts}]] 223 | (merge opts 224 | {::type t 225 | :form (parse pred)})) 226 | 227 | (defmethod parse `s/coll-of [x] (pred-opts-form x)) 228 | (defmethod parse `s/every [x] (pred-opts-form x)) 229 | (defmethod parse `s/map-of [x] (pred-opts-form x)) 230 | 231 | (defmethod parse 'speculate.spec/spec [[_ & pairs]] 232 | (let [{:keys [spec form] :as m} (apply hash-map pairs)] 233 | (merge {::type 'speculate.spec/spec} 234 | (when spec {:form (parse spec)}) 235 | (dissoc m :spec :form :alias :categorize :select)))) 236 | 237 | (defmethod parse 'speculate.spec/strict [[_ merged-keys-form]] 238 | (parse merged-keys-form)) 239 | 240 | (defmethod parse `map? [m] 241 | {::type `map? 242 | :form (->> m 243 | (map (juxt key (comp parse val))) 244 | (into {}))}) 245 | 246 | (defn strip-reader-meta [form] 247 | (dissoc form :line :column)) 248 | 249 | (defmethod parse `s/spec? [x] 250 | (let [tree (-> (s/form x) 251 | (parse) 252 | (merge (strip-reader-meta (meta x))))] 253 | (cond-> tree 254 | (instance? clojure.lang.IDeref x) (merge (deref x))))) 255 | 256 | (def complex-type? 257 | (comp '#{clojure.spec.alpha/coll-of 258 | clojure.spec.alpha/every 259 | clojure.spec.alpha/keys 260 | clojure.spec.alpha/tuple 261 | clojure.spec.alpha/map-of} ::type)) 262 | 263 | (defn leaf? 264 | "An AST is not a leaf if any of it's decendents has a ::name" 265 | [ast] 266 | (not (search ::name ast))) 267 | 268 | (defmethod parse `util/named? [x] 269 | (if-let [reg (get (s/registry) x)] 270 | (let [form (parse reg)] 271 | (cond-> (assoc form ::name x) 272 | (leaf? form) (assoc :leaf true))) 273 | (if (symbol? x) 274 | {::type `symbol? :form x} 275 | (throw (Exception. (format "Could not find spec in registry: %s" x)))))) 276 | 277 | (defmethod parse `var? [x] 278 | (when-let [reg (get (s/registry) (util/->sym x))] 279 | (parse reg))) 280 | 281 | (defmethod parse `set? [x] 282 | {::type `set? 283 | :form x}) 284 | 285 | (defmethod parse 'clojure.spec.alpha/conformer [x]) 286 | 287 | (defmethod parse :default [x] 288 | (when x 289 | (if (and (map? x) (::type x)) 290 | x 291 | {:form x}))) 292 | 293 | (defn coll-type? [{:keys [::type]}] 294 | (contains? #{`s/every `s/coll-of} type)) 295 | -------------------------------------------------------------------------------- /src/speculate/spec.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.spec 2 | (:require 3 | [clojure.set :as set] 4 | [clojure.spec.alpha :as s] 5 | [clojure.spec.gen.alpha :as gen] 6 | [clojure.walk :as walk] 7 | [speculate.util :as util])) 8 | 9 | (alias 'c 'clojure.core) 10 | 11 | (defn ->sym 12 | "Returns a symbol from a symbol or var" 13 | [x] 14 | (if (var? x) 15 | (let [^clojure.lang.Var v x] 16 | (symbol (str (.name (.ns v))) 17 | (str (.sym v)))) 18 | x)) 19 | 20 | (defn ->gen [x] 21 | (when x (if (fn? x) x #(-> x)))) 22 | 23 | (defn ->spec [ns x] 24 | (cond (string? x) (keyword ns x) 25 | (keyword? x) (keyword ns (name x)) 26 | :else (throw (Exception. (format "Cannot coerce %s to a spec" 27 | (pr-str x)))))) 28 | (defmacro set-of [pred & opts] 29 | `(s/every ~pred ::conform-all true :kind set? ~@opts)) 30 | 31 | (defn parse-min-max [maximum exclusive-maximum minimum exclusive-minimum] 32 | (cond (and minimum maximum) 33 | (cond (and exclusive-minimum exclusive-maximum) 34 | [(s/and integer? #(> % minimum) #(< % maximum)) 35 | (gen/choose (inc minimum) (dec maximum))] 36 | exclusive-minimum 37 | [(s/and integer? #(> % minimum) #(<= % maximum)) 38 | (gen/choose (inc minimum) maximum)] 39 | exclusive-maximum 40 | [(s/and integer? #(>= % minimum) #(< % maximum)) 41 | (gen/choose minimum (dec maximum))] 42 | :else 43 | [(s/and integer? #(>= % minimum) #(<= % maximum)) 44 | (gen/choose minimum maximum)]) 45 | minimum 46 | (if exclusive-minimum 47 | [(s/and integer? #(> % minimum)) 48 | (gen/choose (inc minimum) Integer/MAX_VALUE)] 49 | [(s/and integer? #(>= % minimum)) 50 | (gen/choose minimum Integer/MAX_VALUE)]) 51 | maximum 52 | (if exclusive-maximum 53 | [(s/and integer? #(< % maximum)) 54 | (gen/choose Integer/MIN_VALUE (dec maximum))] 55 | [(s/and integer? #(<= % maximum)) 56 | (gen/choose Integer/MIN_VALUE maximum)]))) 57 | 58 | (defn build-spec [gen spec tests forms] 59 | (let [c (count tests)] 60 | (cond (and (zero? c) spec) 61 | (s/spec-impl (:spec forms) spec (->gen gen) nil) 62 | spec 63 | (s/and-spec-impl (apply vector (:spec forms) (c/map s/form tests)) 64 | (apply vector spec tests) 65 | (->gen gen)) 66 | (= c 1) 67 | (s/spec-impl (s/form (first tests)) (first tests) (->gen gen) nil) 68 | (> c 1) 69 | (s/and-spec-impl (mapv s/form tests) 70 | (vec tests) 71 | (->gen gen))))) 72 | 73 | (defn parse-spec 74 | "Look at a fixed set of expected params and default them where necessary. 75 | Returns a generate, a plain clojure spec (possibly and and of all the tests), 76 | and all the tests." 77 | [{:keys [maximum exclusive-maximum 78 | minimum exclusive-minimum 79 | multiple-of 80 | max-length 81 | min-length 82 | pattern 83 | max-items min-items 84 | unique-items 85 | max-properties 86 | min-properties 87 | required 88 | spec 89 | gen] :as definition}] 90 | (let [[min-max-test min-max-gen] (parse-min-max maximum exclusive-maximum 91 | minimum exclusive-minimum) 92 | multiple-of-test (when multiple-of 93 | (s/spec #(and (not (zero? %)) 94 | (integer? (/ % multiple-of))))) 95 | max-length-test (when max-length 96 | (s/spec #(<= (count %) max-length))) 97 | min-length-test (when min-length 98 | (s/spec #(>= (count %) min-length))) 99 | pattern-test (when pattern 100 | (s/spec #(re-matches pattern %))) 101 | max-items-test (when max-items 102 | (s/spec #(<= (count %) max-items))) 103 | min-items-test (when min-items 104 | (s/spec #(>= (count %) min-items))) 105 | unique-items-test (when unique-items 106 | (s/spec #(= % (distinct %)))) 107 | tests (remove nil? 108 | [min-max-test multiple-of-test max-length-test 109 | min-length-test pattern-test max-items-test 110 | min-items-test unique-items-test])] 111 | [(or gen min-max-gen) spec tests])) 112 | 113 | (defn postwalk-escape [f escape? form] 114 | (if (escape? form) 115 | form 116 | (walk/walk (partial postwalk-escape f escape?) f form))) 117 | 118 | (defn syntax-quote-symbol [form] 119 | (cond (symbol? form) 120 | (if-let [s (resolve form)] 121 | (list 'quote (->sym s)) 122 | form) 123 | (list? form) 124 | (apply list 'list form) 125 | :default form)) 126 | 127 | (defmacro override [base-spec & impls] 128 | (let [impls-spec (s/cat :spec-overrides (s/* seq?) 129 | :protocol-defs (s/* (s/cat :sym symbol? 130 | :list (s/* list?)))) 131 | impls' (s/conform impls-spec impls) 132 | {:keys [spec-overrides protocol-defs]} impls'] 133 | `(reify 134 | s/Spec 135 | ~@(c/map #(or (get (->> spec-overrides 136 | (c/map (juxt (comp util/res first) identity)) 137 | (into {})) 138 | (first %)) 139 | `(~@%)) 140 | `[(s/conform* [_# x#] (s/conform ~base-spec x#)) 141 | (s/unform* [_# x#] (s/unform ~base-spec x#)) 142 | (s/explain* [_# path# via# in# x#] (s/explain* ~base-spec path# via# in# x#)) 143 | (s/gen* [_# overrides# path# rmap#] (s/gen ~base-spec)) 144 | (s/with-gen* [_# gfn#] (s/with-gen ~base-spec gfn#)) 145 | (s/describe* [_#] (s/describe (s/spec ~base-spec)))]) 146 | ~@(c/mapcat (fn [pdef] 147 | (concat [(:sym pdef)] 148 | (:list pdef))) 149 | protocol-defs)))) 150 | 151 | (defn spec-impl 152 | "Build an object which conforms to the s/Spec protocol, utilising the core 153 | functions." 154 | [gen spec tests categorize select alias form spec-form] 155 | (let [spec' (build-spec gen spec tests form) 156 | dt (partial s/conform spec') 157 | opts (apply concat form)] 158 | (reify 159 | s/Spec 160 | (s/conform* [_ x] (dt x)) 161 | (s/unform* [_ x] 162 | (if spec 163 | (try 164 | (s/unform* spec x) 165 | (catch IllegalArgumentException _ x)) 166 | x)) 167 | (s/explain* [_ path via in x] 168 | (cond (s/spec? spec) 169 | (s/explain* spec path via in x) 170 | (keyword? spec) 171 | (s/explain* ((s/registry) spec) path via in x) 172 | :form 173 | [{:path path :pred (s/abbrev spec-form) :val x :via via :in in}])) 174 | (s/gen* [_ _ _ _] 175 | (if gen (if (fn? gen) (gen) gen) (s/gen spec'))) 176 | (s/with-gen* [_ gfn] (spec-impl gfn spec tests form)) 177 | (s/describe* [_] `(spec ~@opts)) 178 | 179 | clojure.lang.IDeref 180 | (deref [_] {:categorize categorize :select select :alias alias})))) 181 | 182 | (defmacro spec 183 | [& {:keys [spec gen categorize select alias] :as definition}] 184 | `(let [[gen# spec# tests#] (parse-spec ~definition)] 185 | (spec-impl gen# 186 | spec# 187 | tests# 188 | ~categorize 189 | ~select 190 | ~alias 191 | ~(postwalk-escape 192 | syntax-quote-symbol 193 | (fn [form] 194 | (and (seq? form) (= 'fn* (first form)))) 195 | (dissoc definition :alias :categorize :select :gen)) 196 | '~(util/res spec)))) 197 | 198 | (defn strict-impl [keys-spec keys-form form] 199 | (reify 200 | s/Spec 201 | (s/conform* [_ x] (s/conform* keys-spec x)) 202 | (s/unform* [_ x] (s/unform keys-spec x)) 203 | (s/explain* [_ path via in x] 204 | (when-not (s/valid? keys-spec x) 205 | (concat (s/explain* keys-spec path via in x) 206 | [{:path path 207 | :pred (list 'strict-extra-keys 208 | (set/difference (set (keys x)) 209 | (set (map util/un-ns (:req-un keys-form))) 210 | (set (map util/un-ns (:opt-un keys-form))))) 211 | :val x 212 | :via via 213 | :in in}]))) 214 | (s/gen* [_ overrides path rmap] (s/gen* keys-spec overrides path rmap)) 215 | (s/with-gen* [_ gfn] (s/with-gen* keys-spec gfn)) 216 | (s/describe* [_] (list `strict form)))) 217 | 218 | (defmacro strict 219 | "Takes `clojure.spec/keys` forms, and/or ::keywords that resolve to 220 | `clojure.spec.keys` specs. Merges them and wraps them in a \"strictly 221 | only these keys\" context." 222 | [& keys-forms] 223 | (let [{:keys [req req-un opt opt-un] :as keys-form} 224 | (->> keys-forms 225 | (map #(->> (if (keyword? %) (s/form %) %) 226 | (rest) 227 | (apply hash-map))) 228 | (apply merge-with (comp vec concat))) 229 | keys-forms (util/res keys-forms)] 230 | `(strict-impl (s/and (s/keys ~@(apply concat keys-form)) 231 | #(= (set (map util/un-ns ~req-un)) 232 | (set/difference (set (keys %)) 233 | ~(set (map util/un-ns opt-un))))) 234 | ~keys-form 235 | (list `s/keys ~@(apply concat keys-form))))) 236 | -------------------------------------------------------------------------------- /src/speculate/transform/extract.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.transform.extract 2 | (:refer-clojure :exclude [alias *]) 3 | (:require 4 | [clojure.pprint :refer [pprint]] 5 | [clojure.set :as set] 6 | [clojure.spec.alpha :as s] 7 | [clojure.spec.override] 8 | [speculate.ast :as ast] 9 | [speculate.util :as util] 10 | [speculate.transform.state :as state] 11 | [clojure.string :as string])) 12 | 13 | 14 | (defn alias [spec] 15 | (when-let [s (get (s/registry) spec)] 16 | (when (keyword? s) s))) 17 | 18 | (defn un-ns [k] 19 | (keyword (name k))) 20 | 21 | (defn assert-conform! [spec orig-value conformed-value] 22 | (when (= ::s/invalid conformed-value) 23 | (throw (ex-info "Value doesn't conform-to spec" {:spec spec :value orig-value})))) 24 | 25 | (defn leaf-value 26 | [{:keys [categorize coll-indexes pathset] :as state} 27 | {:keys [::ast/name] :as ast} node] 28 | (when-not name 29 | (throw (ex-info "Cannot be a leaf without a name:" 30 | {:type :invalid-leaf 31 | :ast ast 32 | :node node}))) 33 | (let [value (s/conform name node)] 34 | (assert-conform! name node value) 35 | [[{:label name 36 | :value (cond (= value node) 37 | value 38 | (contains? (s/registry) name) 39 | (s/unform name value) 40 | :else 41 | (throw (ex-info (format "Cannot unform: %s" name) 42 | {:type :cannot-unform 43 | :ast ast 44 | :value value 45 | :node node}))) 46 | :pathset pathset 47 | :categorize (cond-> categorize 48 | (contains? categorize name) 49 | (assoc name #{value})) 50 | :coll-indexes coll-indexes}] state])) 51 | 52 | (defmulti -walk (fn [state ast node] (::ast/type ast))) 53 | 54 | (defn walk [state {:keys [leaf] :as ast} node] 55 | (let [parse-name (::ast/name ast) 56 | pull-leaf? (and parse-name 57 | (not leaf) 58 | (contains? (:to-nodeset state) parse-name))] 59 | (let [inc-alias? (contains? (:include state) parse-name) 60 | [included] (when inc-alias? 61 | (or (leaf-value state ast node) 62 | (throw 63 | (Exception. 64 | (format "Extract keys: Value not present for required key: %s" parse-name))))) 65 | [pulled s] (when pull-leaf? 66 | (-> state 67 | (update :pulled (fnil conj #{}) parse-name) 68 | (leaf-value ast node)))] 69 | (if leaf 70 | (leaf-value state ast node) 71 | (-> (-walk (if s s state) ast node) 72 | (state/reset state :categorize) 73 | (cond-> 74 | included (state/update-value concat included) 75 | pulled (state/update-value concat pulled))))))) 76 | 77 | (defmethod -walk 'clojure.spec.alpha/keys 78 | [state ast node] 79 | (let [{:keys [req req-un opt opt-un]} (:form ast) 80 | f (fn [un? req? s {:keys [leaf] :as branch-ast}] 81 | (let [label (::ast/name branch-ast) 82 | k (cond-> label un? un-ns) 83 | s' (-> s 84 | (cond-> (not leaf) 85 | (update :pathset (fnil conj #{}) label)))] 86 | (if (contains? node k) 87 | (let [[result s'' :as value] (walk s' branch-ast (get node k))] 88 | (when (and req? (nil? value)) 89 | (throw 90 | (Exception. 91 | (format "Value not present for required key: %s" label)))) 92 | [result (-> s'' 93 | (assoc :pathset (:pathset s)) 94 | (cond-> (and value (not leaf)) 95 | (update :pathset-union (fnil conj #{}) label)))]) 96 | [nil s]))) 97 | [a s] (state/map state (partial f nil :req) req) 98 | [b t] (state/map state (partial f nil nil) opt) 99 | [c u] (state/map state (partial f :un :req) req-un) 100 | [d v] (state/map state (partial f :un nil) opt-un)] 101 | [(concat a b c d) (util/deep-merge s t u v)])) 102 | 103 | (defn -walk-coll [state ast node] 104 | (let [label (::ast/name ast) 105 | categorize (:categorize ast)] 106 | (state/map-indexed state 107 | (fn [state i x] 108 | (-> (cond-> state 109 | (not categorize) 110 | (assoc-in [:coll-indexes label] i)) 111 | (walk (:form ast) x) 112 | (state/reset state :coll-indexes))) 113 | node))) 114 | 115 | (defmethod -walk 'clojure.spec.alpha/every 116 | [state ast node] 117 | (-walk-coll state ast node)) 118 | 119 | (defmethod -walk 'clojure.spec.alpha/coll-of 120 | [state ast node] 121 | (-walk-coll state ast node)) 122 | 123 | (defn f-or [& fs] 124 | (comp (partial some identity) (apply juxt fs))) 125 | 126 | (defmethod -walk 'clojure.spec.alpha/and 127 | [state ast node] 128 | (let [specs (filter (f-or (comp s/spec? ::ast/name) 129 | (comp util/spec-symbol? ::ast/type)) 130 | (:form ast))] 131 | (walk state (first specs) node))) 132 | 133 | (defmethod -walk 'clojure.spec.alpha/or 134 | [state ast node] 135 | (let [label (::ast/name ast) 136 | spec (or label (eval (:spec ast))) 137 | conformed (s/conform spec node) 138 | _ (assert-conform! label node conformed) 139 | [or-key _] conformed 140 | form (get (:form ast) or-key)] 141 | (if (contains? '#{clojure.spec.alpha/pred clojure.spec.alpha/nil} or-key) 142 | (walk form node) 143 | (-> state 144 | (update :categorize assoc or-key #{or-key}) 145 | (update :categories (fnil conj #{}) or-key) 146 | (update :categorized (partial merge-with set/union) {or-key #{or-key}}) 147 | (walk form node))))) 148 | 149 | (defn state-fn? [f] 150 | (-> f meta :name (= 'state-fn))) 151 | 152 | (defn key-cat? [[k cat-f]] 153 | (if (= cat-f keys) :key-cat :set-cat)) 154 | 155 | (defn include-cat-vals [state set-cats] 156 | (mapcat (fn [[k vs]] 157 | (->> vs 158 | (mapcat #(when (contains? (s/registry) k) 159 | (-> state 160 | (leaf-value (ast/parse k) %) 161 | (first)))) 162 | (remove nil?))) 163 | set-cats)) 164 | 165 | (defn assert-all-valid! [spec orig-coll conformed-coll] 166 | (assert 167 | (not-any? #{::s/invalid} conformed-coll) 168 | (format "Categorization must be valid %s %s" spec (pr-str orig-coll)))) 169 | 170 | (defn category-set-map [state set-cat node] 171 | (->> set-cat 172 | (map (fn [[k cat-f]] 173 | (let [cat-set (if (state-fn? cat-f) 174 | (cat-f state node) 175 | (cat-f node)) 176 | _ (when (and (not (nil? cat-set)) (empty? cat-set)) 177 | (throw 178 | (ex-info 179 | (format "Categorization for %s returned no categories" k) 180 | {:type :invalid-categorization}))) 181 | cat-set' (some->> cat-set 182 | (map #(cond->> % 183 | (or (s/spec? k) 184 | (contains? (s/registry) k)) 185 | (s/conform k))) 186 | (seq) 187 | (set))] 188 | (assert-all-valid! k cat-set cat-set') 189 | [k cat-set']))) 190 | (into {}))) 191 | 192 | (defn include-not-present [coll-a coll-b] 193 | (concat coll-a (->> (map :label coll-a) 194 | (apply dissoc (group-by :label coll-b)) 195 | (vals) 196 | (apply concat)))) 197 | 198 | (defn categorize-map [state {:keys [categorize]} form node] 199 | (let [{:keys [key-cat set-cat]} (group-by key-cat? categorize) 200 | set-cats (category-set-map state set-cat node) 201 | state' (-> state 202 | (update :categorize merge set-cats) 203 | (update :categorized (partial merge-with set/union) set-cats) 204 | (update :categories set/union (set (keys categorize)))) 205 | form' (assoc form :categorize categorize)] 206 | (-> (if key-cat 207 | (let [[k f] (first key-cat)] 208 | (state/map state' 209 | (fn [s k-cat] 210 | (let [k-cat' #{(s/conform k k-cat)} 211 | _ (assert-all-valid! k #{k-cat} k-cat') 212 | s' (-> s 213 | (update :categorize assoc k k-cat') 214 | (update :categorized update k set/union k-cat'))] 215 | (-> s' 216 | (walk form' {k-cat (k-cat node)}) 217 | (state/update-value conj (ffirst (leaf-value s' (ast/parse k) k-cat)))))) 218 | (f node))) 219 | (walk state' form' node)) 220 | (state/update-value include-not-present 221 | (include-cat-vals state' set-cats))))) 222 | 223 | (defn categorize-coll [state ast form nodes] 224 | (state/map state #(categorize-map %1 ast (:form form) %2) nodes)) 225 | 226 | (defmethod -walk 'speculate.spec/spec 227 | [state ast node] 228 | (let [{:keys [::ast/name alias leaf form select]} ast 229 | state' (cond-> state alias (update :alias assoc name alias))] 230 | (-> (cond (:categorize ast) 231 | (try 232 | (condp = (::ast/type form) 233 | 'clojure.spec.alpha/keys (categorize-map state' ast form node) 234 | 'clojure.spec.alpha/coll-of (categorize-coll state' ast form node) 235 | 'clojure.spec.alpha/every (categorize-coll state' ast form node) 236 | (categorize-map state' ast form node)) 237 | (catch clojure.lang.ExceptionInfo e 238 | (if (= :invalid-categorization (:type (ex-data e))) 239 | [[]] 240 | (throw e)))) 241 | 242 | select 243 | (walk state' form node) 244 | 245 | (not leaf) 246 | (walk state' form node) 247 | 248 | leaf 249 | (leaf-value state ast node)) 250 | (state/update-state (fn [{:keys [categories categorized pathset-union pulled]}] 251 | (assoc state 252 | :pulled pulled 253 | :pathset-union pathset-union 254 | :categories categories 255 | :categorized categorized)))))) 256 | 257 | (defmethod -walk :default 258 | [state ast node] 259 | (leaf-value state ast node)) 260 | 261 | (defn run-walk [spec node include to-nodeset] 262 | (walk {:include include :to-nodeset to-nodeset} spec node)) 263 | 264 | (defn eval-walk [spec node] 265 | (first (run-walk spec node))) 266 | 267 | (defn exec-walk [spec node] 268 | (second (run-walk spec node))) 269 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 2 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 3 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 4 | 5 | 1. DEFINITIONS 6 | 7 | "Contribution" means: 8 | 9 | a) in the case of the initial Contributor, the initial code and 10 | documentation distributed under this Agreement, and 11 | 12 | b) in the case of each subsequent Contributor: 13 | 14 | i) changes to the Program, and 15 | 16 | ii) additions to the Program; 17 | 18 | where such changes and/or additions to the Program originate from and are 19 | distributed by that particular Contributor. A Contribution 'originates' from 20 | a Contributor if it was added to the Program by such Contributor itself or 21 | anyone acting on such Contributor's behalf. Contributions do not include 22 | additions to the Program which: (i) are separate modules of software 23 | distributed in conjunction with the Program under their own license 24 | agreement, and (ii) are not derivative works of the Program. 25 | 26 | "Contributor" means any person or entity that distributes the Program. 27 | 28 | "Licensed Patents" mean patent claims licensable by a Contributor which are 29 | necessarily infringed by the use or sale of its Contribution alone or when 30 | combined with the Program. 31 | 32 | "Program" means the Contributions distributed in accordance with this 33 | Agreement. 34 | 35 | "Recipient" means anyone who receives the Program under this Agreement, 36 | including all Contributors. 37 | 38 | 2. GRANT OF RIGHTS 39 | 40 | a) Subject to the terms of this Agreement, each Contributor hereby grants 41 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 42 | reproduce, prepare derivative works of, publicly display, publicly perform, 43 | distribute and sublicense the Contribution of such Contributor, if any, and 44 | such derivative works, in source code and object code form. 45 | 46 | b) Subject to the terms of this Agreement, each Contributor hereby grants 47 | Recipient a non-exclusive, worldwide, royalty-free patent license under 48 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 49 | transfer the Contribution of such Contributor, if any, in source code and 50 | object code form. This patent license shall apply to the combination of the 51 | Contribution and the Program if, at the time the Contribution is added by the 52 | Contributor, such addition of the Contribution causes such combination to be 53 | covered by the Licensed Patents. The patent license shall not apply to any 54 | other combinations which include the Contribution. No hardware per se is 55 | licensed hereunder. 56 | 57 | c) Recipient understands that although each Contributor grants the licenses 58 | to its Contributions set forth herein, no assurances are provided by any 59 | Contributor that the Program does not infringe the patent or other 60 | intellectual property rights of any other entity. Each Contributor disclaims 61 | any liability to Recipient for claims brought by any other entity based on 62 | infringement of intellectual property rights or otherwise. As a condition to 63 | exercising the rights and licenses granted hereunder, each Recipient hereby 64 | assumes sole responsibility to secure any other intellectual property rights 65 | needed, if any. For example, if a third party patent license is required to 66 | allow Recipient to distribute the Program, it is Recipient's responsibility 67 | to acquire that license before distributing the Program. 68 | 69 | d) Each Contributor represents that to its knowledge it has sufficient 70 | copyright rights in its Contribution, if any, to grant the copyright license 71 | set forth in this Agreement. 72 | 73 | 3. REQUIREMENTS 74 | 75 | A Contributor may choose to distribute the Program in object code form under 76 | its own license agreement, provided that: 77 | 78 | a) it complies with the terms and conditions of this Agreement; and 79 | 80 | b) its license agreement: 81 | 82 | i) effectively disclaims on behalf of all Contributors all warranties and 83 | conditions, express and implied, including warranties or conditions of title 84 | and non-infringement, and implied warranties or conditions of merchantability 85 | and fitness for a particular purpose; 86 | 87 | ii) effectively excludes on behalf of all Contributors all liability for 88 | damages, including direct, indirect, special, incidental and consequential 89 | damages, such as lost profits; 90 | 91 | iii) states that any provisions which differ from this Agreement are offered 92 | by that Contributor alone and not by any other party; and 93 | 94 | iv) states that source code for the Program is available from such 95 | Contributor, and informs licensees how to obtain it in a reasonable manner on 96 | or through a medium customarily used for software exchange. 97 | 98 | When the Program is made available in source code form: 99 | 100 | a) it must be made available under this Agreement; and 101 | 102 | b) a copy of this Agreement must be included with each copy of the Program. 103 | 104 | Contributors may not remove or alter any copyright notices contained within 105 | the Program. 106 | 107 | Each Contributor must identify itself as the originator of its Contribution, 108 | if any, in a manner that reasonably allows subsequent Recipients to identify 109 | the originator of the Contribution. 110 | 111 | 4. COMMERCIAL DISTRIBUTION 112 | 113 | Commercial distributors of software may accept certain responsibilities with 114 | respect to end users, business partners and the like. While this license is 115 | intended to facilitate the commercial use of the Program, the Contributor who 116 | includes the Program in a commercial product offering should do so in a 117 | manner which does not create potential liability for other Contributors. 118 | Therefore, if a Contributor includes the Program in a commercial product 119 | offering, such Contributor ("Commercial Contributor") hereby agrees to defend 120 | and indemnify every other Contributor ("Indemnified Contributor") against any 121 | losses, damages and costs (collectively "Losses") arising from claims, 122 | lawsuits and other legal actions brought by a third party against the 123 | Indemnified Contributor to the extent caused by the acts or omissions of such 124 | Commercial Contributor in connection with its distribution of the Program in 125 | a commercial product offering. The obligations in this section do not apply 126 | to any claims or Losses relating to any actual or alleged intellectual 127 | property infringement. In order to qualify, an Indemnified Contributor must: 128 | a) promptly notify the Commercial Contributor in writing of such claim, and 129 | b) allow the Commercial Contributor tocontrol, and cooperate with the 130 | Commercial Contributor in, the defense and any related settlement 131 | negotiations. The Indemnified Contributor may participate in any such claim 132 | at its own expense. 133 | 134 | For example, a Contributor might include the Program in a commercial product 135 | offering, Product X. That Contributor is then a Commercial Contributor. If 136 | that Commercial Contributor then makes performance claims, or offers 137 | warranties related to Product X, those performance claims and warranties are 138 | such Commercial Contributor's responsibility alone. Under this section, the 139 | Commercial Contributor would have to defend claims against the other 140 | Contributors related to those performance claims and warranties, and if a 141 | court requires any other Contributor to pay any damages as a result, the 142 | Commercial Contributor must pay those damages. 143 | 144 | 5. NO WARRANTY 145 | 146 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON 147 | AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER 148 | EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR 149 | CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A 150 | PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the 151 | appropriateness of using and distributing the Program and assumes all risks 152 | associated with its exercise of rights under this Agreement , including but 153 | not limited to the risks and costs of program errors, compliance with 154 | applicable laws, damage to or loss of data, programs or equipment, and 155 | unavailability or interruption of operations. 156 | 157 | 6. DISCLAIMER OF LIABILITY 158 | 159 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 160 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 161 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 162 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 163 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 164 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 165 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 166 | OF SUCH DAMAGES. 167 | 168 | 7. GENERAL 169 | 170 | If any provision of this Agreement is invalid or unenforceable under 171 | applicable law, it shall not affect the validity or enforceability of the 172 | remainder of the terms of this Agreement, and without further action by the 173 | parties hereto, such provision shall be reformed to the minimum extent 174 | necessary to make such provision valid and enforceable. 175 | 176 | If Recipient institutes patent litigation against any entity (including a 177 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 178 | (excluding combinations of the Program with other software or hardware) 179 | infringes such Recipient's patent(s), then such Recipient's rights granted 180 | under Section 2(b) shall terminate as of the date such litigation is filed. 181 | 182 | All Recipient's rights under this Agreement shall terminate if it fails to 183 | comply with any of the material terms or conditions of this Agreement and 184 | does not cure such failure in a reasonable period of time after becoming 185 | aware of such noncompliance. If all Recipient's rights under this Agreement 186 | terminate, Recipient agrees to cease use and distribution of the Program as 187 | soon as reasonably practicable. However, Recipient's obligations under this 188 | Agreement and any licenses granted by Recipient relating to the Program shall 189 | continue and survive. 190 | 191 | Everyone is permitted to copy and distribute copies of this Agreement, but in 192 | order to avoid inconsistency the Agreement is copyrighted and may only be 193 | modified in the following manner. The Agreement Steward reserves the right to 194 | publish new versions (including revisions) of this Agreement from time to 195 | time. No one other than the Agreement Steward has the right to modify this 196 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 197 | Eclipse Foundation may assign the responsibility to serve as the Agreement 198 | Steward to a suitable separate entity. Each new version of the Agreement will 199 | be given a distinguishing version number. The Program (including 200 | Contributions) may always be distributed subject to the version of the 201 | Agreement under which it was received. In addition, after a new version of 202 | the Agreement is published, Contributor may elect to distribute the Program 203 | (including its Contributions) under the new version. Except as expressly 204 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 205 | licenses to the intellectual property of any Contributor under this 206 | Agreement, whether expressly, by implication, estoppel or otherwise. All 207 | rights in the Program not expressly granted under this Agreement are 208 | reserved. 209 | 210 | This Agreement is governed by the laws of the State of New York and the 211 | intellectual property laws of the United States of America. No party to this 212 | Agreement will bring a legal action under this Agreement more than one year 213 | after the cause of action arose. Each party waives its rights to a jury trial 214 | in any resulting litigation. 215 | -------------------------------------------------------------------------------- /src/speculate/transform/combine.clj: -------------------------------------------------------------------------------- 1 | (ns speculate.transform.combine 2 | (:require 3 | [clojure.pprint :refer [pprint]] 4 | [clojure.set :as set] 5 | [clojure.spec.alpha :as s] 6 | [speculate.ast :as ast] 7 | [speculate.transform.maybe :as maybe] 8 | [speculate.util :as util] 9 | [clojure.future :refer :all])) 10 | 11 | (defn assert-conform! [spec value] 12 | (when-not (s/valid? spec value) 13 | (throw 14 | (ex-info "Value doesn't conform-to spec" {:spec spec :value value}))) 15 | value) 16 | 17 | (defn or-coerce [spec k] 18 | (let [k' (s/conform spec k)] 19 | (when-not (= ::s/invalid k') k'))) 20 | 21 | (defn f-or [& fs] 22 | (comp (partial some identity) (apply juxt fs))) 23 | 24 | (defn unwrap [spec value] 25 | (cond (nil? value) 26 | maybe/Nothing 27 | (map? value) 28 | (:value value) 29 | (sequential? value) 30 | (let [[v :as vs] (map :value value)] 31 | (cond (s/valid? spec vs) 32 | vs 33 | (s/valid? spec v) 34 | v 35 | :else 36 | (throw (ex-info "Leaf value did not match spec" 37 | {:label spec :value value})))))) 38 | 39 | (defn get-by [value-index & ks] 40 | (some (fn [{:keys [label] :as value}] 41 | (when (contains? (set (remove nil? ks)) label) value)) 42 | value-index)) 43 | 44 | (defn combine-leaf-value 45 | [value-index {:keys [::ast/name] :as ast}] 46 | (if-let [[[k txfn]] (seq (:alias ast))] 47 | (if-let [v (get-by value-index k)] 48 | (txfn (unwrap k v)) 49 | maybe/Nothing) 50 | (if-let [v (get-by value-index name (ast/alias name))] 51 | (unwrap name v) 52 | maybe/Nothing))) 53 | 54 | (def -combine nil) 55 | (defmulti -combine (fn [value-index _ ast] (::ast/type ast))) 56 | 57 | (defn combine [value-index index-meta ast] 58 | (cond (or (:alias ast) (:leaf ast)) 59 | (maybe/or (combine-leaf-value value-index ast) 60 | (-combine value-index index-meta ast)) 61 | (contains? (:pulled index-meta) (::ast/name ast)) 62 | (combine-leaf-value value-index ast) 63 | :default 64 | (-combine value-index index-meta ast))) 65 | 66 | (defn filter-when [cond pred coll] 67 | (cond->> coll cond (filter pred))) 68 | 69 | (defn get-category-value [value-index name] 70 | (let [maybe-val (some->> value-index 71 | (some (comp name :categorize)) 72 | first)] 73 | (when-not (= name maybe-val) maybe-val))) 74 | 75 | (defn restrict-to-path-category 76 | [{:keys [pathset-union from-nodeset]} name value-index] 77 | (cond (and (contains? pathset-union name) 78 | (contains? from-nodeset name)) 79 | (->> value-index 80 | (filter (fn [{:keys [pathset]}] 81 | (contains? pathset name))) 82 | (seq)) 83 | (contains? from-nodeset name) 84 | (->> value-index 85 | (filter (fn [{:keys [pathset]}] 86 | (contains? pathset name))) 87 | (seq)) 88 | ;; nil 89 | :else 90 | value-index)) 91 | 92 | (defn build-kv-fn 93 | [value-index {:keys [categorized] :as index-meta}] 94 | (fn [construct req? empty {:keys [::ast/name leaf] :as form}] 95 | (if-let [category-value (get-category-value value-index name)] 96 | (construct name category-value) 97 | (let [value-index' (if leaf 98 | value-index 99 | (restrict-to-path-category index-meta name value-index)) 100 | value (combine value-index' index-meta form) 101 | value (cond (maybe/nothing? value) 102 | maybe/Nothing 103 | (and (= :opt req?) 104 | ('#{clojure.spec.alpha/coll-of 105 | clojure.spec.alpha/every} (::ast/type form)) 106 | (empty? value)) 107 | maybe/Nothing 108 | :else value)] 109 | (if (maybe/nothing? value) 110 | (if (and leaf req?) 111 | (construct name nil) 112 | (empty name)) 113 | (->> value 114 | (assert-conform! name) 115 | (construct name))))))) 116 | 117 | (defmethod -combine 'clojure.spec.alpha/keys 118 | [value-index index-meta {:keys [keys?] :as ast}] 119 | (let [{:keys [req req-un opt opt-un]} (:form ast) 120 | keys?-pred (some-> value-index first :categorize (get keys?)) 121 | pred (comp keys?-pred ::ast/name) 122 | un-pred (comp keys?-pred 123 | (f-or (partial or-coerce keys?) util/un-ns) 124 | ::ast/name) 125 | construct vector 126 | unstruct (fn [name value] [(util/un-ns name) value]) 127 | opt-empty (constantly maybe/Nothing) 128 | req-empty (constantly maybe/Nothing) 129 | build-kv (build-kv-fn value-index index-meta)] 130 | (maybe/some->> 131 | (concat (->> req 132 | (filter-when keys?-pred pred) 133 | (maybe/keep (partial build-kv construct :req req-empty))) 134 | (->> opt 135 | (filter-when keys?-pred pred) 136 | (maybe/keep (partial build-kv construct :opt opt-empty))) 137 | (->> req-un 138 | (filter-when keys?-pred un-pred) 139 | (maybe/keep (partial build-kv unstruct :req req-empty))) 140 | (->> opt-un 141 | (filter-when keys?-pred un-pred) 142 | (maybe/keep (partial build-kv unstruct :opt opt-empty)))) 143 | (maybe/seq) 144 | (into {})))) 145 | 146 | (defn val-sets [m] 147 | (->> m (map (fn [[k v]] [k #{v}])) (into {}))) 148 | 149 | (def cartesian-product (memoize util/kvs-cartesian-product)) 150 | 151 | (defn expand-value-index [categorized] 152 | (mapcat (fn [{:keys [categorize] :as v}] 153 | (->> categorize 154 | (merge categorized) 155 | (cartesian-product) 156 | (map #(assoc v :categorize %)))))) 157 | 158 | (defn restrict-keys 159 | "Like select-keys where all keys are a map, ignores keys not present" 160 | [m keyseq] 161 | (let [pred (fn [map-key] 162 | (some (fn [seq-key] 163 | (= map-key (select-keys seq-key (keys map-key)))) 164 | keyseq))] 165 | (->> m (filter (comp pred key)) (into {})))) 166 | 167 | (defn merge-into-set [a b] 168 | (reduce (fn [init [k v]] 169 | (update init k (fnil conj #{}) (k b))) 170 | a b)) 171 | 172 | (defn compress [value-index] 173 | (->> value-index 174 | (group-by #(dissoc % :categorize :pathset)) 175 | (map (fn [[k vs]] 176 | (assoc k 177 | :categorize (->> vs 178 | (map :categorize) 179 | (reduce merge-into-set {})) 180 | :pathset (->> vs (map :pathset) (reduce set/union))))))) 181 | 182 | (defn categorize [categorized categorize value-index] 183 | (let [keys-to-expand (keys categorize) 184 | minimal-categorized (select-keys categorized keys-to-expand) 185 | expanded-categorized (cartesian-product categorized) 186 | expand-nil-to-all (partial merge-with #(or %2 %1) minimal-categorized) 187 | expand-xform (comp (map #(update % :categorize expand-nil-to-all)) 188 | (expand-value-index categorized)) 189 | group (memoize #(select-keys % keys-to-expand))] 190 | (->> value-index 191 | (sequence expand-xform) 192 | (group-by (comp group :categorize)) 193 | (#(restrict-keys % expanded-categorized)) 194 | (vals) 195 | (map (comp #(with-meta % {:categorized (:categorize (first %))}) 196 | compress))))) 197 | 198 | (def leaf? 199 | (memoize 200 | (fn [ast] 201 | (->> (ast/leaves ast) 202 | (mapcat (juxt :label :alias (comp ffirst :alias-map))) 203 | (remove nil?) 204 | (set))))) 205 | 206 | (defn only-leaves [ast value-index] 207 | (filter (comp (leaf? ast) :label) value-index)) 208 | 209 | (defn coll-combine [value-index index-meta ast] 210 | (let [spec (::ast/name ast) 211 | form (:form ast) 212 | coll-index-f #(get-in % [:coll-indexes spec]) 213 | apply-to-all (remove coll-index-f value-index) 214 | indexed (->> value-index 215 | (filter coll-index-f) 216 | (group-by coll-index-f) 217 | (sort-by key) 218 | (vals)) 219 | coll-into (condp = (::s/kind-form ast) 220 | 'clojure.core/set? #{} 221 | 'clojure.core/list? (list) 222 | [])] 223 | (if (seq indexed) 224 | (maybe/some->> indexed 225 | (map (partial concat apply-to-all)) 226 | (maybe/keep #(combine % index-meta form)) 227 | (maybe/seq) 228 | (into coll-into)) 229 | (if-let [cat? (:categorize form)] 230 | (maybe/some->> value-index 231 | (categorize (:categorized index-meta) cat?) 232 | (maybe/keep #(combine % index-meta (:form ast))) 233 | (into coll-into)) 234 | (maybe/some->> value-index 235 | (only-leaves ast) 236 | (group-by :coll-indexes) 237 | (vals) 238 | (maybe/keep #(combine % index-meta (:form ast))) 239 | (into coll-into)))))) 240 | 241 | (defmethod -combine 'clojure.spec.alpha/every 242 | [value-index index-meta ast] 243 | (coll-combine value-index index-meta ast)) 244 | 245 | (defmethod -combine 'clojure.spec.alpha/coll-of 246 | [value-index index-meta ast] 247 | (coll-combine value-index index-meta ast)) 248 | 249 | (defmethod -combine 'clojure.spec.alpha/and 250 | [value-index index-meta ast] 251 | (->> (:form ast) 252 | (filter (f-or (comp s/spec? ::ast/name) 253 | (comp util/spec-symbol? ::ast/type))) 254 | (maybe/some (fn [v] 255 | (let [v' (combine value-index index-meta v)] 256 | (if (s/valid? (::ast/name ast) v') 257 | v' 258 | maybe/Nothing)))))) 259 | 260 | (defmethod -combine 'clojure.spec.alpha/or 261 | [value-index index-meta {:keys [form] :as ast}] 262 | (let [ks (set (keys form))] 263 | (maybe/some (fn [[k v]] 264 | (let [value-index' (remove (fn [{:keys [categorize] :as value}] 265 | (seq (select-keys categorize 266 | (disj ks k)))) 267 | value-index) 268 | v' (combine value-index' index-meta v)] 269 | (if (s/valid? (::ast/name ast) v') 270 | v' 271 | maybe/Nothing))) 272 | form))) 273 | 274 | (defn select [{:keys [categorized]} select value-index] 275 | (let [categorized (or (-> value-index meta :categorized) categorized) 276 | f (->> select 277 | (map (fn [[k f]] 278 | (cond (fn? f) f 279 | (set? f) (comp f k :categorize)))) 280 | (apply juxt) 281 | (comp (partial every? some?))) 282 | xform (comp (expand-value-index categorized) 283 | (filter f)) 284 | filtered (sequence xform value-index)] 285 | (with-meta (compress filtered) 286 | {:categorized (merge categorized 287 | (-> (first filtered) 288 | (:categorize) 289 | (select-keys (keys select)) 290 | (val-sets)))}))) 291 | 292 | (defn key-cat? [[k cat-f]] 293 | (if (= cat-f keys) :key-cat :set-cat)) 294 | 295 | (defn valmerge [a b] 296 | (condp (fn [f [a b]] (and (f a) (f b))) [a b] 297 | map? (merge-with valmerge a b) 298 | seq? (distinct (concat a b)) 299 | set? (set/union a b) 300 | b)) 301 | 302 | (defn categorize-value-index [categorized categorize? select? value-index] 303 | (if categorize? 304 | (cond->> (categorize categorized categorize? value-index) 305 | select? 306 | (map #(select categorized select? %))) 307 | (cond->> value-index 308 | select? 309 | (select categorized select?)))) 310 | 311 | (defmethod -combine 'speculate.spec/spec 312 | [value-index {:keys [categorized] :as index-meta} ast] 313 | (let [{:keys [alias form leaf]} ast 314 | categorize? (:categorize ast) 315 | {[key-cat] :key-cat} (group-by key-cat? categorize?) 316 | form-type (condp = (::ast/type form) 317 | 'clojure.spec.alpha/keys :map 318 | 'clojure.spec.alpha/coll-of :coll 319 | 'clojure.spec.alpha/every :coll 320 | :other) 321 | value-index' (->> value-index 322 | (categorize-value-index categorized 323 | categorize? 324 | (:select ast))) 325 | cat-fn (fn [x] (assoc index-meta 326 | :categorized (or (-> x meta :categorized) 327 | categorized)))] 328 | (cond (empty? value-index') 329 | maybe/Nothing 330 | :default 331 | (if categorize? 332 | (if (= form-type :map) 333 | (if key-cat 334 | (let [[k v] key-cat] 335 | (maybe/some->> value-index' 336 | (maybe/keep #(combine % (cat-fn %) (assoc form :keys? k))) 337 | (maybe/seq) 338 | (reduce merge {}))) 339 | (maybe/some->> value-index' 340 | (maybe/keep #(combine % (cat-fn %) form)) 341 | (maybe/seq) 342 | (reduce valmerge))) 343 | (maybe/some->> value-index' 344 | (maybe/keep #(combine % (cat-fn %) form)) 345 | (maybe/seq))) 346 | (combine value-index' (cat-fn value-index') form))))) 347 | 348 | (defmethod -combine :default 349 | [value-index _ ast] 350 | (combine-leaf-value value-index ast)) 351 | --------------------------------------------------------------------------------