variants in schema extensions

schema_extensions.clj

(ns schema-client.schema-extensions
  "Schemas representing abstract classes and subclasses"
  (:use plumbing.core)
  (:require
   [clojure.string :as str]
   [plumbing.map :as map]
   [schema.core :as s]
   [schema.utils :as utils]
   [schema.macros :as sm]))

(set! *warn-on-reflection* true)

(defprotocol PExtensibleSchema
  (extend-schema! [this extension schcema-name dispatch-values]))

(defrecord SchemaExtension [schema-name base-schema extended-schema explain-value]
  schema.core.Schema
  (walker [this]
    (s/subschema-walker extended-schema))
  (explain [this]
    (list 'extend-schema
          schema-name
          (s/schema-name base-schema)
          (s/explain explain-value))))

(defn schema-extention [base-schema extended-schema schema-name explain-value]
  (s/schema-with-name
   (SchemaExtension. schema-name base-schema extended-schema explain-value)
   (name schema-name)))

(defmacro extend-schema [schema-name extensible-schema dispatch-values extension]
  `(def ~schema-name
     (extend-schema! ~extensible-schema ~extension '~schema-name ~dispatch-values)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Abstract Map

(defrecord AbstractSchema [sub-schemas dispatch-key schema]
  schema.core.Schema
  (walker [this]
    (let [dispatch-value-walker (s/subschema-walker (apply s/enum (keys @sub-schemas)))
          subschema-walkers (map-vals s/subschema-walker @sub-schemas)]
      (fn [x]
        (if-let [dispatch-value (get x dispatch-key)]
          (let [walked-value (dispatch-value-walker dispatch-value)]
            (if (utils/error? walked-value)
              walked-value
              (if-let [subschema-walker (get subschema-walkers walked-value)]
                (subschema-walker x)
                (sm/validation-error this x (list (set (keys subschema-walkers)) walked-value)))))
          (sm/validation-error this x (list 'contains? (utils/value-name x) dispatch-key))))))
  (explain [this]
    (list 'abstract-map-schema dispatch-key (s/explain schema) (set (keys @sub-schemas))))

  PExtensibleSchema
  (extend-schema! [this extension schema-name dispatch-values]
    (let [sub-schema (assoc (map/merge-disjoint schema extension)
                       dispatch-key (apply s/enum dispatch-values))
          ext-schema (schema-extention this sub-schema schema-name extension)]
      (swap! sub-schemas map/merge-disjoint (map-from-keys (constantly ext-schema) dispatch-values))
      ext-schema)))

(defn sub-schemas [abstract-schema]
  @(.sub-schemas ^AbstractSchema abstract-schema))

(s/defn abstract-map-schema
  [dispatch-key :- clojure.lang.Keyword schema :- clojure.lang.APersistentMap]
  (AbstractSchema. (atom {}) dispatch-key schema))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Variants

(defrecord VariantSchema [variants]
  schema.core.Schema
  (walker [this]
    (let [dispatch-value-walker (s/subschema-walker (apply s/enum (keys @variants)))
          variant-walkers (map-vals s/subschema-walker @variants)]
      (fn [x]
        (if-let [dispatch-value (first x)]
          (if-let [variant-walker (get variant-walkers dispatch-value)]
            (variant-walker x)
            (sm/validation-error this x (list (set (keys variant-walkers))) "Unknown variant"))
          (sm/validation-error this x (list 'seq (utils/value-name x)))))))
  (explain [this]
    (list 'variant-schema))

  PExtensibleSchema
  (extend-schema! [this extension schema-name dispatch-values]
    (let [sub-schema (s/pair (apply s/enum dispatch-values) 'dispatch-values
                             extension 'variant)
          ext-schema (schema-extention this sub-schema schema-name extension)]
      (swap! variants map/merge-disjoint (map-from-keys (constantly ext-schema) dispatch-values))
      ext-schema)))

(defn variant-schema []
  (VariantSchema. (atom {})))

(set! *warn-on-reflection* false)

schema_extensions_test.clj

(ns schema-client.schema-extensions-test
  (:use clojure.test
        plumbing.core
        plumbing.test
        schema-client.schema-extensions)
  (:require
   [schema.core :as s]
   [schema.coerce :as coerce]
   [schema.test :as st]))

;; Helpers from schema.test-macros
(defmacro valid!
  "Assert that x satisfies schema s"
  [s x]
  `(~'is (not (s/check ~s ~x))))

(defmacro invalid!
  "Assert that x does not satisfy schema s, optionally checking the stringified return value"
  ([s x]
     `(~'is (s/check ~s ~x)))
  ([s x expected]
     `(do (invalid! ~s ~x)
          (when *clojure-version* ;; not in cljs
            (~'is (= ~expected (pr-str (s/check ~s ~x))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(s/defschema Animal
  (abstract-map-schema
   :type
   {:age Number
    :vegan? Boolean}))

(extend-schema Cat Animal [:cat] {:fav-catnip String})

(st/deftest extend-schema-test
  (valid! Cat {:age 3 :vegan? false :fav-catnip "cosmic" :type :cat})
  (invalid! Cat {:age 3 :vegan? false :fav-catnip "cosmic" :type :cat :foobar false})

  (valid! Animal {:age 3 :vegan? false :fav-catnip "cosmic" :type :cat})
  (invalid! Animal {:age 3 :vegan? false :type :cat}
            "{:fav-catnip missing-required-key}")
  (invalid! Animal {:age 3 :vegan? false :fav-catnip "cosmic" :type :dog}
            "(not (#{:cat} :dog))"))

(def email-pattern ;; android.util.Patterns.EMAIL
  (re-pattern
   (str "[a-zA-Z0-9\\+\\.\\_\\%\\-\\+]{1,256}"
        "\\@"
        "[a-zA-Z0-9][a-zA-Z0-9\\-]{0,64}"
        "("
        "\\."
        "[a-zA-Z0-9][a-zA-Z0-9\\-]{0,25}"
        ")+")))

(s/defschema Email (s/pred #(re-find email-pattern %)))

(s/defschema Order (variant-schema))
(extend-schema DeliveryOrder Order [:delivery] s/Str)
(extend-schema EmailOrder Order [:email] Email)
(extend-schema LocalStoreOrder Order [:local] s/Int)

(deftest variant-schema-test
  (doseq [[schema order]
          [[DeliveryOrder   [:delivery "123 Clojure Conj Circle"]]
           [EmailOrder      [:email "me@example.com"]]
           [LocalStoreOrder [:local 123]]]]
    (valid! Order order)
    (valid! schema order))
  (doseq [order [[:unknown-variant "123 Clojure Conj Circle"]
                 [:email nil]
                 [:email "bad-email"]
                 [:local 3.14]
                 [:local]]]
    (invalid! Order order)))