extend_schema_test.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]))

(defprotocol PAbstractSchema
  (restricted-schema [this]
    "Returns the abstract schema plus restrictions from child schemas on dispatch key"))

;; Abstract class
(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))))

  PAbstractSchema
  (restricted-schema [this]
    (assoc schema dispatch-key (apply s/enum (keys @sub-schemas)))))

(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))

;; Extension of an abstract class
(defrecord SchemaExtension [schema-name base-schema extended-schema]
  schema.core.Schema
  (walker [this]
    (s/subschema-walker extended-schema))
  (explain [this]
    (list 'extend-schema
          schema-name
          (s/schema-name base-schema)
          (s/explain (apply dissoc extended-schema (keys base-schema))))))

(defn extend-schema-fn [schema-name ^AbstractSchema abstract-schema dispatch-values extension]
  (let [schema-extension
        (s/schema-with-name
         (SchemaExtension.
          schema-name
          abstract-schema
          (assoc (map/merge-disjoint (.schema abstract-schema) extension)
            (.dispatch-key abstract-schema) (apply s/enum dispatch-values)))
         (name schema-name))]
    (swap! (safe-get abstract-schema :sub-schemas) map/merge-disjoint
           (into {} (for [v dispatch-values] [v schema-extension])))
    schema-extension))

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


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

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

;; Tests
(st/deftest abstract-schema-test
  (is-=
   {:age java.lang.Number 
    :type (s/enum :cat)
    :vegan? java.lang.Boolean}
   (restricted-schema Animal)))

(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))"))